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 @@ -203,6 +204,39 @@ # define d29 61 # define d30 62 # define d31 63 + +# define q0 32 +# define q1 33 +# define q2 34 +# define q3 35 +# define q4 36 +# define q5 37 +# define q6 38 +# define q7 39 +# define q8 40 +# define q9 41 +# define q10 42 +# define q11 43 +# define q12 44 +# define q13 45 +# define q14 46 +# define q15 47 +# define q16 48 +# define q17 49 +# define q18 50 +# define q19 51 +# define q20 52 +# define q21 53 +# define q22 54 +# define q23 55 +# define q24 56 +# define q25 57 +# define q26 58 +# define q27 59 +# define q28 60 +# define q29 61 +# define q30 62 +# define q31 63 #endif # if defined(MACHREGS_darwin) @@ -447,39 +481,40 @@ #endif +-- See also Note [Caller saves and callee-saves regs.] callerSaves :: GlobalReg -> Bool #if defined(CALLER_SAVES_Base) callerSaves BaseReg = True #endif #if defined(CALLER_SAVES_R1) -callerSaves (VanillaReg 1 _) = True +callerSaves (VanillaReg 1) = True #endif #if defined(CALLER_SAVES_R2) -callerSaves (VanillaReg 2 _) = True +callerSaves (VanillaReg 2) = True #endif #if defined(CALLER_SAVES_R3) -callerSaves (VanillaReg 3 _) = True +callerSaves (VanillaReg 3) = True #endif #if defined(CALLER_SAVES_R4) -callerSaves (VanillaReg 4 _) = True +callerSaves (VanillaReg 4) = True #endif #if defined(CALLER_SAVES_R5) -callerSaves (VanillaReg 5 _) = True +callerSaves (VanillaReg 5) = True #endif #if defined(CALLER_SAVES_R6) -callerSaves (VanillaReg 6 _) = True +callerSaves (VanillaReg 6) = True #endif #if defined(CALLER_SAVES_R7) -callerSaves (VanillaReg 7 _) = True +callerSaves (VanillaReg 7) = True #endif #if defined(CALLER_SAVES_R8) -callerSaves (VanillaReg 8 _) = True +callerSaves (VanillaReg 8) = True #endif #if defined(CALLER_SAVES_R9) -callerSaves (VanillaReg 9 _) = True +callerSaves (VanillaReg 9) = True #endif #if defined(CALLER_SAVES_R10) -callerSaves (VanillaReg 10 _) = True +callerSaves (VanillaReg 10) = True #endif #if defined(CALLER_SAVES_F1) callerSaves (FloatReg 1) = True @@ -555,34 +590,34 @@ ,Hp #endif #if defined(REG_R1) - ,VanillaReg 1 VGcPtr + ,VanillaReg 1 #endif #if defined(REG_R2) - ,VanillaReg 2 VGcPtr + ,VanillaReg 2 #endif #if defined(REG_R3) - ,VanillaReg 3 VGcPtr + ,VanillaReg 3 #endif #if defined(REG_R4) - ,VanillaReg 4 VGcPtr + ,VanillaReg 4 #endif #if defined(REG_R5) - ,VanillaReg 5 VGcPtr + ,VanillaReg 5 #endif #if defined(REG_R6) - ,VanillaReg 6 VGcPtr + ,VanillaReg 6 #endif #if defined(REG_R7) - ,VanillaReg 7 VGcPtr + ,VanillaReg 7 #endif #if defined(REG_R8) - ,VanillaReg 8 VGcPtr + ,VanillaReg 8 #endif #if defined(REG_R9) - ,VanillaReg 9 VGcPtr + ,VanillaReg 9 #endif #if defined(REG_R10) - ,VanillaReg 10 VGcPtr + ,VanillaReg 10 #endif #if defined(REG_SpLim) ,SpLim @@ -740,34 +775,34 @@ globalRegMaybe BaseReg = Just (RealRegSingle REG_Base) # endif # if defined(REG_R1) -globalRegMaybe (VanillaReg 1 _) = Just (RealRegSingle REG_R1) +globalRegMaybe (VanillaReg 1) = Just (RealRegSingle REG_R1) # endif # if defined(REG_R2) -globalRegMaybe (VanillaReg 2 _) = Just (RealRegSingle REG_R2) +globalRegMaybe (VanillaReg 2) = Just (RealRegSingle REG_R2) # endif # if defined(REG_R3) -globalRegMaybe (VanillaReg 3 _) = Just (RealRegSingle REG_R3) +globalRegMaybe (VanillaReg 3) = Just (RealRegSingle REG_R3) # endif # if defined(REG_R4) -globalRegMaybe (VanillaReg 4 _) = Just (RealRegSingle REG_R4) +globalRegMaybe (VanillaReg 4) = Just (RealRegSingle REG_R4) # endif # if defined(REG_R5) -globalRegMaybe (VanillaReg 5 _) = Just (RealRegSingle REG_R5) +globalRegMaybe (VanillaReg 5) = Just (RealRegSingle REG_R5) # endif # if defined(REG_R6) -globalRegMaybe (VanillaReg 6 _) = Just (RealRegSingle REG_R6) +globalRegMaybe (VanillaReg 6) = Just (RealRegSingle REG_R6) # endif # if defined(REG_R7) -globalRegMaybe (VanillaReg 7 _) = Just (RealRegSingle REG_R7) +globalRegMaybe (VanillaReg 7) = Just (RealRegSingle REG_R7) # endif # if defined(REG_R8) -globalRegMaybe (VanillaReg 8 _) = Just (RealRegSingle REG_R8) +globalRegMaybe (VanillaReg 8) = Just (RealRegSingle REG_R8) # endif # if defined(REG_R9) -globalRegMaybe (VanillaReg 9 _) = Just (RealRegSingle REG_R9) +globalRegMaybe (VanillaReg 9) = Just (RealRegSingle REG_R9) # endif # if defined(REG_R10) -globalRegMaybe (VanillaReg 10 _) = Just (RealRegSingle REG_R10) +globalRegMaybe (VanillaReg 10) = Just (RealRegSingle REG_R10) # endif # if defined(REG_F1) globalRegMaybe (FloatReg 1) = Just (RealRegSingle REG_F1) @@ -997,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 @@ -1,8 +1,10 @@ +{-# LANGUAGE MultiWayIf #-} {-# LANGUAGE CPP #-} {-# LANGUAGE NondecreasingIndentation, ScopedTypeVariables #-} {-# LANGUAGE TupleSections, NamedFieldPuns #-} -{-# LANGUAGE ViewPatterns #-} {-# 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,10 +346,12 @@ 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) import GHC.Driver.Config.Logger (initLogFlags) +import GHC.Driver.Config.StgToJS (initStgToJSConfig) import GHC.Driver.Config.Diagnostic import GHC.Driver.Main import GHC.Driver.Make @@ -336,6 +372,7 @@ 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 ) @@ -353,11 +390,11 @@ import GHC.Utils.TmpFs import GHC.Utils.Error +import GHC.Utils.Exception import GHC.Utils.Monad import GHC.Utils.Misc import GHC.Utils.Outputable import GHC.Utils.Panic -import GHC.Utils.Panic.Plain import GHC.Utils.Logger import GHC.Utils.Fingerprint @@ -371,6 +408,8 @@ import GHC.Core.InstEnv import GHC.Core +import GHC.Data.Maybe + import GHC.Types.Id import GHC.Types.Name hiding ( varName ) import GHC.Types.Avail @@ -387,14 +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.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 @@ -402,29 +438,30 @@ 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 ) +import Data.Word ( Word8 ) + import qualified Data.Map.Strict as Map import Data.Set (Set) +import qualified Data.Set as S import qualified Data.Sequence as Seq -import Data.Maybe -import Data.Typeable ( Typeable ) -import Data.Word ( Word8 ) -import Control.Monad + +import System.Directory +import System.Environment ( getEnv, getProgName ) import System.Exit ( exitWith, ExitCode(..) ) -import GHC.Utils.Exception -import Data.IORef import System.FilePath -import Control.Concurrent -import Control.Applicative ((<|>)) -import Control.Monad.Catch as MC - -import GHC.Data.Maybe import System.IO.Error ( isDoesNotExistError ) -import System.Environment ( getEnv, getProgName ) -import System.Directory -import Data.List (isPrefixOf) -import qualified Data.Set as S -- %************************************************************************ @@ -455,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 _ -> @@ -558,13 +597,13 @@ initGhcMonad :: GhcMonad m => Maybe FilePath -> m () initGhcMonad mb_top_dir = setSession =<< liftIO ( do +#if !defined(javascript_HOST_ARCH) -- The call to c_keepCAFsForGHCi must not be optimized away. Even in non-debug builds. -- So we can't use assertM here. -- See Note [keepCAFsForGHCi] in keepCAFsForGHCi.c for details about why. --- #if MIN_VERSION_GLASGOW_HASKELL(9,7,0,0) !keep_cafs <- c_keepCAFsForGHCi massert keep_cafs --- #endif +#endif initHscEnv mb_top_dir ) @@ -637,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 @@ -655,7 +694,7 @@ let !unit_env1 = if homeUnitId_ dflags /= uid then - ue_renameUnitId + UnitEnv.renameUnitId uid (homeUnitId_ dflags) unit_env0 @@ -673,16 +712,70 @@ setTopSessionDynFlags dflags = do hsc_env <- getSession logger <- getLogger + lookup_cache <- liftIO $ mkInterpSymbolCache - -- Interpreter - interp <- if gopt Opt_ExternalInterpreter dflags - then do + -- 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 let prog = pgm_i dflags ++ flavour 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 @@ -698,14 +791,17 @@ , iservConfHook = createIservProcessHook (hsc_hooks hsc_env) , iservConfTrace = tr } - s <- liftIO $ newMVar IServPending + s <- liftIO $ newMVar InterpPending loader <- liftIO Loader.uninitializedLoader - return (Just (Interp (ExternalInterp conf (IServ s)) loader)) - else + return (Just (Interp (ExternalInterp (ExtIServ (ExtInterpState conf s))) loader lookup_cache)) + + -- Internal interpreter + | otherwise + -> #if defined(HAVE_INTERNAL_INTERPRETER) do loader <- liftIO Loader.uninitializedLoader - return (Just (Interp InternalInterp loader)) + return (Just (Interp InternalInterp loader lookup_cache)) #else return Nothing #endif @@ -742,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 @@ -755,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 } @@ -769,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 @@ -791,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 } @@ -808,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 @@ -837,9 +1026,9 @@ => Logger -> DynFlags -> [Located String] - -> m (DynFlags, [Located String], [Warn]) + -> 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) @@ -930,16 +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 $ handleFlagWarnings logger print_config diag_opts (map (Warn WarningWithoutFlag) warnings) + 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 @@ -989,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 @@ -998,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 @@ -1026,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'. @@ -1133,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: @@ -1156,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 @@ -1191,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, @@ -1209,11 +1454,10 @@ ModuleInfo { minf_type_env = md_types details, minf_exports = md_exports details, - minf_rdr_env = Just (tcg_rdr_env tc_gbl_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. @@ -1302,8 +1546,7 @@ else return $ Right mod_guts - Nothing -> panic "compileToCoreModule: target FilePath not found in\ - module dependency graph" + Nothing -> panic "compileToCoreModule: target FilePath not found in module dependency graph" where -- two versions, based on whether we simplify (thus run tidyProgram, -- which returns a (CgGuts, ModDetails) pair, or not (in which case -- we just have a ModGuts. @@ -1325,162 +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 GlobalRdrEnv, -- 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] ] - -- - return (Just (ModuleInfo { - minf_type_env = mkTypeEnv tys, - minf_exports = avails, - minf_rdr_env = Just $! availsToGlobalRdrEnv (moduleName mdl) avails, - minf_instances = error "getModuleInfo: instances for package module unimplemented", - minf_iface = Just iface, - minf_safe = getSafeMode $ mi_trust iface, - minf_modBreaks = emptyModBreaks - })) - -availsToGlobalRdrEnv :: ModuleName -> [AvailInfo] -> GlobalRdrEnv -availsToGlobalRdrEnv mod_name avails - = mkGlobalRdrEnv (gresFromAvails (Just imp_spec) avails) - where - -- 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_name, is_as = mod_name, - 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, - 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 greMangledName . globalRdrEnvElts) (minf_rdr_env minf) - -modInfoExports :: ModuleInfo -> [Name] -modInfoExports minf = concatMap availNames $! minf_exports minf - -modInfoExportsWithSelectors :: ModuleInfo -> [Name] -modInfoExportsWithSelectors minf = concatMap availNamesWithSelectors $! 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 GlobalRdrEnv -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) @@ -1668,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 @@ -1693,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) @@ -1730,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 @@ -1765,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 @@ -1957,7 +2093,8 @@ mkApiErr :: DynFlags -> SDoc -> GhcApiError mkApiErr dflags msg = GhcApiError (showSDoc dflags msg) --- + +#if !defined(javascript_HOST_ARCH) foreign import ccall unsafe "keepCAFsForGHCi" c_keepCAFsForGHCi :: IO Bool - +#endif diff --git a/GHC/Builtin/Names.hs b/GHC/Builtin/Names.hs --- a/GHC/Builtin/Names.hs +++ b/GHC/Builtin/Names.hs @@ -4,2820 +4,2774 @@ \section[GHC.Builtin.Names]{Definitions of prelude modules and names} -Nota Bene: all Names defined in here should come from the base package - - - ModuleNames for prelude modules, - e.g. pREL_BASE_Name :: ModuleName - - - Modules for prelude modules - e.g. pREL_Base :: Module - - - Uniques for Ids, DataCons, TyCons and Classes that the compiler - "knows about" in some way - e.g. intTyConKey :: Unique - minusClassOpKey :: Unique - - - Names for Ids, DataCons, TyCons and Classes that the compiler - "knows about" in some way - e.g. intTyConName :: Name - minusName :: Name - One of these Names contains - (a) the module and occurrence name of the thing - (b) its Unique - The way the compiler "knows about" one of these things is - where the type checker or desugarer needs to look it up. For - example, when desugaring list comprehensions the desugarer - needs to conjure up 'foldr'. It does this by looking up - foldrName in the environment. - - - RdrNames for Ids, DataCons etc that the compiler may emit into - generated code (e.g. for deriving). It's not necessary to know - the uniques for these guys, only their names - - -Note [Known-key names] -~~~~~~~~~~~~~~~~~~~~~~ -It is *very* important that the compiler gives wired-in things and -things with "known-key" names the correct Uniques wherever they -occur. We have to be careful about this in exactly two places: - - 1. When we parse some source code, renaming the AST better yield an - AST whose Names have the correct uniques - - 2. When we read an interface file, the read-in gubbins better have - the right uniques - -This is accomplished through a combination of mechanisms: - - 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 - - -- 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 :: Int -> Module --- (mkInteractiveMoudule 9) makes module 'interactive:Ghci9' -mkInteractiveModule n = mkModule interactiveUnit (mkModuleName ("Ghci" ++ show 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 = varQual_RDR gHC_GENERICS (fsLit "unPar1") -unRec1_RDR = varQual_RDR gHC_GENERICS (fsLit "unRec1") -unK1_RDR = varQual_RDR gHC_GENERICS (fsLit "unK1") -unComp1_RDR = varQual_RDR gHC_GENERICS (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 = varQual_RDR gHC_GENERICS (fsLit "uAddr#") -uCharHash_RDR = varQual_RDR gHC_GENERICS (fsLit "uChar#") -uDoubleHash_RDR = varQual_RDR gHC_GENERICS (fsLit "uDouble#") -uFloatHash_RDR = varQual_RDR gHC_GENERICS (fsLit "uFloat#") -uIntHash_RDR = varQual_RDR gHC_GENERICS (fsLit "uInt#") -uWordHash_RDR = varQual_RDR gHC_GENERICS (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) - -{- -************************************************************************ -* * -\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 - --- 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 - --- 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 - --- Representations for primitive types -trTYPEKey - , trTYPE'PtrRepLiftedKey - , trRuntimeRepKey - , tr'PtrRepLiftedKey - , trLiftedRepKey - :: Unique -trTYPEKey = mkPreludeMiscIdUnique 512 -trTYPE'PtrRepLiftedKey = mkPreludeMiscIdUnique 513 -trRuntimeRepKey = mkPreludeMiscIdUnique 514 -tr'PtrRepLiftedKey = mkPreludeMiscIdUnique 515 -trLiftedRepKey = mkPreludeMiscIdUnique 516 - --- 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 - - -bitIntegerIdKey :: Unique -bitIntegerIdKey = mkPreludeMiscIdUnique 550 - -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 - ------------------------------------------------------- --- 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 - || any (n `hasKey`) - [ liftedTypeKindTyConKey, unliftedTypeKindTyConKey - , liftedDataConKey, unliftedDataConKey - , tYPETyConKey - , cONSTRAINTTyConKey - , runtimeRepTyConKey, boxedRepDataConKey - , eqTyConKey - , listTyConKey - , oneDataConKey - , manyDataConKey - , fUNTyConKey, unrestrictedFunTyConKey ] +Nota Bene: all Names defined in here should come from the base package, +the big-num package or (for plugins) the ghc package. + + - ModuleNames for prelude modules, + e.g. pRELUDE_NAME :: ModuleName + + - Modules for prelude modules + e.g. pRELUDE :: Module + + - Uniques for Ids, DataCons, TyCons and Classes that the compiler + "knows about" in some way + e.g. orderingTyConKey :: Unique + minusClassOpKey :: Unique + + - Names for Ids, DataCons, TyCons and Classes that the compiler + "knows about" in some way + e.g. orderingTyConName :: Name + minusName :: Name + One of these Names contains + (a) the module and occurrence name of the thing + (b) its Unique + The way the compiler "knows about" one of these things is + where the type checker or desugarer needs to look it up. For + example, when desugaring list comprehensions the desugarer + needs to conjure up 'foldr'. It does this by looking up + foldrName in the environment. + + - RdrNames for Ids, DataCons etc that the compiler may emit into + generated code (e.g. for deriving). + e.g. and_RDR :: RdrName + It's not necessary to know the uniques for these guys, only their names + + +Note [Known-key names] +~~~~~~~~~~~~~~~~~~~~~~ +It is *very* important that the compiler gives wired-in things and +things with "known-key" names the correct Uniques wherever they +occur. We have to be careful about this in exactly two places: + + 1. When we parse some source code, renaming the AST better yield an + AST whose Names have the correct uniques + + 2. When we read an interface file, the read-in gubbins better have + the right uniques + +This is accomplished through a combination of mechanisms: + + 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 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 @@ -11,9 +11,9 @@ import GHC.Builtin.Names( mk_known_key_name ) import GHC.Unit.Types import GHC.Types.Name( Name ) -import GHC.Types.Name.Occurrence( tcName, clsName, dataName, varName ) +import GHC.Types.Name.Occurrence( tcName, clsName, dataName, varName, fieldName ) import GHC.Types.Name.Reader( RdrName, nameRdrName ) -import GHC.Types.Unique +import GHC.Types.Unique ( Unique ) import GHC.Builtin.Uniques import GHC.Data.FastString @@ -31,7 +31,8 @@ templateHaskellNames = [ returnQName, bindQName, sequenceQName, newNameName, liftName, liftTypedName, - mkNameName, mkNameG_vName, mkNameG_dName, mkNameG_tcName, mkNameLName, + mkNameName, mkNameG_vName, mkNameG_dName, mkNameG_tcName, mkNameG_fldName, + mkNameLName, mkNameSName, mkNameQName, mkModNameName, liftStringName, @@ -46,6 +47,7 @@ litPName, varPName, tupPName, unboxedTupPName, unboxedSumPName, conPName, tildePName, bangPName, infixPName, asPName, wildPName, recPName, listPName, sigPName, viewPName, + typePName, invisPName, orPName, -- FieldPat fieldPatName, -- Match @@ -60,6 +62,7 @@ fromEName, fromThenEName, fromToEName, fromThenToEName, listEName, sigEName, recConEName, recUpdEName, staticEName, unboundVarEName, labelEName, implicitParamVarEName, getFieldEName, projectionEName, + typeEName, forallEName, forallVisEName, constrainedEName, -- FieldExp fieldExpName, -- Body @@ -72,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 @@ -109,8 +115,11 @@ -- TyVarBndr plainTVName, kindedTVName, plainInvisTVName, kindedInvisTVName, + plainBndrTVName, kindedBndrTVName, -- Specificity specifiedSpecName, inferredSpecName, + -- Visibility + bndrReqName, bndrInvisName, -- Role nominalRName, representationalRName, phantomRName, inferRName, -- Kind @@ -134,6 +143,9 @@ -- Overlap overlappableDataConName, overlappingDataConName, overlapsDataConName, incoherentDataConName, + -- NamespaceSpecifier + noNamespaceSpecifierDataConName, typeNamespaceSpecifierDataConName, + dataNamespaceSpecifierDataConName, -- DerivStrategy stockStrategyName, anyclassStrategyName, newtypeStrategyName, viaStrategyName, @@ -152,11 +164,14 @@ 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, - typeTyConName, tyVarBndrUnitTyConName, tyVarBndrSpecTyConName, clauseTyConName, + typeTyConName, + tyVarBndrUnitTyConName, tyVarBndrSpecTyConName, tyVarBndrVisTyConName, + clauseTyConName, patQTyConName, funDepTyConName, decsQTyConName, ruleBndrTyConName, tySynEqnTyConName, roleTyConName, codeTyConName, injAnnTyConName, kindTyConName, @@ -164,28 +179,35 @@ 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, qqFun :: 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 -qqFun = mk_known_key_name varName qqLib +liftFun = mk_known_key_name varName liftLib +thFld :: FastString -> FastString -> Unique -> Name +thFld con = mk_known_key_name (fieldName con) thSyn + +qqFld :: FastString -> Unique -> Name +qqFld = mk_known_key_name (fieldName (fsLit "QuasiQuoter")) qqLib + -------------------- TH.Syntax ----------------------- liftClassName :: Name -liftClassName = thCls (fsLit "Lift") liftClassKey +liftClassName = mk_known_key_name clsName liftLib (fsLit "Lift") liftClassKey quoteClassName :: Name quoteClassName = thCls (fsLit "Quote") quoteClassKey @@ -194,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 @@ -212,29 +234,31 @@ 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_dName, mkNameG_tcName, + mkNameName, mkNameG_vName, mkNameG_fldName, mkNameG_dName, mkNameG_tcName, mkNameLName, mkNameSName, liftStringName, unTypeName, unTypeCodeName, unsafeCodeCoerceName, liftTypedName, mkModNameName, mkNameQName :: Name returnQName = thFun (fsLit "returnQ") returnQIdKey bindQName = thFun (fsLit "bindQ") bindQIdKey sequenceQName = thFun (fsLit "sequenceQ") sequenceQIdKey newNameName = thFun (fsLit "newName") newNameIdKey -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 mkNameG_tcName = thFun (fsLit "mkNameG_tc") mkNameG_tcIdKey +mkNameG_fldName= thFun (fsLit "mkNameG_fld") mkNameG_fldIdKey mkNameLName = thFun (fsLit "mkNameL") mkNameLIdKey mkNameQName = thFun (fsLit "mkNameQ") mkNameQIdKey mkNameSName = thFun (fsLit "mkNameS") mkNameSIdKey mkModNameName = thFun (fsLit "mkModName") mkModNameIdKey -unTypeName = thFun (fsLit "unType") unTypeIdKey +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 ----------------------- @@ -256,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 @@ -272,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 @@ -290,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 @@ -331,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 @@ -357,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 @@ -381,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 @@ -492,11 +530,20 @@ plainInvisTVName = libFun (fsLit "plainInvisTV") plainInvisTVIdKey kindedInvisTVName = libFun (fsLit "kindedInvisTV") kindedInvisTVIdKey +plainBndrTVName, kindedBndrTVName :: Name +plainBndrTVName = libFun (fsLit "plainBndrTV") plainBndrTVIdKey +kindedBndrTVName = libFun (fsLit "kindedBndrTV") kindedBndrTVIdKey + -- data Specificity = ... specifiedSpecName, inferredSpecName :: Name specifiedSpecName = libFun (fsLit "specifiedSpec") specifiedSpecKey inferredSpecName = libFun (fsLit "inferredSpec") inferredSpecKey +-- data BndrVis = ... +bndrReqName, bndrInvisName :: Name +bndrReqName = libFun (fsLit "bndrReq") bndrReqKey +bndrInvisName = libFun (fsLit "bndrInvis") bndrInvisKey + -- data Role = ... nominalRName, representationalRName, phantomRName, inferRName :: Name nominalRName = libFun (fsLit "nominalR") nominalRIdKey @@ -569,7 +616,7 @@ varBangTypeTyConName, typeQTyConName, decsQTyConName, ruleBndrTyConName, tySynEqnTyConName, roleTyConName, derivClauseTyConName, kindTyConName, - tyVarBndrUnitTyConName, tyVarBndrSpecTyConName, + tyVarBndrUnitTyConName, tyVarBndrSpecTyConName, tyVarBndrVisTyConName, derivStrategyTyConName :: Name -- These are only used for the types of top-level splices expQTyConName = libTc (fsLit "ExpQ") expQTyConKey @@ -589,14 +636,15 @@ kindTyConName = thTc (fsLit "Kind") kindTyConKey tyVarBndrUnitTyConName = libTc (fsLit "TyVarBndrUnit") tyVarBndrUnitTyConKey tyVarBndrSpecTyConName = libTc (fsLit "TyVarBndrSpec") tyVarBndrSpecTyConKey +tyVarBndrVisTyConName = libTc (fsLit "TyVarBndrVis") tyVarBndrVisTyConKey derivStrategyTyConName = thTc (fsLit "DerivStrategy") derivStrategyTyConKey -- quasiquoting quoteExpName, quotePatName, quoteDecName, quoteTypeName :: Name -quoteExpName = qqFun (fsLit "quoteExp") quoteExpKey -quotePatName = qqFun (fsLit "quotePat") quotePatKey -quoteDecName = qqFun (fsLit "quoteDec") quoteDecKey -quoteTypeName = qqFun (fsLit "quoteType") quoteTypeKey +quoteExpName = qqFld (fsLit "quoteExp") quoteExpKey +quotePatName = qqFld (fsLit "quotePat") quotePatKey +quoteDecName = qqFld (fsLit "quoteDec") quoteDecKey +quoteTypeName = qqFld (fsLit "quoteType") quoteTypeKey -- data Inline = ... noInlineDataConName, inlineDataConName, inlinableDataConName :: Name @@ -625,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 @@ -652,14 +711,14 @@ expTyConKey, matchTyConKey, clauseTyConKey, qTyConKey, expQTyConKey, patTyConKey, stmtTyConKey, conTyConKey, typeQTyConKey, typeTyConKey, - tyVarBndrUnitTyConKey, tyVarBndrSpecTyConKey, + tyVarBndrUnitTyConKey, tyVarBndrSpecTyConKey, tyVarBndrVisTyConKey, decTyConKey, bangTypeTyConKey, varBangTypeTyConKey, fieldExpTyConKey, fieldPatTyConKey, nameTyConKey, patQTyConKey, funDepTyConKey, predTyConKey, predQTyConKey, decsQTyConKey, ruleBndrTyConKey, tySynEqnTyConKey, roleTyConKey, codeTyConKey, injAnnTyConKey, kindTyConKey, overlapTyConKey, derivClauseTyConKey, derivStrategyTyConKey, decsTyConKey, - modNameTyConKey :: Unique + modNameTyConKey, quasiQuoterTyConKey :: Unique expTyConKey = mkPreludeTyConUnique 200 matchTyConKey = mkPreludeTyConUnique 201 clauseTyConKey = mkPreludeTyConUnique 202 @@ -694,6 +753,8 @@ tyVarBndrSpecTyConKey = mkPreludeTyConUnique 237 codeTyConKey = mkPreludeTyConUnique 238 modNameTyConKey = mkPreludeTyConUnique 239 +tyVarBndrVisTyConKey = mkPreludeTyConUnique 240 +quasiQuoterTyConKey = mkPreludeTyConUnique 241 {- ********************************************************************* * * @@ -731,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 @@ -741,7 +809,7 @@ -- If you want to change this, make sure you check in GHC.Builtin.Names returnQIdKey, bindQIdKey, sequenceQIdKey, liftIdKey, newNameIdKey, - mkNameIdKey, mkNameG_vIdKey, mkNameG_dIdKey, mkNameG_tcIdKey, + mkNameIdKey, mkNameG_vIdKey, mkNameG_fldIdKey, mkNameG_dIdKey, mkNameG_tcIdKey, mkNameLIdKey, mkNameSIdKey, unTypeIdKey, unTypeCodeIdKey, unsafeCodeCoerceIdKey, liftTypedIdKey, mkModNameIdKey, mkNameQIdKey :: Unique returnQIdKey = mkPreludeMiscIdUnique 200 @@ -761,6 +829,7 @@ mkModNameIdKey = mkPreludeMiscIdUnique 215 unsafeCodeCoerceIdKey = mkPreludeMiscIdUnique 216 mkNameQIdKey = mkPreludeMiscIdUnique 217 +mkNameG_fldIdKey = mkPreludeMiscIdUnique 218 -- data Lit = ... @@ -784,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 @@ -800,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 @@ -822,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 @@ -859,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, @@ -889,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 @@ -914,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 @@ -928,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 @@ -1022,6 +1105,10 @@ plainInvisTVIdKey = mkPreludeMiscIdUnique 482 kindedInvisTVIdKey = mkPreludeMiscIdUnique 483 +plainBndrTVIdKey, kindedBndrTVIdKey :: Unique +plainBndrTVIdKey = mkPreludeMiscIdUnique 484 +kindedBndrTVIdKey = mkPreludeMiscIdUnique 485 + -- data Role = ... nominalRIdKey, representationalRIdKey, phantomRIdKey, inferRIdKey :: Unique nominalRIdKey = mkPreludeMiscIdUnique 416 @@ -1106,6 +1193,11 @@ specifiedSpecKey = mkPreludeMiscIdUnique 498 inferredSpecKey = mkPreludeMiscIdUnique 499 +-- data BndrVis = ... +bndrReqKey, bndrInvisKey :: Unique +bndrReqKey = mkPreludeMiscIdUnique 800 -- TODO (int-index): make up some room in the 5** numberspace? +bndrInvisKey = mkPreludeMiscIdUnique 801 + {- ************************************************************************ * * @@ -1114,27 +1206,7 @@ ************************************************************************ -} -lift_RDR, liftTyped_RDR, mkNameG_dRDR, mkNameG_vRDR, 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 - --- 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'. @@ -551,37 +651,44 @@ primOpIsDiv :: PrimOp -> Bool primOpIsDiv op = case op of - -- TODO: quotRemWord2, Int64, Word64 IntQuotOp -> True Int8QuotOp -> True Int16QuotOp -> True Int32QuotOp -> True + Int64QuotOp -> True IntRemOp -> True Int8RemOp -> True Int16RemOp -> True Int32RemOp -> True + Int64RemOp -> True IntQuotRemOp -> True Int8QuotRemOp -> True Int16QuotRemOp -> True Int32QuotRemOp -> True + -- Int64QuotRemOp doesn't exist (yet) WordQuotOp -> True Word8QuotOp -> True Word16QuotOp -> True Word32QuotOp -> True + Word64QuotOp -> True WordRemOp -> True Word8RemOp -> True Word16RemOp -> True Word32RemOp -> True + Word64RemOp -> True WordQuotRemOp -> True Word8QuotRemOp -> True Word16QuotRemOp -> True Word32QuotRemOp -> True + -- Word64QuotRemOp doesn't exist (yet) + WordQuotRem2Op -> True + FloatDivOp -> True DoubleDivOp -> True _ -> False @@ -752,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* @@ -762,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 @@ -810,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,2410 +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, 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 ) - -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: (,,) (,,)# - 2-tuples: (,) (,)# - 1-tuples: ?? - 0-tuples: () ()# - -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 () = () - data Solo a = MkSolo a - data (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) - where ns = occNameSpace occ - - tup_name boxity arity - = choose_ns (getName (tupleTyCon boxity arity)) - (getName (tupleDataCon boxity arity)) - --- 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 -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 _ 0 = "()" -mkBoxedTupleStr ns 1 | isDataConNameSpace ns = "MkSolo" -- See Note [One-tuples] -mkBoxedTupleStr _ 1 = "Solo" -- See Note [One-tuples] -mkBoxedTupleStr _ ar = '(' : commas 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 = take (ar-1) (repeat ',') - -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) 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_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 - -unitTyConKey :: Unique -unitTyConKey = getUnique unitTyCon - -unitDataCon :: DataCon -unitDataCon = head (tyConDataCons unitTyCon) - -unitDataConId :: Id -unitDataConId = dataConWorkId unitDataCon - -soloTyCon :: TyCon -soloTyCon = tupleTyCon Boxed 1 - -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 tyConPromDataConInfo (tyConAppTyCon lev) of - Levity Lifted -> [LiftedRep] - Levity Unlifted -> [UnliftedRep] - _ -> pprPanic "boxedRepDataCon" (ppr lev) - 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 }A - -- 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 $ - mkPromotedMaybeTy charSymbolPairKind (fmap reifyCharSymbolPairTy (unconsFS 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 - -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] - , mkPromotedMaybeTy charSymbolPairKind (fmap reifyCharSymbolPairTy (unconsFS 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 noInlieConstraintId 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. @@ -807,7 +807,7 @@ Wrinkles -(W1) In GHC.Core.RoughMap.roughMtchTyConName we are careful to map +(W1) In GHC.Core.RoughMap.roughMatchTyConName we are careful to map TYPE and CONSTRAINT to the same rough-map key. Reason: If we insert (F @Constraint tys) into a FamInstEnv, and look up (F @Type tys'), we /must/ ensure that the (C @Constraint tys) @@ -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. @@ -1042,8 +1042,8 @@ * It is "naturally coherent". This means that the solver won't hesitate to solve a goal of type (a ~~ b) even if there is, say (Int ~~ c) in the context. (Normally, it waits to learn more, just in case the given - influences what happens next.) See Note [Naturally coherent classes] - in GHC.Tc.Solver.Interact. + influences what happens next.) See Note [Solving equality classes] + in GHC.Tc.Solver.Dict * It always terminates. That is, in the UndecidableInstances checks, we don't worry if a (~~) constraint is too big, as we know that solving @@ -1052,7 +1052,7 @@ On the other hand, this behaves just like any class w.r.t. eager superclass unpacking in the solver. So a lifted equality given quickly becomes an unlifted equality given. This is good, because the solver knows all about unlifted -equalities. There is some special-casing in GHC.Tc.Solver.Interact.matchClassInst to +equalities. There is some special-casing in GHC.Tc.Solver.Dict.matchClassInst to pretend that there is an instance of this class, as we can't write the instance in Haskell. @@ -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,15 +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 @@ -30,10 +34,12 @@ , mkPreludeMiscIdUnique, mkPreludeDataConUnique , mkPreludeTyConUnique, mkPreludeClassUnique - , mkVarOccUnique, mkDataOccUnique, mkTvOccUnique, mkTcOccUnique , mkRegSingleUnique, mkRegPairUnique, mkRegClassUnique, mkRegSubUnique , mkCostCentreUnique + , varNSUnique, dataNSUnique, tvNSUnique, tcNSUnique + , mkFldNSUnique, isFldNSUnique + , mkBuiltinUnique , mkPseudoUniqueE @@ -63,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) @@ -118,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 @@ -222,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 @@ -270,6 +295,30 @@ mkTupleTyConUnique Boxed a = mkUniqueInt '4' (2*a) mkTupleTyConUnique Unboxed a = mkUniqueInt '5' (2*a) +-- | Inverse of 'mkTupleTyConUnique' +isTupleTyConUnique :: Unique -> Maybe (Boxity, Arity) +isTupleTyConUnique u = + case (tag, i) of + ('4', 0) -> Just (Boxed, arity) + ('5', 0) -> Just (Unboxed, arity) + _ -> Nothing + 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 getTupleTyConName boxity n = case n `divMod` 2 of @@ -370,13 +419,18 @@ mkCostCentreUnique :: Int -> Unique mkCostCentreUnique = mkUniqueInt 'C' +varNSUnique, dataNSUnique, tvNSUnique, tcNSUnique :: Unique +varNSUnique = mkUnique 'i' 0 +dataNSUnique = mkUnique 'd' 0 +tvNSUnique = mkUnique 'v' 0 +tcNSUnique = mkUnique 'c' 0 -mkVarOccUnique, mkDataOccUnique, mkTvOccUnique, mkTcOccUnique :: FastString -> Unique --- See Note [The Unique of an OccName] in GHC.Types.Name.Occurrence -mkVarOccUnique fs = mkUniqueInt 'i' (uniqueOfFS fs) -mkDataOccUnique fs = mkUniqueInt 'd' (uniqueOfFS fs) -mkTvOccUnique fs = mkUniqueInt 'v' (uniqueOfFS fs) -mkTcOccUnique fs = mkUniqueInt 'c' (uniqueOfFS fs) +mkFldNSUnique :: FastString -> Unique +mkFldNSUnique fs = mkUniqueInt 'f' (uniqueOfFS fs) + +isFldNSUnique :: Unique -> Bool +isFldNSUnique uniq = case unpkUnique uniq of + (tag, _) -> tag == 'f' initExitJoinUnique :: Unique initExitJoinUnique = mkUnique 's' 0 diff --git a/GHC/Builtin/Uniques.hs-boot b/GHC/Builtin/Uniques.hs-boot --- a/GHC/Builtin/Uniques.hs-boot +++ b/GHC/Builtin/Uniques.hs-boot @@ -4,7 +4,6 @@ import GHC.Types.Unique import {-# SOURCE #-} GHC.Types.Name import GHC.Types.Basic -import GHC.Data.FastString -- Needed by GHC.Builtin.Types knownUniqueName :: Unique -> Maybe Name @@ -27,7 +26,6 @@ mkPseudoUniqueE, mkBuiltinUnique :: Int -> Unique mkRegSingleUnique, mkRegPairUnique, mkRegSubUnique, mkRegClassUnique :: Int -> Unique -mkVarOccUnique, mkDataOccUnique, mkTvOccUnique, mkTcOccUnique :: FastString -> Unique initExitJoinUnique :: Unique 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. @@ -239,21 +239,76 @@ ghcPrimExports :: [IfaceExport] ghcPrimExports - = map (avail . idName) ghcPrimIds ++ - map (avail . idName) allThePrimOpIds ++ - [ availTC n [n] [] - | tc <- exposedPrimTyCons, let n = tyConName tc ] + = map (Avail . idName) ghcPrimIds ++ + map (Avail . idName) allThePrimOpIds ++ + [ AvailTC n [n] + | tc <- exposedPrimTyCons, let n = tyConName tc ] ghcPrimDeclDocs :: Docs ghcPrimDeclDocs = emptyDocs { docs_decls = listToUniqMap $ mapMaybe findName primOpDocs } where - 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/bytearray-ops.txt.pp b/GHC/Builtin/bytearray-ops.txt.pp deleted file mode 100644 --- a/GHC/Builtin/bytearray-ops.txt.pp +++ /dev/null @@ -1,551 +0,0 @@ - ------------------------------------- --- ByteArray# operations ------------------------------------- - - --- Do not edit. This file is generated by utils/genprimopcode/gen_bytearray_ops.py. --- To regenerate run, --- --- python3 utils/genprimops/gen_bytearray_ops.py > compiler/GHC/Builtin/bytearray-ops.txt.pp - - ------------------------------------- --- aligned index operations ------------------------------------- - -primop IndexByteArrayOp_Char "indexCharArray#" GenPrimOp - ByteArray# -> Int# -> Char# - {Read a 8-bit character; offset in bytes.} - with can_fail = True - -primop IndexByteArrayOp_WideChar "indexWideCharArray#" GenPrimOp - ByteArray# -> Int# -> Char# - {Read a 32-bit character; offset in 4-byte words.} - with can_fail = True - -primop IndexByteArrayOp_Int "indexIntArray#" GenPrimOp - ByteArray# -> Int# -> Int# - {Read a word-sized integer; offset in machine words.} - with can_fail = True - -primop IndexByteArrayOp_Word "indexWordArray#" GenPrimOp - ByteArray# -> Int# -> Word# - {Read a word-sized unsigned integer; offset in machine words.} - with can_fail = True - -primop IndexByteArrayOp_Addr "indexAddrArray#" GenPrimOp - ByteArray# -> Int# -> Addr# - {Read a machine address; offset in machine words.} - with can_fail = True - -primop IndexByteArrayOp_Float "indexFloatArray#" GenPrimOp - ByteArray# -> Int# -> Float# - {Read a single-precision floating-point value; offset in 4-byte words.} - with can_fail = True - -primop IndexByteArrayOp_Double "indexDoubleArray#" GenPrimOp - ByteArray# -> Int# -> Double# - {Read a double-precision floating-point value; offset in 8-byte words.} - with can_fail = True - -primop IndexByteArrayOp_StablePtr "indexStablePtrArray#" GenPrimOp - ByteArray# -> Int# -> StablePtr# a - {Read a 'StablePtr#' value; offset in machine words.} - with can_fail = True - -primop IndexByteArrayOp_Int8 "indexInt8Array#" GenPrimOp - ByteArray# -> Int# -> Int8# - {Read a 8-bit signed integer; offset in bytes.} - with can_fail = True - -primop IndexByteArrayOp_Int16 "indexInt16Array#" GenPrimOp - ByteArray# -> Int# -> Int16# - {Read a 16-bit signed integer; offset in 2-byte words.} - with can_fail = True - -primop IndexByteArrayOp_Int32 "indexInt32Array#" GenPrimOp - ByteArray# -> Int# -> Int32# - {Read a 32-bit signed integer; offset in 4-byte words.} - with can_fail = True - -primop IndexByteArrayOp_Int64 "indexInt64Array#" GenPrimOp - ByteArray# -> Int# -> Int64# - {Read a 64-bit signed integer; offset in 8-byte words.} - with can_fail = True - -primop IndexByteArrayOp_Word8 "indexWord8Array#" GenPrimOp - ByteArray# -> Int# -> Word8# - {Read a 8-bit unsigned integer; offset in bytes.} - with can_fail = True - -primop IndexByteArrayOp_Word16 "indexWord16Array#" GenPrimOp - ByteArray# -> Int# -> Word16# - {Read a 16-bit unsigned integer; offset in 2-byte words.} - with can_fail = True - -primop IndexByteArrayOp_Word32 "indexWord32Array#" GenPrimOp - ByteArray# -> Int# -> Word32# - {Read a 32-bit unsigned integer; offset in 4-byte words.} - with can_fail = True - -primop IndexByteArrayOp_Word64 "indexWord64Array#" GenPrimOp - ByteArray# -> Int# -> Word64# - {Read a 64-bit unsigned integer; offset in 8-byte words.} - with can_fail = True - - ------------------------------------- --- unaligned index operations ------------------------------------- - -primop IndexByteArrayOp_Word8AsChar "indexWord8ArrayAsChar#" GenPrimOp - ByteArray# -> Int# -> Char# - {Read a 8-bit character; offset in bytes.} - with can_fail = True - -primop IndexByteArrayOp_Word8AsWideChar "indexWord8ArrayAsWideChar#" GenPrimOp - ByteArray# -> Int# -> Char# - {Read a 32-bit character; offset in bytes.} - with can_fail = True - -primop IndexByteArrayOp_Word8AsInt "indexWord8ArrayAsInt#" GenPrimOp - ByteArray# -> Int# -> Int# - {Read a word-sized integer; offset in bytes.} - with can_fail = True - -primop IndexByteArrayOp_Word8AsWord "indexWord8ArrayAsWord#" GenPrimOp - ByteArray# -> Int# -> Word# - {Read a word-sized unsigned integer; offset in bytes.} - with can_fail = True - -primop IndexByteArrayOp_Word8AsAddr "indexWord8ArrayAsAddr#" GenPrimOp - ByteArray# -> Int# -> Addr# - {Read a machine address; offset in bytes.} - with can_fail = True - -primop IndexByteArrayOp_Word8AsFloat "indexWord8ArrayAsFloat#" GenPrimOp - ByteArray# -> Int# -> Float# - {Read a single-precision floating-point value; offset in bytes.} - with can_fail = True - -primop IndexByteArrayOp_Word8AsDouble "indexWord8ArrayAsDouble#" GenPrimOp - ByteArray# -> Int# -> Double# - {Read a double-precision floating-point value; offset in bytes.} - with can_fail = True - -primop IndexByteArrayOp_Word8AsStablePtr "indexWord8ArrayAsStablePtr#" GenPrimOp - ByteArray# -> Int# -> StablePtr# a - {Read a 'StablePtr#' value; offset in bytes.} - with can_fail = True - -primop IndexByteArrayOp_Word8AsInt16 "indexWord8ArrayAsInt16#" GenPrimOp - ByteArray# -> Int# -> Int16# - {Read a 16-bit signed integer; offset in bytes.} - with can_fail = True - -primop IndexByteArrayOp_Word8AsInt32 "indexWord8ArrayAsInt32#" GenPrimOp - ByteArray# -> Int# -> Int32# - {Read a 32-bit signed integer; offset in bytes.} - with can_fail = True - -primop IndexByteArrayOp_Word8AsInt64 "indexWord8ArrayAsInt64#" GenPrimOp - ByteArray# -> Int# -> Int64# - {Read a 64-bit signed integer; offset in bytes.} - with can_fail = True - -primop IndexByteArrayOp_Word8AsWord16 "indexWord8ArrayAsWord16#" GenPrimOp - ByteArray# -> Int# -> Word16# - {Read a 16-bit unsigned integer; offset in bytes.} - with can_fail = True - -primop IndexByteArrayOp_Word8AsWord32 "indexWord8ArrayAsWord32#" GenPrimOp - ByteArray# -> Int# -> Word32# - {Read a 32-bit unsigned integer; offset in bytes.} - with can_fail = True - -primop IndexByteArrayOp_Word8AsWord64 "indexWord8ArrayAsWord64#" GenPrimOp - ByteArray# -> Int# -> Word64# - {Read a 64-bit unsigned integer; offset in bytes.} - with can_fail = True - - ------------------------------------- --- aligned read operations ------------------------------------- - -primop ReadByteArrayOp_Char "readCharArray#" GenPrimOp - MutableByteArray# s -> Int# -> State# s -> (# State# s, Char# #) - {Read a 8-bit character; offset in bytes.} - with has_side_effects = True - can_fail = True - -primop ReadByteArrayOp_WideChar "readWideCharArray#" GenPrimOp - MutableByteArray# s -> Int# -> State# s -> (# State# s, Char# #) - {Read a 32-bit character; offset in 4-byte words.} - with has_side_effects = True - can_fail = True - -primop ReadByteArrayOp_Int "readIntArray#" GenPrimOp - MutableByteArray# s -> Int# -> State# s -> (# State# s, Int# #) - {Read a word-sized integer; offset in machine words.} - with has_side_effects = True - can_fail = True - -primop ReadByteArrayOp_Word "readWordArray#" GenPrimOp - MutableByteArray# s -> Int# -> State# s -> (# State# s, Word# #) - {Read a word-sized unsigned integer; offset in machine words.} - with has_side_effects = True - can_fail = True - -primop ReadByteArrayOp_Addr "readAddrArray#" GenPrimOp - MutableByteArray# s -> Int# -> State# s -> (# State# s, Addr# #) - {Read a machine address; offset in machine words.} - with has_side_effects = True - can_fail = True - -primop ReadByteArrayOp_Float "readFloatArray#" GenPrimOp - MutableByteArray# s -> Int# -> State# s -> (# State# s, Float# #) - {Read a single-precision floating-point value; offset in 4-byte words.} - with has_side_effects = True - can_fail = True - -primop ReadByteArrayOp_Double "readDoubleArray#" GenPrimOp - MutableByteArray# s -> Int# -> State# s -> (# State# s, Double# #) - {Read a double-precision floating-point value; offset in 8-byte words.} - with has_side_effects = True - can_fail = True - -primop ReadByteArrayOp_StablePtr "readStablePtrArray#" GenPrimOp - MutableByteArray# s -> Int# -> State# s -> (# State# s, StablePtr# a #) - {Read a 'StablePtr#' value; offset in machine words.} - with has_side_effects = True - can_fail = True - -primop ReadByteArrayOp_Int8 "readInt8Array#" GenPrimOp - MutableByteArray# s -> Int# -> State# s -> (# State# s, Int8# #) - {Read a 8-bit signed integer; offset in bytes.} - with has_side_effects = True - can_fail = True - -primop ReadByteArrayOp_Int16 "readInt16Array#" GenPrimOp - MutableByteArray# s -> Int# -> State# s -> (# State# s, Int16# #) - {Read a 16-bit signed integer; offset in 2-byte words.} - with has_side_effects = True - can_fail = True - -primop ReadByteArrayOp_Int32 "readInt32Array#" GenPrimOp - MutableByteArray# s -> Int# -> State# s -> (# State# s, Int32# #) - {Read a 32-bit signed integer; offset in 4-byte words.} - with has_side_effects = True - can_fail = True - -primop ReadByteArrayOp_Int64 "readInt64Array#" GenPrimOp - MutableByteArray# s -> Int# -> State# s -> (# State# s, Int64# #) - {Read a 64-bit signed integer; offset in 8-byte words.} - with has_side_effects = True - can_fail = True - -primop ReadByteArrayOp_Word8 "readWord8Array#" GenPrimOp - MutableByteArray# s -> Int# -> State# s -> (# State# s, Word8# #) - {Read a 8-bit unsigned integer; offset in bytes.} - with has_side_effects = True - can_fail = True - -primop ReadByteArrayOp_Word16 "readWord16Array#" GenPrimOp - MutableByteArray# s -> Int# -> State# s -> (# State# s, Word16# #) - {Read a 16-bit unsigned integer; offset in 2-byte words.} - with has_side_effects = True - can_fail = True - -primop ReadByteArrayOp_Word32 "readWord32Array#" GenPrimOp - MutableByteArray# s -> Int# -> State# s -> (# State# s, Word32# #) - {Read a 32-bit unsigned integer; offset in 4-byte words.} - with has_side_effects = True - can_fail = True - -primop ReadByteArrayOp_Word64 "readWord64Array#" GenPrimOp - MutableByteArray# s -> Int# -> State# s -> (# State# s, Word64# #) - {Read a 64-bit unsigned integer; offset in 8-byte words.} - with has_side_effects = True - can_fail = True - - ------------------------------------- --- unaligned read operations ------------------------------------- - -primop ReadByteArrayOp_Word8AsChar "readWord8ArrayAsChar#" GenPrimOp - MutableByteArray# s -> Int# -> State# s -> (# State# s, Char# #) - {Read a 8-bit character; offset in bytes.} - with has_side_effects = True - can_fail = True - -primop ReadByteArrayOp_Word8AsWideChar "readWord8ArrayAsWideChar#" GenPrimOp - MutableByteArray# s -> Int# -> State# s -> (# State# s, Char# #) - {Read a 32-bit character; offset in bytes.} - with has_side_effects = True - can_fail = True - -primop ReadByteArrayOp_Word8AsInt "readWord8ArrayAsInt#" GenPrimOp - MutableByteArray# s -> Int# -> State# s -> (# State# s, Int# #) - {Read a word-sized integer; offset in bytes.} - with has_side_effects = True - can_fail = True - -primop ReadByteArrayOp_Word8AsWord "readWord8ArrayAsWord#" GenPrimOp - MutableByteArray# s -> Int# -> State# s -> (# State# s, Word# #) - {Read a word-sized unsigned integer; offset in bytes.} - with has_side_effects = True - can_fail = True - -primop ReadByteArrayOp_Word8AsAddr "readWord8ArrayAsAddr#" GenPrimOp - MutableByteArray# s -> Int# -> State# s -> (# State# s, Addr# #) - {Read a machine address; offset in bytes.} - with has_side_effects = True - can_fail = True - -primop ReadByteArrayOp_Word8AsFloat "readWord8ArrayAsFloat#" GenPrimOp - MutableByteArray# s -> Int# -> State# s -> (# State# s, Float# #) - {Read a single-precision floating-point value; offset in bytes.} - with has_side_effects = True - can_fail = True - -primop ReadByteArrayOp_Word8AsDouble "readWord8ArrayAsDouble#" GenPrimOp - MutableByteArray# s -> Int# -> State# s -> (# State# s, Double# #) - {Read a double-precision floating-point value; offset in bytes.} - with has_side_effects = True - can_fail = True - -primop ReadByteArrayOp_Word8AsStablePtr "readWord8ArrayAsStablePtr#" GenPrimOp - MutableByteArray# s -> Int# -> State# s -> (# State# s, StablePtr# a #) - {Read a 'StablePtr#' value; offset in bytes.} - with has_side_effects = True - can_fail = True - -primop ReadByteArrayOp_Word8AsInt16 "readWord8ArrayAsInt16#" GenPrimOp - MutableByteArray# s -> Int# -> State# s -> (# State# s, Int16# #) - {Read a 16-bit signed integer; offset in bytes.} - with has_side_effects = True - can_fail = True - -primop ReadByteArrayOp_Word8AsInt32 "readWord8ArrayAsInt32#" GenPrimOp - MutableByteArray# s -> Int# -> State# s -> (# State# s, Int32# #) - {Read a 32-bit signed integer; offset in bytes.} - with has_side_effects = True - can_fail = True - -primop ReadByteArrayOp_Word8AsInt64 "readWord8ArrayAsInt64#" GenPrimOp - MutableByteArray# s -> Int# -> State# s -> (# State# s, Int64# #) - {Read a 64-bit signed integer; offset in bytes.} - with has_side_effects = True - can_fail = True - -primop ReadByteArrayOp_Word8AsWord16 "readWord8ArrayAsWord16#" GenPrimOp - MutableByteArray# s -> Int# -> State# s -> (# State# s, Word16# #) - {Read a 16-bit unsigned integer; offset in bytes.} - with has_side_effects = True - can_fail = True - -primop ReadByteArrayOp_Word8AsWord32 "readWord8ArrayAsWord32#" GenPrimOp - MutableByteArray# s -> Int# -> State# s -> (# State# s, Word32# #) - {Read a 32-bit unsigned integer; offset in bytes.} - with has_side_effects = True - can_fail = True - -primop ReadByteArrayOp_Word8AsWord64 "readWord8ArrayAsWord64#" GenPrimOp - MutableByteArray# s -> Int# -> State# s -> (# State# s, Word64# #) - {Read a 64-bit unsigned integer; offset in bytes.} - with has_side_effects = True - can_fail = True - - ------------------------------------- --- aligned write operations ------------------------------------- - -primop WriteByteArrayOp_Char "writeCharArray#" GenPrimOp - MutableByteArray# s -> Int# -> Char# -> State# s -> State# s - {Write a 8-bit character; offset in bytes.} - with has_side_effects = True - can_fail = True - -primop WriteByteArrayOp_WideChar "writeWideCharArray#" GenPrimOp - MutableByteArray# s -> Int# -> Char# -> State# s -> State# s - {Write a 32-bit character; offset in 4-byte words.} - with has_side_effects = True - can_fail = True - -primop WriteByteArrayOp_Int "writeIntArray#" GenPrimOp - MutableByteArray# s -> Int# -> Int# -> State# s -> State# s - {Write a word-sized integer; offset in machine words.} - with has_side_effects = True - can_fail = True - -primop WriteByteArrayOp_Word "writeWordArray#" GenPrimOp - MutableByteArray# s -> Int# -> Word# -> State# s -> State# s - {Write a word-sized unsigned integer; offset in machine words.} - with has_side_effects = True - can_fail = True - -primop WriteByteArrayOp_Addr "writeAddrArray#" GenPrimOp - MutableByteArray# s -> Int# -> Addr# -> State# s -> State# s - {Write a machine address; offset in machine words.} - with has_side_effects = True - can_fail = True - -primop WriteByteArrayOp_Float "writeFloatArray#" GenPrimOp - MutableByteArray# s -> Int# -> Float# -> State# s -> State# s - {Write a single-precision floating-point value; offset in 4-byte words.} - with has_side_effects = True - can_fail = True - -primop WriteByteArrayOp_Double "writeDoubleArray#" GenPrimOp - MutableByteArray# s -> Int# -> Double# -> State# s -> State# s - {Write a double-precision floating-point value; offset in 8-byte words.} - with has_side_effects = True - can_fail = True - -primop WriteByteArrayOp_StablePtr "writeStablePtrArray#" GenPrimOp - MutableByteArray# s -> Int# -> StablePtr# a -> State# s -> State# s - {Write a 'StablePtr#' value; offset in machine words.} - with has_side_effects = True - can_fail = True - -primop WriteByteArrayOp_Int8 "writeInt8Array#" GenPrimOp - MutableByteArray# s -> Int# -> Int8# -> State# s -> State# s - {Write a 8-bit signed integer; offset in bytes.} - with has_side_effects = True - can_fail = True - -primop WriteByteArrayOp_Int16 "writeInt16Array#" GenPrimOp - MutableByteArray# s -> Int# -> Int16# -> State# s -> State# s - {Write a 16-bit signed integer; offset in 2-byte words.} - with has_side_effects = True - can_fail = True - -primop WriteByteArrayOp_Int32 "writeInt32Array#" GenPrimOp - MutableByteArray# s -> Int# -> Int32# -> State# s -> State# s - {Write a 32-bit signed integer; offset in 4-byte words.} - with has_side_effects = True - can_fail = True - -primop WriteByteArrayOp_Int64 "writeInt64Array#" GenPrimOp - MutableByteArray# s -> Int# -> Int64# -> State# s -> State# s - {Write a 64-bit signed integer; offset in 8-byte words.} - with has_side_effects = True - can_fail = True - -primop WriteByteArrayOp_Word8 "writeWord8Array#" GenPrimOp - MutableByteArray# s -> Int# -> Word8# -> State# s -> State# s - {Write a 8-bit unsigned integer; offset in bytes.} - with has_side_effects = True - can_fail = True - -primop WriteByteArrayOp_Word16 "writeWord16Array#" GenPrimOp - MutableByteArray# s -> Int# -> Word16# -> State# s -> State# s - {Write a 16-bit unsigned integer; offset in 2-byte words.} - with has_side_effects = True - can_fail = True - -primop WriteByteArrayOp_Word32 "writeWord32Array#" GenPrimOp - MutableByteArray# s -> Int# -> Word32# -> State# s -> State# s - {Write a 32-bit unsigned integer; offset in 4-byte words.} - with has_side_effects = True - can_fail = True - -primop WriteByteArrayOp_Word64 "writeWord64Array#" GenPrimOp - MutableByteArray# s -> Int# -> Word64# -> State# s -> State# s - {Write a 64-bit unsigned integer; offset in 8-byte words.} - with has_side_effects = True - can_fail = True - - ------------------------------------- --- unaligned write operations ------------------------------------- - -primop WriteByteArrayOp_Word8AsChar "writeWord8ArrayAsChar#" GenPrimOp - MutableByteArray# s -> Int# -> Char# -> State# s -> State# s - {Write a 8-bit character; offset in bytes.} - with has_side_effects = True - can_fail = True - -primop WriteByteArrayOp_Word8AsWideChar "writeWord8ArrayAsWideChar#" GenPrimOp - MutableByteArray# s -> Int# -> Char# -> State# s -> State# s - {Write a 32-bit character; offset in bytes.} - with has_side_effects = True - can_fail = True - -primop WriteByteArrayOp_Word8AsInt "writeWord8ArrayAsInt#" GenPrimOp - MutableByteArray# s -> Int# -> Int# -> State# s -> State# s - {Write a word-sized integer; offset in bytes.} - with has_side_effects = True - can_fail = True - -primop WriteByteArrayOp_Word8AsWord "writeWord8ArrayAsWord#" GenPrimOp - MutableByteArray# s -> Int# -> Word# -> State# s -> State# s - {Write a word-sized unsigned integer; offset in bytes.} - with has_side_effects = True - can_fail = True - -primop WriteByteArrayOp_Word8AsAddr "writeWord8ArrayAsAddr#" GenPrimOp - MutableByteArray# s -> Int# -> Addr# -> State# s -> State# s - {Write a machine address; offset in bytes.} - with has_side_effects = True - can_fail = True - -primop WriteByteArrayOp_Word8AsFloat "writeWord8ArrayAsFloat#" GenPrimOp - MutableByteArray# s -> Int# -> Float# -> State# s -> State# s - {Write a single-precision floating-point value; offset in bytes.} - with has_side_effects = True - can_fail = True - -primop WriteByteArrayOp_Word8AsDouble "writeWord8ArrayAsDouble#" GenPrimOp - MutableByteArray# s -> Int# -> Double# -> State# s -> State# s - {Write a double-precision floating-point value; offset in bytes.} - with has_side_effects = True - can_fail = True - -primop WriteByteArrayOp_Word8AsStablePtr "writeWord8ArrayAsStablePtr#" GenPrimOp - MutableByteArray# s -> Int# -> StablePtr# a -> State# s -> State# s - {Write a 'StablePtr#' value; offset in bytes.} - with has_side_effects = True - can_fail = True - -primop WriteByteArrayOp_Word8AsInt16 "writeWord8ArrayAsInt16#" GenPrimOp - MutableByteArray# s -> Int# -> Int16# -> State# s -> State# s - {Write a 16-bit signed integer; offset in bytes.} - with has_side_effects = True - can_fail = True - -primop WriteByteArrayOp_Word8AsInt32 "writeWord8ArrayAsInt32#" GenPrimOp - MutableByteArray# s -> Int# -> Int32# -> State# s -> State# s - {Write a 32-bit signed integer; offset in bytes.} - with has_side_effects = True - can_fail = True - -primop WriteByteArrayOp_Word8AsInt64 "writeWord8ArrayAsInt64#" GenPrimOp - MutableByteArray# s -> Int# -> Int64# -> State# s -> State# s - {Write a 64-bit signed integer; offset in bytes.} - with has_side_effects = True - can_fail = True - -primop WriteByteArrayOp_Word8AsWord16 "writeWord8ArrayAsWord16#" GenPrimOp - MutableByteArray# s -> Int# -> Word16# -> State# s -> State# s - {Write a 16-bit unsigned integer; offset in bytes.} - with has_side_effects = True - can_fail = True - -primop WriteByteArrayOp_Word8AsWord32 "writeWord8ArrayAsWord32#" GenPrimOp - MutableByteArray# s -> Int# -> Word32# -> State# s -> State# s - {Write a 32-bit unsigned integer; offset in bytes.} - with has_side_effects = True - can_fail = True - -primop WriteByteArrayOp_Word8AsWord64 "writeWord8ArrayAsWord64#" GenPrimOp - MutableByteArray# s -> Int# -> Word64# -> State# s -> State# s - {Write a 64-bit unsigned integer; offset in bytes.} - with has_side_effects = True - can_fail = True - 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,4174 +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.} -primop Pdep16Op "pdep16#" GenPrimOp Word# -> Word# -> Word# - {Deposit bits to lower 16 bits of a word at locations specified by a mask.} -primop Pdep32Op "pdep32#" GenPrimOp Word# -> Word# -> Word# - {Deposit bits to lower 32 bits of a word at locations specified by a mask.} -primop Pdep64Op "pdep64#" GenPrimOp Word64# -> Word64# -> Word64# - {Deposit bits to a word at locations specified by a mask.} -primop PdepOp "pdep#" GenPrimOp Word# -> Word# -> Word# - {Deposit bits to a word at locations specified by a mask.} - -primop Pext8Op "pext8#" GenPrimOp Word# -> Word# -> Word# - {Extract bits from lower 8 bits of a word at locations specified by a mask.} -primop Pext16Op "pext16#" GenPrimOp Word# -> Word# -> Word# - {Extract bits from lower 16 bits of a word at locations specified by a mask.} -primop Pext32Op "pext32#" GenPrimOp Word# -> Word# -> Word# - {Extract bits from lower 32 bits of a word at locations specified by a mask.} -primop Pext64Op "pext64#" GenPrimOp Word64# -> Word64# -> Word64# - {Extract bits from a word at locations specified by a mask.} -primop PextOp "pext#" GenPrimOp Word# -> Word# -> Word# - {Extract bits from a word at locations specified by a mask.} - -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 "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#'.} - 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. Note that this is deprecated - as it is unsafe in the presence of shrink and resize 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.} - -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#'.} - with out_of_line = True - has_side_effects = True - -primop ResizeMutableByteArrayOp_Char "resizeMutableByteArray#" GenPrimOp - MutableByteArray# s -> Int# -> State# s -> (# State# s,MutableByteArray# s #) - {Resize (unpinned) mutable byte array to new specified size (in bytes). - 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.} - 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. Note that this is deprecated as it is - unsafe in the presence of shrink and resize 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.} - -#include "bytearray-ops.txt.pp" - -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 n@ copies the range - starting at offset @src_ofs@ of length @n@ 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 - {Copy a range of the first MutableByteArray\# to the specified region in the second MutableByteArray\#. - 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 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 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 - --- 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# - -primop IndexOffAddrOp_Char "indexCharOffAddr#" GenPrimOp - Addr# -> Int# -> Char# - {Reads 8-bit character; offset in bytes.} - with can_fail = True - -primop IndexOffAddrOp_WideChar "indexWideCharOffAddr#" GenPrimOp - Addr# -> Int# -> Char# - {Reads 31-bit character; offset in 4-byte words.} - with can_fail = True - -primop IndexOffAddrOp_Int "indexIntOffAddr#" GenPrimOp - Addr# -> Int# -> Int# - with can_fail = True - -primop IndexOffAddrOp_Word "indexWordOffAddr#" GenPrimOp - Addr# -> Int# -> Word# - with can_fail = True - -primop IndexOffAddrOp_Addr "indexAddrOffAddr#" GenPrimOp - Addr# -> Int# -> Addr# - with can_fail = True - -primop IndexOffAddrOp_Float "indexFloatOffAddr#" GenPrimOp - Addr# -> Int# -> Float# - with can_fail = True - -primop IndexOffAddrOp_Double "indexDoubleOffAddr#" GenPrimOp - Addr# -> Int# -> Double# - with can_fail = True - -primop IndexOffAddrOp_StablePtr "indexStablePtrOffAddr#" GenPrimOp - Addr# -> Int# -> StablePtr# a - with can_fail = True - -primop IndexOffAddrOp_Int8 "indexInt8OffAddr#" GenPrimOp - Addr# -> Int# -> Int8# - with can_fail = True - -primop IndexOffAddrOp_Int16 "indexInt16OffAddr#" GenPrimOp - Addr# -> Int# -> Int16# - with can_fail = True - -primop IndexOffAddrOp_Int32 "indexInt32OffAddr#" GenPrimOp - Addr# -> Int# -> Int32# - with can_fail = True - -primop IndexOffAddrOp_Int64 "indexInt64OffAddr#" GenPrimOp - Addr# -> Int# -> Int64# - with can_fail = True - -primop IndexOffAddrOp_Word8 "indexWord8OffAddr#" GenPrimOp - Addr# -> Int# -> Word8# - with can_fail = True - -primop IndexOffAddrOp_Word16 "indexWord16OffAddr#" GenPrimOp - Addr# -> Int# -> Word16# - with can_fail = True - -primop IndexOffAddrOp_Word32 "indexWord32OffAddr#" GenPrimOp - Addr# -> Int# -> Word32# - with can_fail = True - -primop IndexOffAddrOp_Word64 "indexWord64OffAddr#" GenPrimOp - Addr# -> Int# -> Word64# - with can_fail = True - -primop ReadOffAddrOp_Char "readCharOffAddr#" GenPrimOp - Addr# -> Int# -> State# s -> (# State# s, Char# #) - {Reads 8-bit character; offset in bytes.} - with has_side_effects = True - can_fail = True - -primop ReadOffAddrOp_WideChar "readWideCharOffAddr#" GenPrimOp - Addr# -> Int# -> State# s -> (# State# s, Char# #) - {Reads 31-bit character; offset in 4-byte words.} - with has_side_effects = True - can_fail = True - -primop ReadOffAddrOp_Int "readIntOffAddr#" GenPrimOp - Addr# -> Int# -> State# s -> (# State# s, Int# #) - with has_side_effects = True - can_fail = True - -primop ReadOffAddrOp_Word "readWordOffAddr#" GenPrimOp - Addr# -> Int# -> State# s -> (# State# s, Word# #) - with has_side_effects = True - can_fail = True - -primop ReadOffAddrOp_Addr "readAddrOffAddr#" GenPrimOp - Addr# -> Int# -> State# s -> (# State# s, Addr# #) - with has_side_effects = True - can_fail = True - -primop ReadOffAddrOp_Float "readFloatOffAddr#" GenPrimOp - Addr# -> Int# -> State# s -> (# State# s, Float# #) - with has_side_effects = True - can_fail = True - -primop ReadOffAddrOp_Double "readDoubleOffAddr#" GenPrimOp - Addr# -> Int# -> State# s -> (# State# s, Double# #) - with has_side_effects = True - can_fail = True - -primop ReadOffAddrOp_StablePtr "readStablePtrOffAddr#" GenPrimOp - Addr# -> Int# -> State# s -> (# State# s, StablePtr# a #) - with has_side_effects = True - can_fail = True - -primop ReadOffAddrOp_Int8 "readInt8OffAddr#" GenPrimOp - Addr# -> Int# -> State# s -> (# State# s, Int8# #) - with has_side_effects = True - can_fail = True - -primop ReadOffAddrOp_Int16 "readInt16OffAddr#" GenPrimOp - Addr# -> Int# -> State# s -> (# State# s, Int16# #) - with has_side_effects = True - can_fail = True - -primop ReadOffAddrOp_Int32 "readInt32OffAddr#" GenPrimOp - Addr# -> Int# -> State# s -> (# State# s, Int32# #) - with has_side_effects = True - can_fail = True - -primop ReadOffAddrOp_Int64 "readInt64OffAddr#" GenPrimOp - Addr# -> Int# -> State# s -> (# State# s, Int64# #) - with has_side_effects = True - can_fail = True - -primop ReadOffAddrOp_Word8 "readWord8OffAddr#" GenPrimOp - Addr# -> Int# -> State# s -> (# State# s, Word8# #) - with has_side_effects = True - can_fail = True - -primop ReadOffAddrOp_Word16 "readWord16OffAddr#" GenPrimOp - Addr# -> Int# -> State# s -> (# State# s, Word16# #) - with has_side_effects = True - can_fail = True - -primop ReadOffAddrOp_Word32 "readWord32OffAddr#" GenPrimOp - Addr# -> Int# -> State# s -> (# State# s, Word32# #) - with has_side_effects = True - can_fail = True - -primop ReadOffAddrOp_Word64 "readWord64OffAddr#" GenPrimOp - Addr# -> Int# -> State# s -> (# State# s, Word64# #) - with has_side_effects = True - can_fail = True - -primop WriteOffAddrOp_Char "writeCharOffAddr#" GenPrimOp - Addr# -> Int# -> Char# -> State# s -> State# s - with has_side_effects = True - can_fail = True - -primop WriteOffAddrOp_WideChar "writeWideCharOffAddr#" GenPrimOp - Addr# -> Int# -> Char# -> State# s -> State# s - with has_side_effects = True - can_fail = True - -primop WriteOffAddrOp_Int "writeIntOffAddr#" GenPrimOp - Addr# -> Int# -> Int# -> State# s -> State# s - with has_side_effects = True - can_fail = True - -primop WriteOffAddrOp_Word "writeWordOffAddr#" GenPrimOp - Addr# -> Int# -> Word# -> State# s -> State# s - with has_side_effects = True - can_fail = True - -primop WriteOffAddrOp_Addr "writeAddrOffAddr#" GenPrimOp - Addr# -> Int# -> Addr# -> State# s -> State# s - with has_side_effects = True - can_fail = True - -primop WriteOffAddrOp_Float "writeFloatOffAddr#" GenPrimOp - Addr# -> Int# -> Float# -> State# s -> State# s - with has_side_effects = True - can_fail = True - -primop WriteOffAddrOp_Double "writeDoubleOffAddr#" GenPrimOp - Addr# -> Int# -> Double# -> State# s -> State# s - with has_side_effects = True - can_fail = True - -primop WriteOffAddrOp_StablePtr "writeStablePtrOffAddr#" GenPrimOp - Addr# -> Int# -> StablePtr# a -> State# s -> State# s - with has_side_effects = True - can_fail = True - -primop WriteOffAddrOp_Int8 "writeInt8OffAddr#" GenPrimOp - Addr# -> Int# -> Int8# -> State# s -> State# s - with has_side_effects = True - can_fail = True - -primop WriteOffAddrOp_Int16 "writeInt16OffAddr#" GenPrimOp - Addr# -> Int# -> Int16# -> State# s -> State# s - with has_side_effects = True - can_fail = True - -primop WriteOffAddrOp_Int32 "writeInt32OffAddr#" GenPrimOp - Addr# -> Int# -> Int32# -> State# s -> State# s - with has_side_effects = True - can_fail = True - -primop WriteOffAddrOp_Int64 "writeInt64OffAddr#" GenPrimOp - Addr# -> Int# -> Int64# -> State# s -> State# s - with has_side_effects = True - can_fail = True - -primop WriteOffAddrOp_Word8 "writeWord8OffAddr#" GenPrimOp - Addr# -> Int# -> Word8# -> State# s -> State# s - with has_side_effects = True - can_fail = True - -primop WriteOffAddrOp_Word16 "writeWord16OffAddr#" GenPrimOp - Addr# -> Int# -> Word16# -> State# s -> State# s - with has_side_effects = True - can_fail = True - -primop WriteOffAddrOp_Word32 "writeWord32OffAddr#" GenPrimOp - Addr# -> Int# -> Word32# -> State# s -> State# s - with has_side_effects = True - can_fail = True - -primop WriteOffAddrOp_Word64 "writeWord64OffAddr#" GenPrimOp - Addr# -> Int# -> Word64# -> State# s -> State# s - with has_side_effects = True - can_fail = True - -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 - --- 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 and the result of applying the given function to the - previous contents. Note that this isn't strictly - speaking the correct type for this function; it should really be - @'MutVar#' s a -> (a -> (a,b)) -> 'State#' s -> (# 'State#' s, a, (a, b) #)@, - but we don't know about pairs here. } - with - out_of_line = True - has_side_effects = True - can_fail = True - -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 - -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# RealWorld -> State# RealWorld - 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# RealWorld -> (State# RealWorld -> 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 -> b -> b - { 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'. - -pseudoop "unsafeCoerce#" - a -> b - { The function 'unsafeCoerce#' allows you to side-step the typechecker entirely. That - is, it allows you to coerce any type into any other type. If you use this function, - you had better get it right, otherwise segmentation faults await. It is generally - used when you want to write a program that you know is well-typed, but where Haskell's - type system is not expressive enough to prove that it is well typed. - - The following uses of 'unsafeCoerce#' are supposed to work (i.e. not lead to - spurious compile-time or run-time crashes): - - * Casting any lifted type to 'Any' - - * Casting 'Any' back to the real type - - * Casting an unboxed type to another unboxed type of the same size. - (Casting between floating-point and integral types does not work. - See the "GHC.Float" module for functions to do work.) - - * Casting between two types that have the same runtime representation. One case is when - the two types differ only in "phantom" type parameters, for example - @'Ptr' 'Int'@ to @'Ptr' 'Float'@, or @['Int']@ to @['Float']@ when the list is - known to be empty. Also, a @newtype@ of a type @T@ has the same representation - at runtime as @T@. - - Other uses of 'unsafeCoerce#' are undefined. In particular, you should not use - 'unsafeCoerce#' to cast a T to an algebraic data type D, unless T is also - an algebraic data type. For example, do not cast @'Int'->'Int'@ to 'Bool', even if - you later cast that 'Bool' back to @'Int'->'Int'@ before applying it. The reasons - have to do with GHC's internal representation details (for the cognoscenti, data values - can be entered but function closures cannot). If you want a safe type to cast things - to, use 'Any', which is not an algebraic data type. - - } - with can_fail = True - --- NB. It is tempting to think that casting a value to a type that it doesn't have is safe --- as long as you don't "do anything" with the value in its cast form, such as seq on it. This --- isn't the case: the compiler can insert seqs itself, and if these happen at the wrong type, --- Bad Things Might Happen. See bug #1616: in this case we cast a function of type (a,b) -> (a,b) --- to () -> () and back again. The strictness analyser saw that the function was strict, but --- the wrapper had type () -> (), and hence the wrapper de-constructed the (), the worker re-constructed --- a new (), with the result that the code ended up with "case () of (a,b) -> ...". - -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,706 +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 hiding ( WordOff ) - -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) - | isLarge (fromIntegral $ Map.size lbl_map0) - || isLarge 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 :: Word16 -> [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 - | SmallOp Word16 - | LabelOp LocalLabel --- (unused) | LargeOp Word - -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 -> isLarge w - LabelOp _ -> long_jumps --- LargeOp _ -> True - -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 largeOps = any (largeOp long_jumps) ops - opcode - | largeOps = largeArgInstr w - | otherwise = w - words = concatMap expand ops - expand (SmallOp w) = [w] - expand (LabelOp w) = expand (Op (e w)) - expand (Op w) = if largeOps then largeArg platform (fromIntegral w) else [fromIntegral w] --- expand (LargeOp w) = largeArg platform w - 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 (LargeOp _) = largeArg16s platform - --- 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 [SmallOp o1] - PUSH_LL o1 o2 -> emit bci_PUSH_LL [SmallOp o1, SmallOp o2] - PUSH_LLL o1 o2 o3 -> emit bci_PUSH_LLL [SmallOp o1, SmallOp o2, SmallOp o3] - PUSH8 o1 -> emit bci_PUSH8 [SmallOp o1] - PUSH16 o1 -> emit bci_PUSH16 [SmallOp o1] - PUSH32 o1 -> emit bci_PUSH32 [SmallOp o1] - PUSH8_W o1 -> emit bci_PUSH8_W [SmallOp o1] - PUSH16_W o1 -> emit bci_PUSH16_W [SmallOp o1] - PUSH32_W o1 -> emit bci_PUSH32_W [SmallOp 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, SmallOp 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 [SmallOp n, SmallOp by] - ALLOC_AP n -> emit bci_ALLOC_AP [SmallOp n] - ALLOC_AP_NOUPD n -> emit bci_ALLOC_AP_NOUPD [SmallOp n] - ALLOC_PAP arity n -> emit bci_ALLOC_PAP [SmallOp arity, SmallOp n] - MKAP off sz -> emit bci_MKAP [SmallOp off, SmallOp sz] - MKPAP off sz -> emit bci_MKPAP [SmallOp off, SmallOp sz] - UNPACK n -> emit bci_UNPACK [SmallOp n] - PACK dcon sz -> do itbl_no <- lit [BCONPtrItbl (getName dcon)] - emit bci_PACK [Op itbl_no, SmallOp 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 [SmallOp stkoff, SmallOp 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 [SmallOp 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] - -isLarge :: Word -> Bool -isLarge n = n > 65535 - -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,5 +1,6 @@ - +{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} {-# OPTIONS_GHC -funbox-strict-fields #-} -- -- (c) The University of Glasgow 2002-2006 @@ -13,23 +14,25 @@ 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 +import GHC.Runtime.Heap.Layout ( StgWord ) 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 @@ -40,35 +43,37 @@ protoBCOInstrs :: [BCInstr], -- instrs -- arity and GC info protoBCOBitmap :: [StgWord], - protoBCOBitmapSize :: Word16, + 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 data BCInstr -- Messing with the stack - = STKCHECK Word + = STKCHECK !Word -- Push locals (existing bits of the stack) - | PUSH_L !Word16{-offset-} - | PUSH_LL !Word16 !Word16{-2 offsets-} - | PUSH_LLL !Word16 !Word16 !Word16{-3 offsets-} + | PUSH_L !WordOff{-offset-} + | PUSH_LL !WordOff !WordOff{-2 offsets-} + | PUSH_LLL !WordOff !WordOff !WordOff{-3 offsets-} -- Push the specified local as a 8, 16, 32 bit value onto the stack. (i.e., -- the stack will grow by 8, 16 or 32 bits) - | PUSH8 !Word16 - | PUSH16 !Word16 - | PUSH32 !Word16 + | PUSH8 !ByteOff + | PUSH16 !ByteOff + | PUSH32 !ByteOff -- Push the specified local as a 8, 16, 32 bit value onto the stack, but the -- value will take the whole word on the stack (i.e., the stack will grow by @@ -77,9 +82,9 @@ -- Currently we expect all values on the stack to take full words, except for -- the ones used for PACK (i.e., actually constructing new data types, in -- which case we use PUSH{8,16,32}) - | PUSH8_W !Word16 - | PUSH16_W !Word16 - | PUSH32_W !Word16 + | PUSH8_W !ByteOff + | PUSH16_W !ByteOff + | PUSH32_W !ByteOff -- Push a (heap) ptr (these all map to PUSH_G really) | PUSH_G Name @@ -101,8 +106,8 @@ | PUSH_UBX8 Literal | PUSH_UBX16 Literal | PUSH_UBX32 Literal - | PUSH_UBX Literal Word16 - -- push this int/float/double/addr, on the stack. Word16 + | PUSH_UBX Literal !WordOff + -- push this int/float/double/addr, on the stack. Word -- is # of words to copy from literal pool. Eitherness reflects -- the difficulty of dealing with MachAddr here, mostly due to -- the excessive (and unnecessary) restrictions imposed by the @@ -128,58 +133,77 @@ | PUSH_APPLY_PPPPP | PUSH_APPLY_PPPPPP - | SLIDE Word16{-this many-} Word16{-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 !Word16 -- make an AP with this many payload words - | ALLOC_AP_NOUPD !Word16 -- make an AP_NOUPD with this many payload words - | ALLOC_PAP !Word16 !Word16 -- make a PAP with this arity / payload words - | MKAP !Word16{-ptr to AP is this far down stack-} !Word16{-number of words-} - | MKPAP !Word16{-ptr to PAP is this far down stack-} !Word16{-number of words-} - | UNPACK !Word16 -- unpack N words from t.o.s Constr - | PACK DataCon !Word16 + | ALLOC_AP !HalfWord {- make an AP with this many payload words. + HalfWord matches the size of the n_args field in StgAP, + make sure that we handle truncation when generating + bytecode using this HalfWord type here -} + | ALLOC_AP_NOUPD !HalfWord -- make an AP_NOUPD with this many payload words + | ALLOC_PAP !HalfWord !HalfWord -- make a PAP with this arity / payload words + | MKAP !WordOff{-ptr to AP is this far down stack-} !HalfWord{-number of words-} + | MKPAP !WordOff{-ptr to PAP is this far down stack-} !HalfWord{-number of words-} + | UNPACK !WordOff -- unpack N words from t.o.s Constr + | PACK DataCon !WordOff -- after assembly, the DataCon is an index into the -- itbl array -- For doing case trees | LABEL LocalLabel - | TESTLT_I Int LocalLabel - | TESTEQ_I Int LocalLabel - | TESTLT_W Word LocalLabel - | TESTEQ_W Word LocalLabel - | TESTLT_I64 Int64 LocalLabel - | TESTEQ_I64 Int64 LocalLabel - | TESTLT_I32 Int32 LocalLabel - | TESTEQ_I32 Int32 LocalLabel - | TESTLT_I16 Int16 LocalLabel - | TESTEQ_I16 Int16 LocalLabel - | TESTLT_I8 Int8 LocalLabel - | TESTEQ_I8 Int16 LocalLabel - | TESTLT_W64 Word64 LocalLabel - | TESTEQ_W64 Word64 LocalLabel - | TESTLT_W32 Word32 LocalLabel - | TESTEQ_W32 Word32 LocalLabel - | TESTLT_W16 Word16 LocalLabel - | TESTEQ_W16 Word16 LocalLabel - | TESTLT_W8 Word8 LocalLabel - | TESTEQ_W8 Word8 LocalLabel - | TESTLT_F Float LocalLabel - | TESTEQ_F Float LocalLabel - | TESTLT_D Double LocalLabel - | TESTEQ_D Double LocalLabel + | TESTLT_I !Int LocalLabel + | TESTEQ_I !Int LocalLabel + | TESTLT_W !Word LocalLabel + | TESTEQ_W !Word LocalLabel + | TESTLT_I64 !Int64 LocalLabel + | TESTEQ_I64 !Int64 LocalLabel + | TESTLT_I32 !Int32 LocalLabel + | TESTEQ_I32 !Int32 LocalLabel + | TESTLT_I16 !Int16 LocalLabel + | TESTEQ_I16 !Int16 LocalLabel + | TESTLT_I8 !Int8 LocalLabel + | TESTEQ_I8 !Int16 LocalLabel + | TESTLT_W64 !Word64 LocalLabel + | TESTEQ_W64 !Word64 LocalLabel + | TESTLT_W32 !Word32 LocalLabel + | TESTEQ_W32 !Word32 LocalLabel + | TESTLT_W16 !Word16 LocalLabel + | TESTEQ_W16 !Word16 LocalLabel + | TESTLT_W8 !Word8 LocalLabel + | TESTEQ_W8 !Word8 LocalLabel + | TESTLT_F !Float LocalLabel + | TESTEQ_F !Float LocalLabel + | TESTLT_D !Double LocalLabel + | TESTEQ_D !Double LocalLabel -- The Word16 value is a constructor number and therefore -- stored in the insn stream rather than as an offset into -- the literal pool. - | TESTLT_P Word16 LocalLabel - | TESTEQ_P Word16 LocalLabel + -- | 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 | JMP LocalLabel -- For doing calls to C (via glue code generated by libffi) - | CCALL Word16 -- stack frame size - (RemotePtr C_ffi_cif) -- addr of the glue code - Word16 -- flags. + | CCALL !WordOff -- stack frame size + !FFIInfo -- libffi ffi_cif function prototype + !Word16 -- flags. -- -- 0x1: call is interruptible -- 0x2: call is unsafe @@ -189,9 +213,42 @@ | 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 Word16 -- to the ptr N words down the stack, - Word16 -- add M (interpreted as a signed 16-bit entity) + | SWIZZLE !WordOff -- to the ptr N words down the stack, + !Int -- add M -- To Infinity And Beyond | ENTER @@ -201,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 @@ -212,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 ';')) @@ -251,7 +323,7 @@ ppr con <+> sep (map ppr args) <+> text "->" <+> pprStgExprShort opts expr pprStgRhsShort :: OutputablePass pass => StgPprOpts -> GenStgRhs pass -> SDoc -pprStgRhsShort opts (StgRhsClosure _ext _cc upd_flag args body) = +pprStgRhsShort opts (StgRhsClosure _ext _cc upd_flag args body _typ) = hang (hsep [ char '\\' <> ppr upd_flag, brackets (interppSP args) ]) 4 (pprStgExprShort opts body) pprStgRhsShort opts rhs = pprStgRhs opts rhs @@ -339,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. @@ -447,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 @@ -456,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,26 +24,26 @@ import GHC.ByteCode.Types import GHCi.RemoteTypes import GHCi.ResolvedBCO -import GHCi.BreakArray import GHC.Builtin.PrimOps -import GHC.Builtin.Names +import GHC.Builtin.PrimOps.Ids +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 import GHC.Types.Name.Env - -import Language.Haskell.Syntax.Module.Name +import qualified GHC.Types.Id as Id +import GHC.Types.Unique.DFM -- Standard libraries import Data.Array.Unboxed @@ -54,94 +56,114 @@ linkBCO :: Interp + -> PkgsLoaded -> LinkerEnv + -> LinkedBreaks -> NameEnv Int - -> RemoteRef BreakArray -> UnlinkedBCO -> IO ResolvedBCO -linkBCO interp 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 le) (ssElts lits0) - ptrs <- mapM (resolvePtr interp 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 -> LinkerEnv -> BCONPtr -> IO Word -lookupLiteral interp 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 return (W# (int2Word# (addr2Int# a#))) BCONPtrItbl nm -> do - Ptr a# <- lookupIE interp (itbl_env le) nm + Ptr a# <- lookupIE interp pkgs_loaded (itbl_env le) nm return (W# (int2Word# (addr2Int# a#))) BCONPtrAddr nm -> do - Ptr a# <- lookupAddr interp (addr_env le) nm + 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 -> ItblEnv -> Name -> IO (Ptr ()) -lookupIE interp ie con_nm = +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 <- lookupSymbol interp sym_to_find1 + 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 <- lookupSymbol interp sym_to_find2 + 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 -> AddrEnv -> Name -> IO (Ptr ()) -lookupAddr interp ae addr_nm = do +lookupAddr :: Interp -> PkgsLoaded -> AddrEnv -> Name -> IO (Ptr ()) +lookupAddr interp pkgs_loaded ae addr_nm = do 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 <- lookupSymbol interp sym_to_find + 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 -> PrimOp -> IO (RemotePtr ()) -lookupPrimOp interp primop = do +lookupPrimOp :: Interp -> PkgsLoaded -> PrimOp -> IO (RemotePtr ()) +lookupPrimOp interp pkgs_loaded primop = do let sym_to_find = primopToCLabel primop "closure" - m <- lookupSymbol interp (mkFastString sym_to_find) + 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 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 @@ -152,27 +174,49 @@ | otherwise -> assertPpr (isExternalName nm) (ppr nm) $ do - let sym_to_find = nameToCLabel nm "closure" - m <- lookupSymbol interp sym_to_find + 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 op + -> ResolvedBCOStaticPtr <$> lookupPrimOp interp pkgs_loaded op BCOPtrBCO bco - -> ResolvedBCOPtrBCO <$> linkBCO interp 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 -linkFail :: String -> String -> IO a +-- | 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 -> 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 + mb_ptr <- lookupSymbolInDLL interp dll sym_to_find + case mb_ptr of + Just ptr -> pure (Just ptr) + Nothing -> go dlls + go [] = + -- See Note [Symbols may not be found in pkgs_loaded] in GHC.Linker.Types + lookupSymbol interp sym_to_find + + go loaded_dlls + +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" @@ -183,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 (occNameFS (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,71 +11,91 @@ -- | Bytecode assembler types module GHC.ByteCode.Types ( CompiledByteCode(..), seqCompiledByteCode + , BCOByteArray(..), mkBCOByteArray , FFIInfo(..) , RegBitmap(..) , NativeCallType(..), NativeCallInfo(..), voidTupleReturnInfo, voidPrimCallInfo - , ByteOff(..), WordOff(..) + , ByteOff(..), WordOff(..), HalfWord(..) , 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) @@ -80,6 +103,12 @@ newtype WordOff = WordOff Int deriving (Enum, Eq, Show, Integral, Num, Ord, Real, Outputable) +-- A type for values that are half the size of a word on the target +-- platform where the interpreter runs (which may be a different +-- wordsize than the compiler). +newtype HalfWord = HalfWord Word + deriving (Enum, Eq, Show, Integral, Num, Ord, Real, Outputable) + newtype RegBitmap = RegBitmap { unRegBitmap :: Word32 } deriving (Enum, Eq, Show, Integral, Num, Ord, Real, Bits, FiniteBits, Outputable) @@ -142,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 @@ -161,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 @@ -174,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, Word16)] - , 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 @@ -839,7 +833,7 @@ -- The rendered Haskell type of the closure the table represents , infoProvModule :: !Module -- Origin module - , infoTableProv :: !(Maybe (RealSrcSpan, String)) } + , infoTableProv :: !(Maybe (RealSrcSpan, LexicalFastString)) } -- Position and information about the info table deriving (Eq, Ord) @@ -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,43 +71,48 @@ assign_regs assts (r:rs) regs | isVecType ty = vec | isFloatType ty = float | otherwise = int - where vec = case (w, regs) of - (W128, (vs, fs, ds, ls, s:ss)) - | passVectorInReg W128 profile -> k (RegisterParam (XmmReg s), (vs, fs, ds, ls, ss)) - (W256, (vs, fs, ds, ls, s:ss)) - | passVectorInReg W256 profile -> k (RegisterParam (YmmReg s), (vs, fs, ds, ls, ss)) - (W512, (vs, fs, ds, ls, s:ss)) - | passVectorInReg W512 profile -> k (RegisterParam (ZmmReg s), (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, (vs, fs, ds, ls, s:ss)) - | passFloatInXmm -> k (RegisterParam (FloatReg s), (vs, fs, ds, ls, ss)) - (W32, (vs, f:fs, ds, ls, ss)) - | not passFloatInXmm -> k (RegisterParam f, (vs, fs, ds, ls, ss)) - (W64, (vs, fs, ds, ls, s:ss)) - | passFloatInXmm -> k (RegisterParam (DoubleReg s), (vs, fs, ds, ls, ss)) - (W64, (vs, fs, d:ds, ls, ss)) - | not passFloatInXmm -> k (RegisterParam d, (vs, fs, ds, ls, ss)) + (W32, AvailRegs vs fs ds ls (s:ss)) + | passFloatInXmm -> k (RegisterParam (FloatReg s), AvailRegs vs fs ds ls ss) + (W32, AvailRegs vs (f:fs) ds ls ss) + | not passFloatInXmm -> k (RegisterParam f, AvailRegs vs fs ds ls ss) + (W64, AvailRegs vs fs ds ls (s:ss)) + | passFloatInXmm -> k (RegisterParam (DoubleReg s), AvailRegs vs fs ds ls ss) + (W64, AvailRegs vs fs (d:ds) ls ss) + | not passFloatInXmm -> k (RegisterParam d, AvailRegs vs fs ds ls ss) _ -> (assts, (r:rs)) int = case (w, regs) of (W128, _) -> panic "W128 unsupported register type" - (_, (v:vs, fs, ds, ls, ss)) | widthInBits w <= widthInBits (wordWidth platform) - -> k (RegisterParam (v gcp), (vs, fs, ds, ls, ss)) - (_, (vs, fs, ds, l:ls, ss)) | widthInBits w > widthInBits (wordWidth platform) - -> k (RegisterParam l, (vs, fs, ds, ls, ss)) + (_, AvailRegs (v:vs) fs ds ls ss) | widthInBits w <= widthInBits (wordWidth platform) + -> k (RegisterParam v, AvailRegs vs fs ds ls ss) + (_, AvailRegs vs fs ds (l:ls) ss) | widthInBits w > widthInBits (wordWidth platform) + -> k (RegisterParam l, AvailRegs vs fs ds ls ss) _ -> (assts, (r:rs)) k (asst, regs') = assign_regs ((r, asst) : assts) rs regs' ty = arg_ty r w = typeWidth ty - !gcp | isGcPtrType ty = VGcPtr - | otherwise = VNonGcPtr 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 @@ -131,13 +140,24 @@ ----------------------------------------------------------------------------- -- Local information about the registers available -type AvailRegs = ( [VGcPtr -> GlobalReg] -- available vanilla regs. - , [GlobalReg] -- floats - , [GlobalReg] -- doubles - , [GlobalReg] -- longs (int64 and word64) - , [Int] -- XMM (floats and doubles) - ) +-- | Keep track of locally available registers. +data AvailRegs + = AvailRegs + { availVanillaRegs :: [GlobalReg] + -- ^ Available vanilla registers + , availFloatRegs :: [GlobalReg] + -- ^ Available float registers + , availDoubleRegs :: [GlobalReg] + -- ^ Available double registers + , availLongRegs :: [GlobalReg] + -- ^ Available long registers + , availXMMRegs :: [Int] + -- ^ Available vector XMM registers + } +noAvailRegs :: AvailRegs +noAvailRegs = AvailRegs [] [] [] [] [] + -- Vanilla registers can contain pointers, Ints, Chars. -- Floats and doubles have separate register supplies. -- @@ -146,24 +166,26 @@ getRegsWithoutNode, getRegsWithNode :: Platform -> AvailRegs getRegsWithoutNode platform = - ( filter (\r -> r VGcPtr /= node) (realVanillaRegs platform) - , realFloatRegs platform - , realDoubleRegs platform - , realLongRegs platform - , realXmmRegNos platform) + AvailRegs + { availVanillaRegs = filter (\r -> r /= node) (realVanillaRegs platform) + , availFloatRegs = realFloatRegs platform + , availDoubleRegs = realDoubleRegs platform + , availLongRegs = realLongRegs platform + , availXMMRegs = realXmmRegNos platform } -- getRegsWithNode uses R1/node even if it isn't a register getRegsWithNode platform = - ( if null (realVanillaRegs platform) - then [VanillaReg 1] - else realVanillaRegs platform - , realFloatRegs platform - , realDoubleRegs platform - , realLongRegs platform - , realXmmRegNos platform) + AvailRegs + { availVanillaRegs = if null (realVanillaRegs platform) + then [VanillaReg 1] + else realVanillaRegs platform + , availFloatRegs = realFloatRegs platform + , availDoubleRegs = realDoubleRegs platform + , availLongRegs = realLongRegs platform + , availXMMRegs = realXmmRegNos platform } allFloatRegs, allDoubleRegs, allLongRegs :: Platform -> [GlobalReg] -allVanillaRegs :: Platform -> [VGcPtr -> GlobalReg] +allVanillaRegs :: Platform -> [GlobalReg] allXmmRegs :: Platform -> [Int] allVanillaRegs platform = map VanillaReg $ regList (pc_MAX_Vanilla_REG (platformConstants platform)) @@ -173,7 +195,7 @@ allXmmRegs platform = regList (pc_MAX_XMM_REG (platformConstants platform)) realFloatRegs, realDoubleRegs, realLongRegs :: Platform -> [GlobalReg] -realVanillaRegs :: Platform -> [VGcPtr -> GlobalReg] +realVanillaRegs :: Platform -> [GlobalReg] realVanillaRegs platform = map VanillaReg $ regList (pc_MAX_Real_Vanilla_REG (platformConstants platform)) realFloatRegs platform = map FloatReg $ regList (pc_MAX_Real_Float_REG (platformConstants platform)) @@ -182,147 +204,121 @@ realXmmRegNos :: Platform -> [Int] realXmmRegNos platform - | isSse2Enabled platform = regList (pc_MAX_Real_XMM_REG (platformConstants platform)) - | otherwise = [] + | isSse2Enabled platform || platformArch platform == ArchAArch64 + = regList (pc_MAX_Real_XMM_REG (platformConstants platform)) + | otherwise + = [] regList :: Int -> [Int] regList n = [1 .. n] allRegs :: Platform -> AvailRegs -allRegs platform = ( allVanillaRegs platform - , allFloatRegs platform - , allDoubleRegs platform - , allLongRegs platform - , allXmmRegs platform - ) +allRegs platform = + AvailRegs + { availVanillaRegs = allVanillaRegs platform + , availFloatRegs = allFloatRegs platform + , availDoubleRegs = allDoubleRegs platform + , availLongRegs = allLongRegs platform + , availXMMRegs = allXmmRegs platform } nodeOnly :: AvailRegs -nodeOnly = ([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 - = map ($ VGcPtr) (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 - = map ($ VGcPtr) (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: +nodeOnly = noAvailRegs { availVanillaRegs = [VanillaReg 1] } - ... - 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 VGcPtr : 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 #-} ----------------------------------------------------------------------------- -- @@ -39,9 +37,9 @@ import GHC.Cmm.BlockId import GHC.Cmm.CLabel import GHC.Cmm -import GHC.Cmm.Reg ( pprGlobalReg ) +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 @@ -513,7 +521,7 @@ -- | Expressions, used for unwind information data UnwindExpr = UwConst !Int -- ^ literal value - | UwReg !GlobalReg !Int -- ^ register plus offset + | UwReg !GlobalRegUse !Int -- ^ register plus offset | UwDeref UnwindExpr -- ^ pointer dereferencing | UwLabel CLabel | UwPlus UnwindExpr UnwindExpr @@ -535,7 +543,7 @@ pprUnwindExpr :: IsLine doc => Rational -> Platform -> UnwindExpr -> doc pprUnwindExpr p env = \case UwConst i -> int i - UwReg g 0 -> pprGlobalReg g + UwReg g 0 -> pprGlobalRegUse g UwReg g x -> pprUnwindExpr p env (UwPlus (UwReg g 0) (UwConst x)) UwDeref e -> char '*' <> pprUnwindExpr 3 env e UwLabel l -> pprAsmLabel env l 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 @@ -12,11 +8,11 @@ , AlignmentSpec(..) -- TODO: Remove: , LocalReg(..), localRegType - , GlobalReg(..), isArgReg, globalRegType + , GlobalReg(..), isArgReg, globalRegSpillType + , GlobalRegUse(..) , spReg, hpReg, spLimReg, hpLimReg, nodeReg , currentTSOReg, currentNurseryReg, hpAllocReg, cccsReg , node, baseReg - , VGcPtr(..) , DefinerOfRegs, UserOfRegs , foldRegsDefd, foldRegsUsed @@ -248,9 +244,9 @@ cmmExprType platform = \case (CmmLit lit) -> cmmLitType platform lit (CmmLoad _ rep _) -> rep - (CmmReg reg) -> cmmRegType platform reg + (CmmReg reg) -> cmmRegType reg (CmmMachOp op args) -> machOpResultType platform op (map (cmmExprType platform) args) - (CmmRegOff reg _) -> cmmRegType platform reg + (CmmRegOff reg _) -> cmmRegType reg (CmmStackSlot _ _) -> bWord platform -- an address -- Careful though: what is stored at the stack slot may be bigger than -- an address @@ -385,10 +381,18 @@ instance UserOfRegs GlobalReg CmmReg where {-# INLINEABLE foldRegsUsed #-} foldRegsUsed _ _ z (CmmLocal _) = z - foldRegsUsed _ f z (CmmGlobal reg) = f z reg + foldRegsUsed _ f z (CmmGlobal (GlobalRegUse reg _)) = f z reg +instance UserOfRegs GlobalRegUse CmmReg where + {-# INLINEABLE foldRegsUsed #-} + foldRegsUsed _ _ z (CmmLocal _) = z + foldRegsUsed _ f z (CmmGlobal reg) = f z reg instance DefinerOfRegs GlobalReg CmmReg where foldRegsDefd _ _ z (CmmLocal _) = z + foldRegsDefd _ f z (CmmGlobal (GlobalRegUse reg _)) = f z reg + +instance DefinerOfRegs GlobalRegUse CmmReg where + foldRegsDefd _ _ z (CmmLocal _) = z foldRegsDefd _ f z (CmmGlobal reg) = f z reg instance Ord r => UserOfRegs r r where @@ -427,7 +431,7 @@ CmmRegOff reg i -> pprExpr platform (CmmMachOp (MO_Add rep) [CmmReg reg, CmmLit (CmmInt (fromIntegral i) rep)]) - where rep = typeWidth (cmmRegType platform reg) + where rep = typeWidth (cmmRegType reg) CmmLit lit -> pprLit platform lit _other -> pprExpr1 platform e @@ -502,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,9 +37,9 @@ import GHC.Types.ForeignCall import GHC.Data.OrdList import GHC.Runtime.Heap.Layout (ByteOff) -import GHC.Types.Unique.Supply -import GHC.Utils.Panic +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,35 +308,41 @@ 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 - -- See Note [Width of parameters] + + ci :: (LocalReg, ParamLocation) -> CmmNode O O ci (reg, RegisterParam r@(VanillaReg {})) = let local = CmmLocal reg - global = CmmReg (CmmGlobal r) - width = cmmRegWidth platform local - expr - | width == wordWidth platform = global - | width < wordWidth platform = - CmmMachOp (MO_XX_Conv (wordWidth platform) width) [global] - | otherwise = panic "Parameter width greater than word width" + width = cmmRegWidth local + (expr, ty) + -- See Note [Width of parameters] + | width == wordWidth platform + = (global, localRegType reg) + | width < wordWidth platform + = (CmmMachOp (MO_XX_Conv (wordWidth platform) width) [global] + ,setCmmTypeWidth (wordWidth platform) (localRegType reg)) + | otherwise + = panic "Parameter width greater than word width" + global = CmmReg (CmmGlobal $ GlobalRegUse r ty) in CmmAssign local expr -- Non VanillaRegs ci (reg, RegisterParam r) = - CmmAssign (CmmLocal reg) (CmmReg (CmmGlobal r)) + CmmAssign (CmmLocal reg) (CmmReg (CmmGlobal $ GlobalRegUse r (localRegType reg))) ci (reg, StackParam off) | isBitsType $ localRegType reg + -- See Note [Width of parameters] , typeWidth (localRegType reg) < wordWidth platform = let stack_slot = CmmLoad (CmmStackSlot area off) (cmmBits $ wordWidth platform) NaturallyAligned local = CmmLocal reg - width = cmmRegWidth platform local + width = cmmRegWidth local expr = CmmMachOp (MO_XX_Conv (wordWidth platform) width) [stack_slot] in CmmAssign local expr @@ -359,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 @@ -376,25 +382,30 @@ platform = profilePlatform profile (regs, graph) = foldr co ([], mkNop) (setRA ++ args ++ stack_params) - -- See Note [Width of parameters] + co :: (CmmExpr, ParamLocation) + -> ([GlobalRegUse], CmmAGraph) + -> ([GlobalRegUse], CmmAGraph) co (v, RegisterParam r@(VanillaReg {})) (rs, ms) = let width = cmmExprWidth platform v value + -- See Note [Width of parameters] | width == wordWidth platform = v | 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 r) value <*> ms) + in (ru:rs, mkAssign (CmmGlobal ru) value <*> ms) -- Non VanillaRegs co (v, RegisterParam r) (rs, ms) = - (r:rs, mkAssign (CmmGlobal r) v <*> ms) + let ru = GlobalRegUse r (cmmExprType platform v) + in (ru:rs, mkAssign (CmmGlobal ru) v <*> ms) - -- See Note [Width of parameters] co (v, StackParam off) (rs, ms) = (rs, mkStore (CmmStackSlot area off) (value v) <*> ms) + -- See Note [Width of parameters] width v = cmmExprWidth platform v value v | isBitsType $ cmmExprType platform v @@ -427,19 +438,18 @@ -- Note [Width of parameters] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- -- Consider passing a small (< word width) primitive like Int8# to a function. -- It's actually non-trivial to do this without extending/narrowing: --- * Global registers are considered to have native word width (i.e., 64-bits on --- x86-64), so CmmLint would complain if we assigned an 8-bit parameter to a --- global register. --- * Same problem exists with LLVM IR. --- * Lowering gets harder since on x86-32 not every register exposes its lower +-- * Lowering gets harder, since on x86-32 not every register exposes its lower -- 8 bits (e.g., for %eax we can use %al, but there isn't a corresponding -- 8-bit register for %edi). So we would either need to extend/narrow anyway, -- or complicate the calling convention. -- * Passing a small integer in a stack slot, which has native word width, -- requires extending to word width when writing to the stack and narrowing -- when reading off the stack (see #16258). +-- This is because the generated Cmm application functions (such as stg_ap_n) +-- always load the full width from the stack. -- So instead, we always extend every parameter smaller than native word width -- in copyOutOflow and then truncate it back to the expected width in copyIn. -- Note that we do this in cmm using MO_XX_Conv to avoid requiring @@ -453,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 @@ -468,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 = @@ -482,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) @@ -350,7 +356,7 @@ -- Not foolproof, but GCFun is the culprit we most want to catch isGcJump :: CmmNode O C -> Bool -isGcJump (CmmCall { cml_target = CmmReg (CmmGlobal l) }) +isGcJump (CmmCall { cml_target = CmmReg (CmmGlobal (GlobalRegUse l _)) }) = l == GCFun || l == GCEnter1 isGcJump _something_else = False @@ -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 @@ -875,7 +881,7 @@ do_stk_unwinding_gen = cmmGenStackUnwindInstr cfg adj block | sp_off /= 0 - = block `blockSnoc` CmmAssign spReg (cmmOffset platform spExpr sp_off) + = block `blockSnoc` CmmAssign (spReg platform) (cmmOffset platform (spExpr platform) sp_off) | otherwise = block -- Add unwind pseudo-instruction at the beginning of each block to -- document Sp level for debugging @@ -884,7 +890,7 @@ = CmmUnwind [(Sp, Just sp_unwind)] `blockCons` block | otherwise = block - where sp_unwind = CmmRegOff spReg (sp0 - platformWordSizeInBytes platform) + where sp_unwind = CmmRegOff (spReg platform) (sp0 - platformWordSizeInBytes platform) -- Add unwind pseudo-instruction right after the Sp adjustment -- if there is one. @@ -894,7 +900,7 @@ = block `blockSnoc` CmmUnwind [(Sp, Just sp_unwind)] | otherwise = block - where sp_unwind = CmmRegOff spReg (sp0 - platformWordSizeInBytes platform - sp_off) + where sp_unwind = CmmRegOff (spReg platform) (sp0 - platformWordSizeInBytes platform - sp_off) {- Note [SP old/young offsets] ~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -917,7 +923,7 @@ areaToSp :: Platform -> ByteOff -> ByteOff -> (Area -> StackLoc) -> CmmExpr -> CmmExpr areaToSp platform sp_old _sp_hwm area_off (CmmStackSlot area n) - = cmmOffset platform spExpr (sp_old - area_off area - n) + = cmmOffset platform (spExpr platform) (sp_old - area_off area - n) -- Replace (CmmStackSlot area n) with an offset from Sp areaToSp platform _ sp_hwm _ (CmmLit CmmHighStackMark) @@ -939,9 +945,9 @@ -- | Determine whether a stack check cannot fail. falseStackCheck :: [CmmExpr] -> Bool falseStackCheck [ CmmMachOp (MO_Sub _) - [ CmmRegOff (CmmGlobal Sp) x_off + [ CmmRegOff (CmmGlobal (GlobalRegUse Sp _)) x_off , CmmLit (CmmInt y_lit _)] - , CmmReg (CmmGlobal SpLim)] + , CmmReg (CmmGlobal (GlobalRegUse SpLim _))] = fromIntegral x_off >= y_lit falseStackCheck _ = False @@ -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 @@ -1087,7 +1093,7 @@ [ CmmAssign (CmmLocal reg) -- This cmmOffset basically corresponds to manifesting -- @CmmStackSlot Old sp_off@, see Note [SP old/young offsets] - (CmmLoad (cmmOffset platform spExpr (sp_off - reg_off)) + (CmmLoad (cmmOffset platform (spExpr platform) (sp_off - reg_off)) (localRegType reg) NaturallyAligned) | (reg, reg_off) <- stackSlotRegs stackmap @@ -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 @@ -1142,7 +1148,7 @@ -- Both 'id' and 'new_base' are KindNonPtr because they're -- RTS-only objects and are not subject to garbage collection id <- newTemp (bWord platform) - new_base <- newTemp (cmmRegType platform baseReg) + new_base <- newTemp (cmmRegType $ baseReg platform) let (caller_save, caller_load) = callerSaveVolatileRegs platform save_state_code <- saveThreadState profile load_state_code <- loadThreadState profile @@ -1153,7 +1159,7 @@ resume = mkMiddle (callResumeThread new_base id) <*> -- Assign the result to BaseReg: we -- might now have a different Capability! - mkAssign baseReg (CmmReg (CmmLocal new_base)) <*> + mkAssign (baseReg platform) (CmmReg (CmmLocal new_base)) <*> caller_load <*> load_state_code @@ -1168,7 +1174,7 @@ -- different. Hence we continue by jumping to the top stack frame, -- not by jumping to succ. jump = CmmCall { cml_target = entryCode platform $ - cmmLoadBWord platform spExpr + cmmLoadBWord platform (spExpr platform) , cml_cont = Just succ , cml_args_regs = regs , cml_args = widthInBytes (wordWidth platform) @@ -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" @@ -1193,7 +1199,7 @@ callSuspendThread :: Platform -> LocalReg -> Bool -> CmmNode O O callSuspendThread platform id intrbl = CmmUnsafeForeignCall (PrimTarget MO_SuspendThread) - [id] [baseExpr, mkIntExpr platform (fromEnum intrbl)] + [id] [baseExpr platform, mkIntExpr platform (fromEnum intrbl)] callResumeThread :: LocalReg -> LocalReg -> CmmNode O O callResumeThread new_base id = diff --git a/GHC/Cmm/Lexer.hs b/GHC/Cmm/Lexer.hs --- a/GHC/Cmm/Lexer.hs +++ b/GHC/Cmm/Lexer.hs @@ -1,925 +1,1087 @@ {-# OPTIONS_GHC -fno-warn-unused-binds -fno-warn-missing-signatures #-} {-# LANGUAGE CPP #-} {-# LANGUAGE MagicHash #-} -{-# LINE 13 "_build/source-dist/ghc-9.6.7-src/ghc-9.6.7/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.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 133 "_build/source-dist/ghc-9.6.7-src/ghc-9.6.7/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 GlobalReg - | 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) -> Action -global_regN con span buf len - = return (L span (CmmT_GlobalReg (con (fromIntegral n)))) - where buf' = stepOn buf - n = parseUnsignedInteger buf' (len-1) 10 octDecDigit - -global_reg :: GlobalReg -> Action -global_reg r span _buf _len = return (L span (CmmT_GlobalReg r)) - -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 (\n -> VanillaReg n VGcPtr) -alex_action_26 = global_regN (\n -> VanillaReg n VNonGcPtr) -alex_action_27 = global_regN FloatReg -alex_action_28 = global_regN DoubleReg -alex_action_29 = global_regN LongReg -alex_action_30 = global_reg Sp -alex_action_31 = global_reg SpLim -alex_action_32 = global_reg Hp -alex_action_33 = global_reg HpLim -alex_action_34 = global_reg CCCS -alex_action_35 = global_reg CurrentTSO -alex_action_36 = global_reg CurrentNursery -alex_action_37 = global_reg HpAlloc -alex_action_38 = global_reg BaseReg -alex_action_39 = global_reg MachSp -alex_action_40 = global_reg UnwindReturnReg -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,12 +102,13 @@ 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 platform <- getPlatform - let rep = typeWidth (cmmRegType platform reg) + = do let rep = typeWidth (cmmRegType reg) lintCmmExpr (CmmMachOp (MO_Add rep) [CmmReg reg, CmmLit (CmmInt (fromIntegral offset) rep)]) lintCmmExpr expr = @@ -171,24 +171,10 @@ CmmUnwind{} -> return () CmmAssign reg expr -> do - platform <- getPlatform erep <- lintCmmExpr expr - let reg_ty = cmmRegType platform reg - unless (compat_regs erep reg_ty) $ + let reg_ty = cmmRegType reg + unless (erep `cmmCompatType` reg_ty) $ cmmLintAssignErr (CmmAssign reg expr) erep reg_ty - where - compat_regs :: CmmType -> CmmType -> Bool - compat_regs ty1 ty2 - -- As noted in #22297, SIMD vector registers can be used for - -- multiple different purposes, e.g. xmm1 can be used to hold 4 Floats, - -- or 4 Int32s, or 2 Word64s, ... - -- To allow this, we relax the check: we only ensure that the widths - -- match, until we can find a more robust solution. - | isVecType ty1 - , isVecType ty2 - = typeWidth ty1 == typeWidth ty2 - | otherwise - = cmmEqType_ignoring_ptrhood ty1 ty2 CmmStore l r _alignment -> do _ <- lintCmmExpr l @@ -196,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 () @@ -229,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 @@ -239,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 @@ -301,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,4 +1,4 @@ -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} +{-# LANGUAGE LambdaCase #-} module GHC.Cmm.MachOp ( MachOp(..) @@ -22,10 +22,14 @@ , CallishMachOp(..), callishMachOpHints , pprCallishMachOp , machOpMemcpyishAlign + , callishMachOpArgTys -- Atomic read-modify-write , MemoryOrdering(..) , AtomicMachOp(..) + + -- Fused multiply-add + , FMASign(..), pprFMASign ) where @@ -34,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 ----------------------------------------------------------------------------- @@ -68,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) @@ -108,6 +115,10 @@ | MO_F_Mul Width | MO_F_Quot Width + -- Floating-point fused multiply-add operations + -- | Fused multiply-add, see 'FMASign'. + | MO_FMA FMASign Length Width + -- Floating point comparison | MO_F_Eq Width | MO_F_Ne Width @@ -116,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 @@ -130,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 @@ -142,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 @@ -173,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) @@ -180,7 +207,30 @@ pprMachOp :: MachOp -> SDoc pprMachOp mo = text (show mo) +-- | Where are the signs in a fused multiply-add instruction? +-- +-- @x*y + z@ vs @x*y - z@ vs @-x*y+z@ vs @-x*y-z@. +-- +-- Warning: the signs aren't consistent across architectures (X86, PowerPC, AArch64). +-- The user-facing implementation uses the X86 convention, while the relevant +-- backends use their corresponding conventions. +data FMASign + -- | Fused multiply-add @x*y + z@. + = FMAdd + -- | Fused multiply-subtract. On X86: @x*y - z@. + | FMSub + -- | Fused multiply-add. On X86: @-x*y + z@. + | FNMAdd + -- | Fused multiply-subtract. On X86: @-x*y - z@. + | FNMSub + deriving (Eq, Show) +pprFMASign :: IsLine doc => FMASign -> doc +pprFMASign = \case + FMAdd -> text "fmadd" + FMSub -> text "fmsub" + FNMAdd -> text "fnmadd" + FNMSub -> text "fnmsub" -- ----------------------------------------------------------------------------- -- Some common MachReps @@ -276,6 +326,8 @@ MO_Xor _ -> True MO_F_Add _ -> True MO_F_Mul _ -> True + MO_F_Min {} -> True + MO_F_Max {} -> True _other -> False -- ---------------------------------------------------------------------------- @@ -370,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 -- ---------------------------------------------------------------------------- @@ -393,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 @@ -413,11 +465,16 @@ 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 _ l w -> if l == 1 then cmmFloat w else cmmVec l (cmmFloat w) + MO_F_Eq {} -> comparisonResultRep platform MO_F_Ne {} -> comparisonResultRep platform MO_F_Ge {} -> comparisonResultRep platform @@ -428,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 @@ -447,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 @@ -462,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? @@ -482,79 +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_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_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_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_FMA _ l w -> [vecwidth l w, vecwidth l w, vecwidth l w] - 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_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_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_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_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_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 @@ -652,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 @@ -683,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]@. @@ -744,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,10 +555,9 @@ 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 -- See Note [Recursive superclasses] in GHC.Tc.TyCl.Instance @@ -584,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 @@ -593,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) @@ -437,10 +476,9 @@ That's what the constant-folding operations on comparison operators do above. -} - -- ----------------------------------------------------------------------------- -- Utils isPicReg :: CmmExpr -> Bool -isPicReg (CmmReg (CmmGlobal PicBaseReg)) = True +isPicReg (CmmReg (CmmGlobal (GlobalRegUse PicBaseReg _))) = True isPicReg _ = False diff --git a/GHC/Cmm/Parser.hs b/GHC/Cmm/Parser.hs --- a/GHC/Cmm/Parser.hs +++ b/GHC/Cmm/Parser.hs @@ -34,3434 +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.0 - -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 ([GlobalReg]) -happyIn30 :: ([GlobalReg]) -> (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 ((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 [(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 - (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 ), - - ( "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) - ] - 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 g)) | isPtrGlobalReg g = AddrHint -inferCmmHint _ = NoHint - -isPtrGlobalReg Sp = True -isPtrGlobalReg SpLim = True -isPtrGlobalReg Hp = True -isPtrGlobalReg HpLim = True -isPtrGlobalReg CCCS = True -isPtrGlobalReg CurrentTSO = True -isPtrGlobalReg CurrentNursery = True -isPtrGlobalReg (VanillaReg _ VGcPtr) = True -isPtrGlobalReg _ = 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 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 @@ -11,12 +11,13 @@ , LocalReg(..) , localRegType -- * Global registers - , GlobalReg(..), isArgReg, globalRegType - , pprGlobalReg + , GlobalReg(..), isArgReg, globalRegSpillType, pprGlobalReg , spReg, hpReg, spLimReg, hpLimReg, nodeReg , currentTSOReg, currentNurseryReg, hpAllocReg, cccsReg , node, baseReg - , VGcPtr(..) + , GlobalRegUse(..), pprGlobalRegUse + + , GlobalArgRegs(..) ) where import GHC.Prelude @@ -30,10 +31,66 @@ -- Cmm registers ----------------------------------------------------------------------------- +{- Note [GlobalReg vs GlobalRegUse] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We distinguish GlobalReg, which describes registers in the STG abstract machine, +with GlobalRegUse, which describes an usage of such a register to store values +of a particular CmmType. + +For example, we might want to load/store an 8-bit integer in a register that +can store 32-bit integers. + +The width of the type must fit in the register, i.e. for a usage +@GlobalRegUse reg ty@ we must have that + + > typeWidth ty <= typeWidth (globalRegSpillType reg) + +The restrictions about what categories of types can be stored in a given +register are less easily stated. Some examples are: + + - Vanilla registers can contain both pointers (gcWord) and non-pointers (bWord), + as well as sub-word sized values (e.g. b16). + - On x86_64, SIMD registers can be used to hold vectors of both floating + and integral values (e.g. XmmReg may store 2 Double values or 4 Int32 values). +-} + +-- | A use of a global register at a particular type. +-- +-- While a 'GlobalReg' identifies a global register in the STG machine, +-- a 'GlobalRegUse' also contains information about the type we are storing +-- in the register. +-- +-- See Note [GlobalReg vs GlobalRegUse] for more information. +data GlobalRegUse + = GlobalRegUse + { globalRegUse_reg :: !GlobalReg + -- ^ The underlying 'GlobalReg' + , 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 platform reg) + } + deriving Show + +instance Outputable GlobalRegUse where + ppr (GlobalRegUse reg _) = ppr reg + +pprGlobalRegUse :: IsLine doc => GlobalRegUse -> doc +pprGlobalRegUse (GlobalRegUse reg _) = pprGlobalReg reg + +-- TODO: these instances should be removed in favour +-- of more surgical uses of equality. +instance Eq GlobalRegUse where + GlobalRegUse r1 _ == GlobalRegUse r2 _ = r1 == r2 +instance Ord GlobalRegUse where + GlobalRegUse r1 _ `compare` GlobalRegUse r2 _ = compare r1 r2 + data CmmReg = CmmLocal {-# UNPACK #-} !LocalReg - | CmmGlobal GlobalReg - deriving( Eq, Ord, Show ) + | CmmGlobal GlobalRegUse + deriving ( Eq, Ord, Show ) instance Outputable CmmReg where ppr e = pprReg e @@ -41,16 +98,15 @@ pprReg :: CmmReg -> SDoc pprReg r = case r of - CmmLocal local -> pprLocalReg local - CmmGlobal global -> pprGlobalReg global - -cmmRegType :: Platform -> CmmReg -> CmmType -cmmRegType _ (CmmLocal reg) = localRegType reg -cmmRegType platform (CmmGlobal reg) = globalRegType platform reg + CmmLocal local -> pprLocalReg local + CmmGlobal (GlobalRegUse global _) -> pprGlobalReg global -cmmRegWidth :: Platform -> CmmReg -> Width -cmmRegWidth platform = typeWidth . cmmRegType platform +cmmRegType :: CmmReg -> CmmType +cmmRegType (CmmLocal reg) = localRegType reg +cmmRegType (CmmGlobal reg) = globalRegUse_type reg +cmmRegWidth :: CmmReg -> Width +cmmRegWidth = typeWidth . cmmRegType ----------------------------------------------------------------------------- -- Local registers @@ -129,13 +185,15 @@ there are likely still bugs there, beware! -} -data VGcPtr = VGcPtr | VNonGcPtr deriving( Eq, Show ) - +-- | An abstract global register for the STG machine. +-- +-- See also 'GlobalRegUse', which denotes a usage of a register at a particular +-- type (e.g. using a 32-bit wide register to store an 8-bit wide value), as per +-- Note [GlobalReg vs GlobalRegUse]. data GlobalReg -- Argument and return registers = VanillaReg -- pointers, unboxed ints and chars {-# UNPACK #-} !Int -- its number - VGcPtr | FloatReg -- single-precision floating-point registers {-# UNPACK #-} !Int -- its number @@ -146,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 @@ -156,140 +221,46 @@ {-# 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 - deriving( Show ) - -instance Eq GlobalReg where - VanillaReg i _ == VanillaReg j _ = i==j -- Ignore type when seeking clashes - FloatReg i == FloatReg j = i==j - DoubleReg i == DoubleReg j = i==j - LongReg i == LongReg j = i==j - -- NOTE: XMM, YMM, ZMM registers actually are the same registers - -- at least with respect to store at YMM i and then read from XMM i - -- and similarly for ZMM etc. - XmmReg i == XmmReg j = i==j - YmmReg i == YmmReg j = i==j - ZmmReg i == ZmmReg j = i==j - Sp == Sp = True - SpLim == SpLim = True - Hp == Hp = True - HpLim == HpLim = True - CCCS == CCCS = True - CurrentTSO == CurrentTSO = True - CurrentNursery == CurrentNursery = True - HpAlloc == HpAlloc = True - EagerBlackholeInfo == EagerBlackholeInfo = True - GCEnter1 == GCEnter1 = True - GCFun == GCFun = True - BaseReg == BaseReg = True - MachSp == MachSp = True - UnwindReturnReg == UnwindReturnReg = True - PicBaseReg == PicBaseReg = True - _r1 == _r2 = False - --- NOTE: this Ord instance affects the tuple layout in GHCi, see --- Note [GHCi and native call registers] -instance Ord GlobalReg where - compare (VanillaReg i _) (VanillaReg j _) = compare i j - -- Ignore type when seeking clashes - compare (FloatReg i) (FloatReg j) = compare i j - compare (DoubleReg i) (DoubleReg j) = compare i j - compare (LongReg i) (LongReg j) = compare i j - compare (XmmReg i) (XmmReg j) = compare i j - compare (YmmReg i) (YmmReg j) = compare i j - compare (ZmmReg i) (ZmmReg j) = compare i j - compare Sp Sp = EQ - compare SpLim SpLim = EQ - compare Hp Hp = EQ - compare HpLim HpLim = EQ - compare CCCS CCCS = EQ - compare CurrentTSO CurrentTSO = EQ - compare CurrentNursery CurrentNursery = EQ - compare HpAlloc HpAlloc = EQ - compare EagerBlackholeInfo EagerBlackholeInfo = EQ - compare GCEnter1 GCEnter1 = EQ - compare GCFun GCFun = EQ - compare BaseReg BaseReg = EQ - compare MachSp MachSp = EQ - compare UnwindReturnReg UnwindReturnReg = EQ - compare PicBaseReg PicBaseReg = EQ - compare (VanillaReg _ _) _ = LT - compare _ (VanillaReg _ _) = GT - compare (FloatReg _) _ = LT - compare _ (FloatReg _) = GT - compare (DoubleReg _) _ = LT - compare _ (DoubleReg _) = GT - compare (LongReg _) _ = LT - compare _ (LongReg _) = GT - compare (XmmReg _) _ = LT - compare _ (XmmReg _) = GT - compare (YmmReg _) _ = LT - compare _ (YmmReg _) = GT - compare (ZmmReg _) _ = LT - compare _ (ZmmReg _) = GT - compare Sp _ = LT - compare _ Sp = GT - compare SpLim _ = LT - compare _ SpLim = GT - compare Hp _ = LT - compare _ Hp = GT - compare HpLim _ = LT - compare _ HpLim = GT - compare CCCS _ = LT - compare _ CCCS = GT - compare CurrentTSO _ = LT - compare _ CurrentTSO = GT - compare CurrentNursery _ = LT - compare _ CurrentNursery = GT - compare HpAlloc _ = LT - compare _ HpAlloc = GT - compare GCEnter1 _ = LT - compare _ GCEnter1 = GT - compare GCFun _ = LT - compare _ GCFun = GT - compare BaseReg _ = LT - compare _ BaseReg = GT - compare MachSp _ = LT - compare _ MachSp = GT - compare UnwindReturnReg _ = LT - compare _ UnwindReturnReg = GT - compare EagerBlackholeInfo _ = LT - compare _ EagerBlackholeInfo = GT + deriving( Eq, Ord, Show ) + -- NOTE: the Ord instance affects the tuple layout in GHCi, see + -- Note [GHCi and native call registers] instance Outputable GlobalReg where ppr e = pprGlobalReg e @@ -300,10 +271,7 @@ pprGlobalReg :: IsLine doc => GlobalReg -> doc pprGlobalReg gr = case gr of - VanillaReg n _ -> char 'R' <> int n --- Temp Jan08 --- VanillaReg n VNonGcPtr -> char 'R' <> int n --- VanillaReg n VGcPtr -> char 'P' <> int n + VanillaReg n -> char 'R' <> int n FloatReg n -> char 'F' <> int n DoubleReg n -> char 'D' <> int n LongReg n -> char 'L' <> int n @@ -331,38 +299,38 @@ -- convenient aliases baseReg, spReg, hpReg, spLimReg, hpLimReg, nodeReg, - currentTSOReg, currentNurseryReg, hpAllocReg, cccsReg :: CmmReg -baseReg = CmmGlobal BaseReg -spReg = CmmGlobal Sp -hpReg = CmmGlobal Hp -hpLimReg = CmmGlobal HpLim -spLimReg = CmmGlobal SpLim -nodeReg = CmmGlobal node -currentTSOReg = CmmGlobal CurrentTSO -currentNurseryReg = CmmGlobal CurrentNursery -hpAllocReg = CmmGlobal HpAlloc -cccsReg = CmmGlobal CCCS + currentTSOReg, currentNurseryReg, hpAllocReg, cccsReg :: Platform -> CmmReg +baseReg p = CmmGlobal (GlobalRegUse BaseReg $ bWord p) +spReg p = CmmGlobal (GlobalRegUse Sp $ bWord p) +hpReg p = CmmGlobal (GlobalRegUse Hp $ gcWord p) +hpLimReg p = CmmGlobal (GlobalRegUse HpLim $ bWord p) +spLimReg p = CmmGlobal (GlobalRegUse SpLim $ bWord p) +nodeReg p = CmmGlobal (GlobalRegUse (VanillaReg 1) $ gcWord p) +currentTSOReg p = CmmGlobal (GlobalRegUse CurrentTSO $ bWord p) +currentNurseryReg p = CmmGlobal (GlobalRegUse CurrentNursery $ bWord p) +hpAllocReg p = CmmGlobal (GlobalRegUse HpAlloc $ bWord p) +cccsReg p = CmmGlobal (GlobalRegUse CCCS $ bWord p) node :: GlobalReg -node = VanillaReg 1 VGcPtr +node = VanillaReg 1 -globalRegType :: Platform -> GlobalReg -> CmmType -globalRegType platform = \case - (VanillaReg _ VGcPtr) -> gcWord platform - (VanillaReg _ VNonGcPtr) -> bWord platform - (FloatReg _) -> cmmFloat W32 - (DoubleReg _) -> cmmFloat W64 - (LongReg _) -> cmmBits W64 +globalRegSpillType :: Platform -> GlobalReg -> CmmType +globalRegSpillType platform = \case + VanillaReg _ -> gcWord platform + FloatReg _ -> cmmFloat W32 + DoubleReg _ -> cmmFloat W64 + LongReg _ -> cmmBits W64 + -- TODO: improve the internal model of SIMD/vectorized registers - -- the right design SHOULd improve handling of float and double code too. + -- the right design SHOULD improve handling of float and double code too. -- see remarks in Note [SIMD Design for the future] in GHC.StgToCmm.Prim - (XmmReg _) -> cmmVec 4 (cmmBits W32) - (YmmReg _) -> cmmVec 8 (cmmBits W32) - (ZmmReg _) -> cmmVec 16 (cmmBits W32) + XmmReg _ -> cmmVec 4 (cmmBits W32) + YmmReg _ -> cmmVec 8 (cmmBits W32) + ZmmReg _ -> cmmVec 16 (cmmBits W32) - Hp -> gcWord platform -- The initialiser for all - -- dynamically allocated closures - _ -> bWord platform + Hp -> gcWord platform -- The initialiser for all + -- dynamically allocated closures + _ -> bWord platform isArgReg :: GlobalReg -> Bool isArgReg (VanillaReg {}) = True @@ -373,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 @@ -244,7 +243,7 @@ -- isTrivial :: Platform -> CmmExpr -> Bool isTrivial _ (CmmReg (CmmLocal _)) = True -isTrivial platform (CmmReg (CmmGlobal r)) = -- see Note [Inline GlobalRegs?] +isTrivial platform (CmmReg (CmmGlobal (GlobalRegUse r _))) = -- see Note [Inline GlobalRegs?] if isARM (platformArch platform) then True -- CodeGen.Platform.ARM does not have globalRegMaybe else isJust (globalRegMaybe platform r) @@ -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): -- @@ -667,9 +666,9 @@ , memConflicts addr (loadAddr platform addr' (cmmExprWidth platform e)) = True -- (4) an assignment to Hp/Sp conflicts with a heap/stack read respectively - | HeapMem <- addr, CmmAssign (CmmGlobal Hp) _ <- node = True - | StackMem <- addr, CmmAssign (CmmGlobal Sp) _ <- node = True - | SpMem{} <- addr, CmmAssign (CmmGlobal Sp) _ <- node = True + | HeapMem <- addr, CmmAssign (CmmGlobal (GlobalRegUse Hp _)) _ <- node = True + | StackMem <- addr, CmmAssign (CmmGlobal (GlobalRegUse Sp _)) _ <- node = True + | SpMem{} <- addr, CmmAssign (CmmGlobal (GlobalRegUse Sp _)) _ <- node = True -- (5) foreign calls clobber heap: see Note [Foreign calls clobber heap] | CmmUnsafeForeignCall{} <- node, memConflicts addr AnyMem = True @@ -703,9 +702,9 @@ -- Cmm expression globalRegistersConflict :: Platform -> CmmExpr -> CmmNode e x -> Bool globalRegistersConflict platform expr node = - -- See Note [Inlining foldRegsDefd] - inline foldRegsDefd platform (\b r -> b || regUsedIn platform (CmmGlobal r) expr) - False node + -- See Note [Inlining foldRegsDefd] + 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 -- Cmm expression @@ -852,17 +851,17 @@ loadAddr :: Platform -> CmmExpr -> Width -> AbsMem loadAddr platform e w = case e of - CmmReg r -> regAddr platform r 0 w - CmmRegOff r i -> regAddr platform r i w - _other | regUsedIn platform spReg e -> StackMem - | otherwise -> AnyMem + CmmReg r -> regAddr r 0 w + CmmRegOff r i -> regAddr r i w + _other | regUsedIn platform (spReg platform) e -> StackMem + | otherwise -> AnyMem -regAddr :: Platform -> CmmReg -> Int -> Width -> AbsMem -regAddr _ (CmmGlobal Sp) i w = SpMem i (widthInBytes w) -regAddr _ (CmmGlobal Hp) _ _ = HeapMem -regAddr _ (CmmGlobal CurrentTSO) _ _ = HeapMem -- important for PrimOps -regAddr platform r _ _ | isGcPtrType (cmmRegType platform r) = HeapMem -- yay! GCPtr pays for itself -regAddr _ _ _ _ = AnyMem +regAddr :: CmmReg -> Int -> Width -> AbsMem +regAddr (CmmGlobal (GlobalRegUse Sp _)) i w = SpMem i (widthInBytes w) +regAddr (CmmGlobal (GlobalRegUse Hp _)) _ _ = HeapMem +regAddr (CmmGlobal (GlobalRegUse CurrentTSO _)) _ _ = HeapMem -- important for PrimOps +regAddr r _ _ | isGcPtrType (cmmRegType r) = HeapMem -- yay! GCPtr pays for itself +regAddr _ _ _ = AnyMem {- Note [Inline GlobalRegs?] 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) @@ -54,11 +54,13 @@ CmmTick{} -> BMiddle node CmmUnwind{} -> BMiddle node CmmAssign{} -> annotateNodeOO env node - CmmStore lhs rhs align -> + -- TODO: Track unaligned stores + CmmStore _ _ Unaligned -> annotateNodeOO env node + CmmStore lhs rhs NaturallyAligned -> let ty = cmmExprType (platform env) rhs rhs_nodes = annotateLoads env (collectExprLoads rhs) lhs_nodes = annotateLoads env (collectExprLoads lhs) - st = tsanStore env align ty lhs + st = tsanStore env ty lhs in rhs_nodes `blockAppend` lhs_nodes `blockAppend` st `blockSnoc` node CmmUnsafeForeignCall (PrimTarget op) formals args -> let node' = fromMaybe (BMiddle node) (annotatePrim env op formals args) @@ -83,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 @@ -101,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 _ _) = [] @@ -112,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 @@ -131,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) @@ -148,28 +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) + regs_to_save :: [GlobalReg] + regs_to_save = filter (callerSaves platform) (activeStgRegs platform) - save = blockFromList (map saveReg regs) - saveReg reg = - CmmStore (get_GlobalReg_addr platform reg) - (CmmReg (CmmGlobal reg)) - NaturallyAligned + 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) - restore = blockFromList (map restoreReg regs) - restoreReg reg = - CmmAssign (CmmGlobal reg) - (CmmLoad (get_GlobalReg_addr platform reg) - (globalRegType platform reg) - NaturallyAligned) + (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 @@ -188,26 +204,25 @@ 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 - -> AlignmentSpec -> CmmType -> CmmExpr + -> CmmType -> CmmExpr -> Block CmmNode O O -tsanStore env align 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) - fn = case align of - Unaligned - | w > 1 -> fsLit $ "__tsan_unaligned_write" ++ show w - _ -> fsLit $ "__tsan_write" ++ show w + fn = fsLit $ "__tsan_write" ++ show w 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) @@ -282,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 @@ -3,7 +3,8 @@ , b8, b16, b32, b64, b128, b256, b512, f32, f64, bWord, bHalfWord, gcWord , cInt , cmmBits, cmmFloat - , typeWidth, cmmEqType, cmmEqType_ignoring_ptrhood + , typeWidth, setCmmTypeWidth + , cmmEqType, cmmCompatType , isFloatType, isGcPtrType, isBitsType , isWordAny, isWord32, isWord64 , isFloat64, isFloat32 @@ -56,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) @@ -86,25 +89,34 @@ 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 typeWidth (CmmType _ w) = w + +setCmmTypeWidth :: Width -> CmmType -> CmmType +setCmmTypeWidth w (CmmType c _) = CmmType c w cmmBits, cmmFloat :: Width -> CmmType cmmBits = CmmType BitsCat 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. @@ -50,7 +47,7 @@ cmmConstrTag1, mAX_PTR_TAG, tAG_MASK, -- Overlap and usage - regsOverlap, regUsedIn, + regsOverlap, globalRegsOverlap, regUsedIn, globalRegUsedIn, -- Liveness and bitmaps mkLiveness, @@ -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,9 +94,7 @@ primRepCmmType :: Platform -> PrimRep -> CmmType primRepCmmType platform = \case - VoidRep -> panic "primRepCmmType:VoidRep" - LiftedRep -> gcWord platform - UnliftedRep -> gcWord platform + BoxedRep _ -> gcWord platform IntRep -> bWord platform WordRep -> bWord platform Int8Rep -> b8 @@ -137,13 +132,11 @@ 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 LiftedRep = AddrHint -primRepForeignHint UnliftedRep = AddrHint +primRepForeignHint (BoxedRep _) = AddrHint primRepForeignHint IntRep = SignedHint primRepForeignHint Int8Rep = SignedHint primRepForeignHint Int16Rep = SignedHint @@ -159,8 +152,8 @@ primRepForeignHint DoubleRep = NoHint primRepForeignHint (VecRep {}) = NoHint -typeForeignHint :: UnaryType -> ForeignHint -typeForeignHint = primRepForeignHint . typePrimRep1 +typeForeignHint :: NvUnaryType -> ForeignHint +typeForeignHint = primRepForeignHint . typePrimRepU --------------------------------------------------- -- @@ -437,13 +430,19 @@ -- other. This includes the case that the two registers are the same -- STG register. See Note [Overlapping global registers] for details. regsOverlap :: Platform -> CmmReg -> CmmReg -> Bool -regsOverlap platform (CmmGlobal g) (CmmGlobal g') - | Just real <- globalRegMaybe platform g, - Just real' <- globalRegMaybe platform g', - real == real' - = True +regsOverlap platform (CmmGlobal (GlobalRegUse g1 _)) (CmmGlobal (GlobalRegUse g2 _)) + = globalRegsOverlap platform g1 g2 regsOverlap _ reg reg' = reg == reg' +globalRegsOverlap :: Platform -> GlobalReg -> GlobalReg -> Bool +globalRegsOverlap platform g1 g2 + | Just real <- globalRegMaybe platform g1 + , Just real' <- globalRegMaybe platform g2 + , real == real' + = True + | otherwise + = g1 == g2 + -- | Returns True if the STG register is used by the expression, in -- the sense that a store to the register might affect the value of -- the expression. @@ -461,6 +460,27 @@ reg `regUsedIn_` CmmMachOp _ es = any (reg `regUsedIn_`) es _ `regUsedIn_` CmmStackSlot _ _ = False +globalRegUsedIn :: Platform -> GlobalReg -> CmmExpr -> Bool +globalRegUsedIn platform = globalRegUsedIn_ where + _ `globalRegUsedIn_` CmmLit _ + = False + reg `globalRegUsedIn_` CmmLoad e _ _ + = reg `globalRegUsedIn_` e + reg `globalRegUsedIn_` CmmReg reg' + | CmmGlobal (GlobalRegUse reg' _) <- reg' + = globalRegsOverlap platform reg reg' + | otherwise + = False + reg `globalRegUsedIn_` CmmRegOff reg' _ + | CmmGlobal (GlobalRegUse reg' _) <- reg' + = globalRegsOverlap platform reg reg' + | otherwise + = False + reg `globalRegUsedIn_` CmmMachOp _ es + = any (reg `globalRegUsedIn_`) es + _ `globalRegUsedIn_` CmmStackSlot _ _ + = False + -------------------------------------------- -- -- mkLiveness @@ -499,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 @@ -517,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 _ [] = [] @@ -571,12 +586,12 @@ -- Access to common global registers baseExpr, spExpr, hpExpr, currentTSOExpr, currentNurseryExpr, - spLimExpr, hpLimExpr, cccsExpr :: CmmExpr -baseExpr = CmmReg baseReg -spExpr = CmmReg spReg -spLimExpr = CmmReg spLimReg -hpExpr = CmmReg hpReg -hpLimExpr = CmmReg hpLimReg -currentTSOExpr = CmmReg currentTSOReg -currentNurseryExpr = CmmReg currentNurseryReg -cccsExpr = CmmReg cccsReg + spLimExpr, hpLimExpr, cccsExpr :: Platform -> CmmExpr +baseExpr p = CmmReg $ baseReg p +spExpr p = CmmReg $ spReg p +spLimExpr p = CmmReg $ spLimReg p +hpExpr p = CmmReg $ hpReg p +hpLimExpr p = CmmReg $ hpLimReg p +currentTSOExpr p = CmmReg $ currentTSOReg p +currentNurseryExpr p = CmmReg $ currentNurseryReg p +cccsExpr p = CmmReg $ cccsReg p 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,16 +97,13 @@ 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.Driver.Session +import GHC.Types.Unique.DSM +import GHC.Driver.DynFlags import GHC.Driver.Ppr import GHC.Utils.Misc import GHC.Utils.Logger @@ -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 EagerBlackholeInfo) - | arch == ArchPPC && not (ncgPIC config) - -> cmmExprNative referenceKind $ - CmmLit (CmmLabel (mkCmmCodeLabel rtsUnitId (fsLit "__stg_EAGER_BLACKHOLE_info"))) - CmmReg (CmmGlobal GCEnter1) - | arch == ArchPPC && not (ncgPIC config) - -> cmmExprNative referenceKind $ - CmmLit (CmmLabel (mkCmmCodeLabel rtsUnitId (fsLit "__stg_gc_enter_1"))) - CmmReg (CmmGlobal 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,1899 +1,2505 @@ -{-# language GADTs #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE BinaryLiterals #-} -{-# 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 - ) --- 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 name) - -> do fileId <- getFileId (srcSpanFile span) - let line = srcSpanStartLine span; col = srcSpanStartCol span - return $ unitOL $ LOCATION fileId line col 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 platform 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 mid) - = case globalRegMaybe platform 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 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 :: 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) - --- 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 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 plat 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 plat 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 plat 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 plat 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 plat 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 plat 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 plat reg)) - r' = getRegisterReg plat reg - - -- Generic 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) - 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 platform (CmmLocal dst) - format = cmmTypeFormat rep - w = cmmRegWidth platform (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,27 +14,28 @@ 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 --- | TODO: verify this! -stackFrameHeaderSize :: Platform -> Int -stackFrameHeaderSize _ = 64 +-- | LR and FP (8 byte each) are the prologue of each stack frame +stackFrameHeaderSize :: Int +stackFrameHeaderSize = 2 * 8 -- | All registers are 8 byte wide. spillSlotSize :: Int @@ -49,14 +50,13 @@ maxSpillSlots :: NCGConfig -> Int maxSpillSlots config -- = 0 -- set to zero, to see when allocMoreStack has to fire. - = let platform = ncgPlatform config - in ((ncgSpillPreallocSize config - stackFrameHeaderSize platform) + = ((ncgSpillPreallocSize config - stackFrameHeaderSize) `div` spillSlotSize) - 1 -- | Convert a spill slot number to a *byte* offset, with no sign. spillSlotToOffset :: NCGConfig -> Int -> Int -spillSlotToOffset config slot - = stackFrameHeaderSize (ncgPlatform config) + spillSlotSize * slot +spillSlotToOffset _ slot + = stackFrameHeaderSize + spillSlotSize * slot -- | Get the registers that are being used by this instruction. -- regUsage doesn't need to do any trickery for jumps and such. @@ -80,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) @@ -100,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 ----------------------------------------------- @@ -131,27 +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] @@ -172,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] @@ -197,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. @@ -220,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) @@ -240,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 --------------------------------------------- @@ -274,18 +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) - _ -> panic $ "patchRegsOfInstr: " ++ instrCon instr + 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) + + NEWBLOCK{} -> panic $ "patchRegsOfInstr: " ++ instrCon instr + LOCATION{} -> panic $ "patchRegsOfInstr: " ++ instrCon instr where patchOp :: Operand -> Operand patchOp (OpReg w r) = OpReg w (env r) @@ -310,6 +334,7 @@ CBZ{} -> True CBNZ{} -> True J{} -> True + J_TBL{} -> True B{} -> True BL{} -> True BCOND{} -> True @@ -323,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 @@ -344,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 @@ -369,25 +401,24 @@ 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 = - case (spillSlotToOffset config slot) - delta of +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 ] imm | imm > 0xfff && imm <= 0xffffff && imm .&. 0x7 == 0x0 -> [ mkIp0SpillAddr (imm .&~. 0xfff) , mkStrIp0 (imm .&. 0xfff) ] - imm -> pprPanic "mkSpillInstr" (text "Unable to spill into" <+> int imm) + imm -> pprPanic "mkSpillInstr" (text "Unable to spill register into" <+> int imm) 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))) @@ -396,26 +427,23 @@ mkLoadInstr :: NCGConfig - -> Reg -- register to load + -> RegWithFormat -> Int -- current stack delta -> Int -- spill slot to use -> [Instr] - -mkLoadInstr config reg delta slot = - case (spillSlotToOffset config slot) - delta of +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 ] imm | imm > 0xfff && imm <= 0xffffff && imm .&. 0x7 == 0x0 -> [ mkIp0SpillAddr (imm .&~. 0xfff) , mkLdrIp0 (imm .&. 0xfff) ] - imm -> pprPanic "mkSpillInstr" (text "Unable to spill into" <+> int imm) + imm -> pprPanic "mkLoadInstr" (text "Unable to load spilled register at" <+> int imm) 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))) @@ -437,7 +465,6 @@ COMMENT{} -> True MULTILINE_COMMENT{} -> True LOCATION{} -> True - LDATA{} -> True NEWBLOCK{} -> True DELTA{} -> True PUSH_STACK_FRAME -> True @@ -446,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. @@ -480,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 @@ -495,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 @@ -540,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 @@ -571,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 @@ -595,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] @@ -609,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 @@ -645,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 @@ -660,7 +696,24 @@ | 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 + -- + -- - 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 + +data DMBISHFlags = DmbLoad | DmbLoadStore + deriving (Eq, Show) + instrCon :: Instr -> String instrCon i = case i of @@ -668,7 +721,6 @@ MULTILINE_COMMENT{} -> "COMMENT" ANN{} -> "ANN" LOCATION{} -> "LOCATION" - LDATA{} -> "LDATA" NEWBLOCK{} -> "NEWBLOCK" DELTA{} -> "DELTA" SXTB{} -> "SXTB" @@ -678,54 +730,64 @@ 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" + FMSub -> "FMSUB" + FNMAdd -> "FNMADD" + FNMSub -> "FNMSUB" data Target = TBlock BlockId @@ -765,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,9 +15,7 @@ import GHC.CmmToAsm.Utils import GHC.Cmm hiding (topInfoTable) -import GHC.Cmm.Dataflow.Collections import GHC.Cmm.Dataflow.Label -import GHC.Types.Basic (Alignment, mkAlignment, alignmentBytes) import GHC.Cmm.BlockId import GHC.Cmm.CLabel @@ -29,26 +26,26 @@ import GHC.Utils.Panic -pprProcAlignment :: IsDoc doc => NCGConfig -> doc -pprProcAlignment config = maybe empty (pprAlign platform . mkAlignment) (ncgProcAlignment config) - where - platform = ncgPlatform config - pprNatCmmDecl :: IsDoc doc => NCGConfig -> NatCmmDecl RawCmmStatics Instr -> doc pprNatCmmDecl config (CmmData section dats) = - pprSectionAlign config section $$ pprDatas config dats + let platform = ncgPlatform config + in + pprSectionAlign config section $$ pprDatas platform dats pprNatCmmDecl config proc@(CmmProc top_info lbl _ (ListGraph blocks)) = - let platform = ncgPlatform config in - pprProcAlignment config $$ + let platform = ncgPlatform config + with_dwarf = ncgDwarfEnabled config + in case topInfoTable proc of Nothing -> -- special case for code without info table: pprSectionAlign config (Section Text lbl) $$ -- do not -- pprProcAlignment config $$ - pprLabel platform lbl $$ -- blocks guaranteed not null, so label needed - vcat (map (pprBasicBlock config top_info) blocks) $$ + (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) $$ pprSizeDecl platform lbl @@ -59,7 +56,7 @@ (if platformHasSubsectionsViaSymbols platform then line (pprAsmLabel platform (mkDeadStripPreventer info_lbl) <> char ':') else empty) $$ - vcat (map (pprBasicBlock config top_info) blocks) $$ + vcat (map (pprBasicBlock platform with_dwarf top_info) blocks) $$ -- above: Even the first block gets a label, because with branch-chain -- elimination, it might be the target of a goto. (if platformHasSubsectionsViaSymbols platform @@ -80,10 +77,6 @@ $$ pprTypeDecl platform lbl $$ line (pprAsmLabel platform lbl <> char ':') -pprAlign :: IsDoc doc => Platform -> Alignment -> doc -pprAlign _platform alignment - = line $ text "\t.balign " <> int (alignmentBytes alignment) - -- | Print appropriate alignment for the given section type. pprAlignForSection :: IsDoc doc => Platform -> SectionType -> doc pprAlignForSection _platform _seg @@ -111,13 +104,13 @@ then line (text "\t.size" <+> pprAsmLabel platform lbl <> text ", .-" <> pprAsmLabel platform lbl) else empty -pprBasicBlock :: IsDoc doc => NCGConfig -> LabelMap RawCmmStatics -> NatBasicBlock Instr +pprBasicBlock :: IsDoc doc => Platform -> {- dwarf enabled -} Bool -> LabelMap RawCmmStatics -> NatBasicBlock Instr -> doc -pprBasicBlock config info_env (BasicBlock blockid instrs) +pprBasicBlock platform with_dwarf info_env (BasicBlock blockid instrs) = maybe_infotable $ pprLabel platform asmLbl $$ vcat (map (pprInstr platform) (id {-detectTrivialDeadlock-} optInstrs)) $$ - (if ncgDwarfEnabled config + (if with_dwarf then line (pprAsmLabel platform (mkAsmTempEndLabel asmLbl) <> char ':') else empty ) @@ -128,16 +121,15 @@ 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) $$ + vcat (map (pprData platform) info) $$ pprLabel platform info_lbl $$ c $$ - (if ncgDwarfEnabled config + (if with_dwarf then line (pprAsmLabel platform (mkAsmTempEndLabel info_lbl) <> char ':') else empty) -- Make sure the info table has the right .loc for the block @@ -146,34 +138,31 @@ (l@LOCATION{} : _) -> pprInstr platform l _other -> empty -pprDatas :: IsDoc doc => NCGConfig -> RawCmmStatics -> doc +pprDatas :: IsDoc doc => Platform -> RawCmmStatics -> doc -- See Note [emit-time elimination of static indirections] in "GHC.Cmm.CLabel". -pprDatas config (CmmStaticsRaw alias [CmmStaticLit (CmmLabel lbl), CmmStaticLit ind, _, _]) +pprDatas platform (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') + = pprGloblDecl platform alias + $$ line (text ".equiv" <+> pprAsmLabel platform alias <> comma <> pprAsmLabel platform ind') -pprDatas config (CmmStaticsRaw lbl dats) - = vcat (pprLabel platform lbl : map (pprData config) dats) - where - platform = ncgPlatform config +pprDatas platform (CmmStaticsRaw lbl dats) + = vcat (pprLabel platform lbl : map (pprData platform) dats) -pprData :: IsDoc doc => NCGConfig -> CmmStatic -> doc -pprData _config (CmmString str) = line (pprString str) -pprData _config (CmmFileEmbed path _) = line (pprFileEmbed path) +pprData :: IsDoc doc => Platform -> CmmStatic -> doc +pprData _platform (CmmString str) = line (pprString str) +pprData _platform (CmmFileEmbed path _) = line (pprFileEmbed path) -pprData config (CmmUninitialised bytes) - = line $ let platform = ncgPlatform config - in if platformOS platform == OSDarwin +pprData platform (CmmUninitialised bytes) + = line $ if platformOS platform == OSDarwin then text ".space " <> int bytes else text ".skip " <> int bytes -pprData config (CmmStaticLit lit) = pprDataItem config lit +pprData platform (CmmStaticLit lit) = pprDataItem platform lit pprGloblDecl :: IsDoc doc => Platform -> CLabel -> doc pprGloblDecl platform lbl @@ -207,12 +196,10 @@ then line (text ".type " <> pprAsmLabel platform lbl <> text ", " <> pprLabelType' platform lbl) else empty -pprDataItem :: IsDoc doc => NCGConfig -> CmmLit -> doc -pprDataItem config lit +pprDataItem :: IsDoc doc => Platform -> CmmLit -> doc +pprDataItem platform lit = lines_ (ppr_item (cmmTypeFormat $ cmmLitType platform lit) lit) where - platform = ncgPlatform config - imm = litToImm lit ppr_item II8 _ = [text "\t.byte\t" <> pprImm platform imm] @@ -320,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) @@ -346,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 @@ -371,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 ------------------------------------------------------- @@ -385,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 @@ -410,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 @@ -420,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 @@ -432,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 @@ -475,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 @@ -540,22 +515,47 @@ 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" + FMSub -> text "\tfmsub" + FNMAdd -> text "\tfnmadd" + FNMSub -> text "\tfnmsub" + in op4 fma d r1 r2 r3 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 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 @@ -14,6 +14,7 @@ where import GHC.Prelude hiding (head, init, last, tail) +import qualified GHC.Prelude as Partial (head, tail) import GHC.Platform @@ -25,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 @@ -37,11 +37,9 @@ import GHC.Utils.Outputable import GHC.Utils.Panic -import GHC.Utils.Panic.Plain import GHC.Utils.Misc import Data.List (sortOn, sortBy, nub) -import qualified Data.List as Partial (head, tail) import Data.List.NonEmpty (nonEmpty) import qualified Data.List.NonEmpty as NE import Data.Foldable (toList) @@ -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 @@ -5,7 +5,8 @@ import GHC.Prelude import GHC.Cmm.CLabel -import GHC.Cmm.Expr ( GlobalReg(..) ) +import GHC.Cmm.Expr +import GHC.Data.FastString import GHC.Settings.Config ( cProjectName, cProjectVersion ) import GHC.Types.Tickish ( CmmTickish, GenTickish(..) ) import GHC.Cmm.DebugBlock @@ -13,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 @@ -28,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 @@ -65,7 +64,7 @@ -- .debug_info section: Information records on procedures and blocks -- unique to identify start and end compilation unit .debug_inf - (unitU, us') = takeUniqFromSupply us + (unitU, us') = takeUniqueFromDSupply us infoSct = vcat [ line (dwarfInfoLabel <> colon) , dwarfInfoSection platform , compileUnitHeader platform unitU @@ -79,10 +78,10 @@ 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 framesU procs) + pprDwarfFrame platform (debugFrame platform framesU procs) -- .aranges section: Information about the bounds of compilation units aranges' | ncgSplitSections config = map mkDwarfARange procs @@ -90,8 +89,8 @@ aranges = dwarfARangesSection platform $$ pprDwarfARanges platform aranges' unitU in (infoSct $$ abbrevSct $$ lineSct $$ frameSct $$ aranges, us'') -{-# SPECIALIZE dwarfGen :: String -> NCGConfig -> ModLocation -> UniqSupply -> [DebugBlock] -> (SDoc, UniqSupply) #-} -{-# SPECIALIZE dwarfGen :: String -> NCGConfig -> ModLocation -> UniqSupply -> [DebugBlock] -> (HDoc, UniqSupply) #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable +{-# SPECIALIZE dwarfGen :: String -> NCGConfig -> ModLocation -> DUniqSupply -> [DebugBlock] -> (SDoc, DUniqSupply) #-} +{-# SPECIALIZE dwarfGen :: String -> NCGConfig -> ModLocation -> DUniqSupply -> [DebugBlock] -> (HDoc, DUniqSupply) #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable -- | Build an address range entry for one proc. -- With split sections, each proc needs its own entry, since they may get @@ -177,7 +176,8 @@ procToDwarf config prc = DwarfSubprogram { dwChildren = map (blockToDwarf config) (dblBlocks prc) , dwName = case dblSourceTick prc of - Just s@SourceNote{} -> sourceName s + Just s@SourceNote{} -> case sourceName s of + LexicalFastString s -> unpackFS s _otherwise -> show (dblLabel prc) , dwLabel = dblCLabel prc , dwParent = fmap mkAsmTempDieLabel @@ -215,15 +215,15 @@ -- | Generates the data for the debug frame section, which encodes the -- desired stack unwind behaviour for the debugger -debugFrame :: Unique -> [DebugBlock] -> DwarfFrame -debugFrame u procs +debugFrame :: Platform -> Unique -> [DebugBlock] -> DwarfFrame +debugFrame p u procs = DwarfFrame { dwCieLabel = mkAsmTempLabel u , dwCieInit = initUws , dwCieProcs = map (procToFrame initUws) procs } where initUws :: UnwindTable - initUws = Map.fromList [(Sp, Just (UwReg Sp 0))] + initUws = Map.fromList [(Sp, Just (UwReg (GlobalRegUse Sp $ bWord p) 0))] -- | Generates unwind information for a procedure debug block procToFrame :: UnwindTable -> DebugBlock -> DwarfFrameProc 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 @@ -31,7 +31,7 @@ import GHC.Cmm.DebugBlock import GHC.Cmm.CLabel -import GHC.Cmm.Expr ( GlobalReg(..) ) +import GHC.Cmm.Expr import GHC.Utils.Encoding import GHC.Data.FastString import GHC.Utils.Outputable @@ -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 #-} @@ -469,7 +469,7 @@ = if o' >= 0 then pprByte dW_CFA_def_cfa_offset $$ pprLEBWord (fromIntegral o') else pprByte dW_CFA_def_cfa_offset_sf $$ pprLEBInt o' -pprSetUnwind plat Sp (_, Just (UwReg s' o')) +pprSetUnwind plat Sp (_, Just (UwReg (GlobalRegUse s' _) o')) = if o' >= 0 then pprByte dW_CFA_def_cfa $$ pprLEBRegNo plat s' $$ @@ -479,7 +479,7 @@ pprLEBInt o' pprSetUnwind plat Sp (_, Just uw) = pprByte dW_CFA_def_cfa_expression $$ pprUnwindExpr plat False uw -pprSetUnwind plat g (_, Just (UwDeref (UwReg Sp o))) +pprSetUnwind plat g (_, Just (UwDeref (UwReg (GlobalRegUse Sp _) o))) | o < 0 && ((-o) `mod` platformWordSizeInBytes plat) == 0 -- expected case = pprByte (dW_CFA_offset + dwarfGlobalRegNo plat g) $$ pprLEBWord (fromIntegral ((-o) `div` platformWordSizeInBytes plat)) @@ -491,7 +491,7 @@ = pprByte dW_CFA_expression $$ pprLEBRegNo plat g $$ pprUnwindExpr plat True uw -pprSetUnwind plat g (_, Just (UwReg g' 0)) +pprSetUnwind plat g (_, Just (UwReg (GlobalRegUse g' _) 0)) | g == g' = pprByte dW_CFA_same_value $$ pprLEBRegNo plat g @@ -513,12 +513,14 @@ = let pprE (UwConst i) | i >= 0 && i < 32 = pprByte (dW_OP_lit0 + fromIntegral i) | otherwise = pprByte dW_OP_consts $$ pprLEBInt i -- lazy... - pprE (UwReg Sp i) | spIsCFA - = if i == 0 - then pprByte dW_OP_call_frame_cfa - else pprE (UwPlus (UwReg Sp 0) (UwConst i)) - pprE (UwReg g i) = pprByte (dW_OP_breg0+dwarfGlobalRegNo platform g) $$ - pprLEBInt i + pprE (UwReg r@(GlobalRegUse Sp _) i) + | spIsCFA + = if i == 0 + then pprByte dW_OP_call_frame_cfa + else pprE (UwPlus (UwReg r 0) (UwConst i)) + pprE (UwReg (GlobalRegUse g _) i) + = pprByte (dW_OP_breg0+dwarfGlobalRegNo platform g) $$ + pprLEBInt i pprE (UwDeref u) = pprE u $$ pprByte dW_OP_deref pprE (UwLabel l) = pprByte dW_OP_addr $$ pprWord platform (pprAsmLabel platform l) pprE (UwPlus u1 u2) = pprE u1 $$ pprE u2 $$ pprByte dW_OP_plus 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,9 +179,16 @@ | 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 PicBaseReg) + [ CmmReg (CmmGlobal $ GlobalRegUse PicBaseReg (bWord platform)) , CmmLit $ picRelative (wordWidth platform) (platformArch platform) (platformOS platform) @@ -175,7 +197,7 @@ -- both ABI versions default to medium code model | ArchPPC_64 _ <- platformArch platform = CmmMachOp (MO_Add W32) -- code model medium - [ CmmReg (CmmGlobal PicBaseReg) + [ CmmReg (CmmGlobal $ GlobalRegUse PicBaseReg (bWord platform)) , CmmLit $ picRelative (wordWidth platform) (platformArch platform) (platformOS platform) @@ -184,7 +206,7 @@ | (ncgPIC config || ncgExternalDynamicRefs config) && absoluteLabel lbl = CmmMachOp (MO_Add (wordWidth platform)) - [ CmmReg (CmmGlobal PicBaseReg) + [ CmmReg (CmmGlobal $ GlobalRegUse PicBaseReg (bWord platform)) , CmmLit $ picRelative (wordWidth platform) (platformArch platform) (platformOS 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 @@ -129,10 +128,10 @@ -- Generate location directive dbg <- getDebugBlock (entryLabel block) loc_instrs <- case dblSourceTick =<< dbg of - Just (SourceNote span name) + Just (SourceNote span (LexicalFastString name)) -> do fileid <- getFileId (srcSpanFile span) let line = srcSpanStartLine span; col =srcSpanStartCol span - return $ unitOL $ LOCATION fileid line col name + return $ unitOL $ LOCATION fileid line col (unpackFS name) _ -> return nilOL mid_instrs <- stmtsToInstrs stmts tail_instrs <- stmtToInstrs tail @@ -171,7 +170,7 @@ | target32Bit platform && isWord64 ty -> assignReg_I64Code reg src | otherwise -> assignReg_IntCode format reg src - where ty = cmmRegType platform reg + where ty = cmmRegType reg format = cmmTypeFormat ty CmmStore addr src _alignment @@ -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 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 @@ -253,12 +255,12 @@ -- Expand CmmRegOff. ToDo: should we do it this way around, or convert -- CmmExprs into CmmRegOff? -mangleIndexTree :: Platform -> CmmExpr -> CmmExpr -mangleIndexTree platform (CmmRegOff reg off) +mangleIndexTree :: CmmExpr -> CmmExpr +mangleIndexTree (CmmRegOff reg off) = CmmMachOp (MO_Add width) [CmmReg reg, CmmLit (CmmInt (fromIntegral off) width)] - where width = typeWidth (cmmRegType platform reg) + where width = typeWidth (cmmRegType reg) -mangleIndexTree _ _ +mangleIndexTree _ = panic "PPC.CodeGen.mangleIndexTree: no match" -- ----------------------------------------------------------------------------- @@ -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 @@ -404,7 +406,7 @@ getRegister' :: NCGConfig -> Platform -> CmmExpr -> NatM Register -getRegister' _ platform (CmmReg (CmmGlobal PicBaseReg)) +getRegister' _ platform (CmmReg (CmmGlobal (GlobalRegUse PicBaseReg _))) | OSAIX <- platformOS platform = do let code dst = toOL [ LD II32 dst tocAddr ] tocAddr = AddrRegImm toc (ImmLit (fsLit "ghc_toc_table[TC]")) @@ -416,11 +418,11 @@ | otherwise = return (Fixed II64 toc nilOL) getRegister' _ platform (CmmReg reg) - = return (Fixed (cmmTypeFormat (cmmRegType platform reg)) + = return (Fixed (cmmTypeFormat (cmmRegType reg)) (getRegisterReg platform reg) nilOL) getRegister' config platform tree@(CmmRegOff _ _) - = getRegister' config platform (mangleIndexTree platform tree) + = getRegister' config platform (mangleIndexTree tree) -- for 32-bit architectures, support some 64 -> 32 bit conversions: -- TO_W_(x), TO_W_(x >> 32) @@ -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,7 +693,56 @@ 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 + + -- x86 fmadd x * y + z <> PPC fmadd rt = ra * rc + rb + -- x86 fmsub x * y - z <> PPC fmsub rt = ra * rc - rb + -- 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 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 = let @@ -735,8 +828,7 @@ getAmode :: InstrForm -> CmmExpr -> NatM Amode getAmode inf tree@(CmmRegOff _ _) - = do platform <- getPlatform - getAmode inf (mangleIndexTree platform tree) + = getAmode inf (mangleIndexTree tree) getAmode _ (CmmMachOp (MO_Sub W32) [x, CmmLit (CmmInt i _)]) | Just off <- makeImmediate W32 True (-i) @@ -1038,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) @@ -1048,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 @@ -1112,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 @@ -1894,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'') @@ -1920,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 @@ -1930,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) @@ -1941,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 @@ -1952,14 +2060,14 @@ -> toOL [MR (getHiVRegFromLo r_dest) r3, MR r_dest r4] | otherwise -> unitOL (MR r_dest r3) - where rep = cmmRegType platform (CmmLocal dest) + where rep = cmmRegType (CmmLocal dest) r_dest = getLocalRegReg dest _ -> panic "genCCall' moveResult: Bad dest_regs" 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 @@ -2080,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 @@ -2359,10 +2476,28 @@ let code' dst = code `snocOL` instr dst src return (Any rep code') +-- | Generate code for a 4-register FMA instruction, +-- e.g. @fmadd rt ra rc rb := rt <- ra * rc + rb@. +fma_code :: Width + -> (Format -> Reg -> Reg -> Reg -> Reg -> Instr) + -> CmmExpr + -> CmmExpr + -> CmmExpr + -> NatM Register +fma_code w instr ra rc rb = do + let rep = floatFormat w + (src1, code1) <- getSomeReg ra + (src2, code2) <- getSomeReg rc + (src3, code3) <- getSomeReg rb + let instrCode rt = + code1 `appOL` + code2 `appOL` + code3 `snocOL` instr rep rt src1 src2 src3 + return $ Any rep instrCode + -- There is no "remainder" instruction on the PPC, so we have to do -- it the hard way. -- The "sgn" parameter is the signedness for the division instruction - remainderCode :: Width -> Bool -> Reg -> CmmExpr -> CmmExpr -> NatM (Reg -> InstrBlock) remainderCode rep sgn reg_q arg_x arg_y = do 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 @@ -281,6 +276,14 @@ | FABS Reg Reg -- abs is the same for single and double | FNEG Reg Reg -- negate is the same for single and double prec. + -- | Fused multiply-add instructions. + -- + -- - FMADD: @rd = (ra * rb) + rd@ + -- - FMSUB: @rd = ra * rb - rd@ + -- - FNMADD: @rd = -(ra * rb + rd)@ + -- - FNMSUB: @rd = -(ra * rb - rd)@ + | FMADD FMASign Format Reg Reg Reg Reg + | FCMP Reg Reg | FCTIWZ Reg Reg -- convert to integer word @@ -326,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) @@ -381,10 +384,18 @@ MFCR reg -> usage ([], [reg]) MFLR reg -> usage ([], [reg]) FETCHPC reg -> usage ([], [reg]) + 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] @@ -468,6 +479,8 @@ FDIV fmt r1 r2 r3 -> FDIV fmt (env r1) (env r2) (env r3) FABS r1 r2 -> FABS (env r1) (env r2) FNEG r1 r2 -> FNEG (env r1) (env r2) + FMADD sgn fmt r1 r2 r3 r4 + -> FMADD sgn fmt (env r1) (env r2) (env r3) (env r4) FCMP r1 r2 -> FCMP (env r1) (env r2) FCTIWZ r1 r2 -> FCTIWZ (env r1) (env r2) FCTIDZ r1 r2 -> FCTIDZ (env r1) (env r2) @@ -537,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 @@ -551,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 @@ -562,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 @@ -576,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 @@ -655,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. @@ -688,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 @@ -706,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. @@ -934,6 +941,9 @@ FNEG reg1 reg2 -> pprUnary (text "fneg") reg1 reg2 + FMADD signs fmt dst ra rc rb + -> pprTernaryF (pprFMASign signs) fmt dst ra rc rb + FCMP reg1 reg2 -> line $ hcat [ char '\t', @@ -1081,6 +1091,21 @@ pprReg reg2, text ", ", pprReg reg3 + ] + +pprTernaryF :: IsDoc doc => Line doc -> Format -> Reg -> Reg -> Reg -> Reg -> doc +pprTernaryF op fmt rt ra rc rb = line $ hcat [ + char '\t', + op, + pprFFormat fmt, + char '\t', + pprReg rt, + text ", ", + pprReg ra, + text ", ", + pprReg rc, + text ", ", + pprReg rb ] pprRI :: IsLine doc => Platform -> RI -> doc 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,16 +3,16 @@ import GHC.Prelude import GHC.CmmToAsm.AArch64.Regs -import GHC.Platform.Reg.Class +import GHC.Platform.Reg.Class.Unified import GHC.Platform.Reg import GHC.Utils.Outputable import GHC.Utils.Panic +import GHC.Utils.Misc( HasDebugCallStack ) import GHC.Platform import Data.Word -import GHC.Stack -- AArch64 has 32 64bit general purpose register r0..r30, and zr/sp -- AArch64 has 32 128bit floating point registers v0..v31 as part of the NEON -- extension in Armv8-A. @@ -65,7 +65,7 @@ showBits w = map (\i -> if testBit w i then '1' else '0') [0..31] -- FR instance implementation (See Linear.FreeRegs) -allocateReg :: HasCallStack => RealReg -> FreeRegs -> FreeRegs +allocateReg :: HasDebugCallStack => RealReg -> FreeRegs -> FreeRegs allocateReg (RealRegSingle r) (FreeRegs g f) | r > 31 && testBit f (r - 32) = FreeRegs g (clearBit f (r - 32)) | r < 32 && testBit g r = FreeRegs (clearBit g r) f @@ -115,10 +115,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) @@ -127,7 +128,7 @@ initFreeRegs :: Platform -> FreeRegs initFreeRegs platform = foldl' (flip releaseReg) noFreeRegs (allocatableRegs platform) -releaseReg :: HasCallStack => RealReg -> FreeRegs -> FreeRegs +releaseReg :: HasDebugCallStack => RealReg -> FreeRegs -> FreeRegs releaseReg (RealRegSingle r) (FreeRegs g f) | r > 31 && testBit f (r - 32) = pprPanic "Linear.AArch64.releaseReg" (text "can't release non-allocated reg v" <> int (r - 32)) | r < 32 && testBit g r = pprPanic "Linear.AArch64.releaseReg" (text "can't release non-allocated reg x" <> int r) 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 @@ -199,8 +199,7 @@ (return ()) -} delta <- getDeltaR - fixUpInstrs_ <- mapM (handleComponent delta instr) sccs - let fixUpInstrs = concat fixUpInstrs_ + fixUpInstrs <- concatMapM (handleComponent delta instr) sccs -- make a new basic block containing the fixup code. -- A the end of the current block we will jump to the fixup one, @@ -328,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) @@ -361,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,6 +47,8 @@ import GHC.Types.Unique import GHC.Types.Unique.FM import GHC.Types.Unique.Map +import GHC.Types.Unique.Set +import GHC.Types.Unique.DSM import GHC.Utils.Outputable hiding ((<>)) import GHC.Utils.Panic import GHC.Wasm.ControlFlow.FromCmm @@ -177,7 +178,7 @@ -} globalInfoFromCmmGlobalReg :: WasmTypeTag w -> GlobalReg -> Maybe GlobalInfo globalInfoFromCmmGlobalReg t reg = case reg of - VanillaReg i _ + VanillaReg i | i >= 1 && i <= 10 -> Just (fromString $ "__R" <> show i, ty_word) FloatReg i | i >= 1 && i <= 6 -> @@ -197,7 +198,7 @@ supportedCmmGlobalRegs :: [GlobalReg] supportedCmmGlobalRegs = - [VanillaReg i VGcPtr | i <- [1 .. 10]] + [VanillaReg i | i <- [1 .. 10]] <> [FloatReg i | i <- [1 .. 6]] <> [DoubleReg i | i <- [1 .. 6]] <> [LongReg i | i <- [1 .. 1]] @@ -437,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) @@ -619,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 -> @@ -627,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 @@ -776,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 @@ -797,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 @@ -815,7 +872,11 @@ 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 _ _ _ = panic "lower_CmmMachOp: unreachable" +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 ] -- | Lower a 'CmmLit'. Note that we don't emit 'f32.const' or -- 'f64.const' for the time being, and instead emit their relative bit @@ -872,38 +933,35 @@ lower_CmmReg _ (CmmLocal reg) = do (reg_i, SomeWasmType ty) <- onCmmLocalReg reg pure $ SomeWasmExpr ty $ WasmExpr $ WasmLocalGet ty reg_i -lower_CmmReg _ (CmmGlobal EagerBlackholeInfo) = do - ty_word <- wasmWordTypeM - pure $ - SomeWasmExpr ty_word $ - WasmExpr $ - WasmSymConst "__stg_EAGER_BLACKHOLE_info" -lower_CmmReg _ (CmmGlobal GCEnter1) = do - ty_word <- wasmWordTypeM - ty_word_cmm <- wasmWordCmmTypeM - onFuncSym "__stg_gc_enter_1" [] [ty_word_cmm] - pure $ SomeWasmExpr ty_word $ WasmExpr $ WasmSymConst "__stg_gc_enter_1" -lower_CmmReg _ (CmmGlobal GCFun) = do +lower_CmmReg lbl (CmmGlobal (GlobalRegUse greg reg_use_ty)) = do ty_word <- wasmWordTypeM ty_word_cmm <- wasmWordCmmTypeM - onFuncSym "__stg_gc_fun" [] [ty_word_cmm] - pure $ SomeWasmExpr ty_word $ WasmExpr $ WasmSymConst "__stg_gc_fun" -lower_CmmReg lbl (CmmGlobal BaseReg) = do - platform <- wasmPlatformM - lower_CmmExpr lbl $ regTableOffset platform 0 -lower_CmmReg lbl (CmmGlobal reg) = do - ty_word <- wasmWordTypeM - if + case greg of + EagerBlackholeInfo -> + pure $ + SomeWasmExpr ty_word $ + WasmExpr $ + WasmSymConst "__stg_EAGER_BLACKHOLE_info" + GCEnter1 -> do + onFuncSym "__stg_gc_enter_1" [] [ty_word_cmm] + pure $ SomeWasmExpr ty_word $ WasmExpr $ WasmSymConst "__stg_gc_enter_1" + GCFun -> do + onFuncSym "__stg_gc_fun" [] [ty_word_cmm] + pure $ SomeWasmExpr ty_word $ WasmExpr $ WasmSymConst "__stg_gc_fun" + BaseReg -> do + platform <- wasmPlatformM + lower_CmmExpr lbl $ regTableOffset platform 0 + _other | Just (sym_global, SomeWasmType ty) <- - globalInfoFromCmmGlobalReg ty_word reg -> + globalInfoFromCmmGlobalReg ty_word greg -> pure $ SomeWasmExpr ty $ WasmExpr $ WasmGlobalGet ty sym_global | otherwise -> do platform <- wasmPlatformM - case someWasmTypeFromCmmType $ globalRegType platform reg of + case someWasmTypeFromCmmType reg_use_ty of SomeWasmType ty -> do (WasmExpr ptr_instr, o) <- lower_CmmExpr_Ptr lbl $ - get_GlobalReg_addr platform reg + get_GlobalReg_addr platform greg pure $ SomeWasmExpr ty $ WasmExpr $ @@ -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 @@ -1331,7 +1406,7 @@ [CmmActual] -> WasmCodeGenM w (WasmStatements w) lower_CmmUnsafeForeignCall_Drop lbl sym_callee ret_cmm_ty arg_exprs = do - ret_uniq <- wasmUniq + ret_uniq <- getUniqueM let ret_local = LocalReg ret_uniq ret_cmm_ty lower_CmmUnsafeForeignCall lbl @@ -1379,7 +1454,7 @@ (reg_i, SomeWasmType reg_ty) <- onCmmLocalReg reg pure $ SomeWasmPostCCall (reg_ty `TypeListCons` acc_tys) $ - case (# ret_hint, cmmRegWidth platform $ CmmLocal reg #) of + case (# ret_hint, cmmRegWidth $ CmmLocal reg #) of (# SignedHint, W8 #) -> acc_instr `WasmConcat` WasmConst reg_ty 0xFF @@ -1458,7 +1533,7 @@ (i, SomeWasmType ty_reg) <- onCmmLocalReg reg WasmExpr instrs <- lower_CmmExpr_Typed lbl ty_reg e pure $ WasmStatements $ instrs `WasmConcat` WasmLocalSet ty_reg i - CmmAssign (CmmGlobal reg) e + CmmAssign (CmmGlobal (GlobalRegUse reg _)) e | BaseReg <- reg -> pure $ WasmStatements WasmNop | Just (sym_global, SomeWasmType ty_reg) <- globalInfoFromCmmGlobalReg ty_word reg -> do @@ -1551,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,7 +45,9 @@ wasmStateM, wasmModifyM, wasmExecM, - wasmUniq, + wasmRunM, + WasmAsmConfig (..), + defaultWasmAsmConfig ) where @@ -53,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 @@ -67,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 @@ -137,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 @@ -198,7 +202,7 @@ type SymMap = UniqMap SymName -- | No need to remember the symbols. -type SymSet = WS.Word64Set +type SymSet = UniqueSet type GlobalInfo = (SymName, SomeWasmType) @@ -306,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)) @@ -420,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, @@ -437,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 @@ -469,7 +481,42 @@ wasmExecM :: WasmCodeGenM w a -> WasmCodeGenState w -> WasmCodeGenState w wasmExecM (WasmCodeGenM s) = execState s -wasmUniq :: WasmCodeGenM w Unique -wasmUniq = wasmStateM $ - \s@WasmCodeGenState {..} -> case takeUniqFromSupply wasmUniqSupply of - (u, us) -> (# u, s {wasmUniqSupply = us} #) +wasmRunM :: WasmCodeGenM w a -> WasmCodeGenState w -> (a, WasmCodeGenState w) +wasmRunM (WasmCodeGenM s) = runState s + +instance MonadGetUnique (WasmCodeGenM w) where + getUniqueM = wasmStateM $ + \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/Wasm/Utils.hs b/GHC/CmmToAsm/Wasm/Utils.hs --- a/GHC/CmmToAsm/Wasm/Utils.hs +++ b/GHC/CmmToAsm/Wasm/Utils.hs @@ -23,7 +23,7 @@ detEltsUFM = sortOn fst . nonDetEltsUFM detEltsUniqMap :: Ord k => UniqMap k a -> [(k, a)] -detEltsUniqMap = sortOn fst . nonDetEltsUniqMap +detEltsUniqMap = sortOn fst . nonDetUniqMapToList builderCommas :: (a -> Builder) -> [a] -> Builder builderCommas f xs = mconcat (intersperse ", " (map f xs)) 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,4411 +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 name) - -> do fileId <- getFileId (srcSpanFile span) - let line = srcSpanStartLine span; col = srcSpanStartCol span - return $ unitOL $ LOCATION fileId line col 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 - if ncgDwarfUnwindings config - then do lbl <- mkAsmTempLabel <$> getUniqueM - let unwind = M.singleton MachSp (Just $ UwReg MachSp $ 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 platform 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 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 :: Platform -> CmmReg -> Int -> CmmExpr -mangleIndexTree platform reg off - = CmmMachOp (MO_Add width) [CmmReg reg, CmmLit (CmmInt (fromIntegral off) width)] - where width = typeWidth (cmmRegType platform 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' platform is32Bit (CmmReg reg) - = case reg of - CmmGlobal 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 platform reg) - format = fmt - -- - platform <- ncgPlatform <$> getConfig - return (Fixed format - (getRegisterReg platform reg) - nilOL) - - -getRegister' platform is32Bit (CmmRegOff r n) - = getRegister' platform is32Bit $ mangleIndexTree platform 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 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' _ _ (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 platform r n - - CmmMachOp (MO_Add W64) [CmmReg (CmmGlobal 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 = reverse (drop (length rs) (reverse 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 - ------------ - -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 #-} ----------------------------------------------------------------------------- @@ -12,6 +14,7 @@ ( Instr(..) , Operand(..) , PrefetchVariant(..) + , FMAPermutation(..) , JumpDest(..) , getJumpDestBlockId , canShortcut @@ -29,12 +32,14 @@ , mkStackDeallocInstr , mkSpillInstr , mkRegRegMoveInstr + , movInstr , jumpDestsOfInstr , canFallthroughTo , patchRegsOfInstr , patchJumpInstr , isMetaInstr , isJumpishInstr + , MinOrMax(..), MinMaxType(..) ) where @@ -44,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 @@ -64,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. -- @@ -80,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 @@ -196,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) @@ -241,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 @@ -249,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 @@ -257,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 @@ -273,11 +211,17 @@ | CVTSI2SS Format Operand Reg -- I32/I64 to F32 | CVTSI2SD Format Operand Reg -- I32/I64 to F64 + -- | FMA3 fused multiply-add operations. + | FMA3 Format FMASign FMAPermutation Operand Reg Reg + -- 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. @@ -298,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 @@ -308,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 @@ -344,111 +288,372 @@ | 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 | OpImm Imm -- immediate value | OpAddr AddrMode -- memory reference - +-- NB: As of 2023 we only use the FMA213 permutation. +data FMAPermutation = FMA132 | FMA213 | FMA231 -- | Returns which registers are read and written as a (read, written) -- pair. 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 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 @@ -459,75 +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 :: 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 @@ -547,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 @@ -562,6 +797,8 @@ JMP op regs -> JMP (patchOp op) regs JMP_TBL op ids s lbl -> JMP_TBL (patchOp op) ids s lbl + FMA3 fmt perm var x1 x2 x3 -> patch3 (FMA3 fmt perm var) x1 x2 x3 + -- literally only support storing the top x87 stack value st(0) X87Store fmt dst -> X87Store fmt (lookupAddr dst) @@ -571,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 @@ -585,6 +822,8 @@ LOCATION {} -> instr UNWIND {} -> instr DELTA _ -> instr + LDATA {} -> instr + NEWBLOCK {} -> instr JXX _ _ -> instr JXX_GBL _ _ -> instr @@ -600,19 +839,131 @@ 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 patch2 :: (Operand -> Operand -> a) -> Operand -> Operand -> a patch2 insn src dst = (insn $! patchOp src) $! patchOp dst + patch3 :: (Operand -> Reg -> Reg -> a) -> Operand -> Reg -> Reg -> a + patch3 insn src1 src2 dst = ((insn $! patchOp src1) $! env src2) $! env dst patchOp (OpReg reg) = OpReg $! env reg patchOp (OpImm imm) = OpImm imm @@ -686,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 @@ -772,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 @@ -849,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 @@ -879,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 -> @@ -960,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 @@ -975,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 @@ -1006,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 @@ -1016,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 @@ -1049,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 @@ -1064,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,46 +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 - pprProcAlignment config $$ - 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) @@ -120,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 @@ -138,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 @@ -157,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] @@ -293,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 { @@ -320,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 { @@ -374,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"; @@ -384,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" @@ -398,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 @@ -407,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 @@ -507,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 @@ -587,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 @@ -679,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) @@ -733,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 @@ -836,8 +915,16 @@ -> 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 + FMAdd -> text "vfmadd" + FMSub -> text "vfmsub" + FNMAdd -> text "vfnmadd" + FNMSub -> text "vfnmsub" + in pprFormatOpRegReg (mnemo <> pprFMAPermutation perm) format op1 op2 op3 + SQRT format op1 op2 -> pprFormatOpReg (text "sqrt") format op1 op2 @@ -894,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' @@ -933,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 [ @@ -943,7 +1193,6 @@ pprOperand platform format op1 ] - pprFormatOp_ :: Line doc -> Format -> Operand -> doc pprFormatOp_ name format op1 = line $ hcat [ @@ -968,7 +1217,50 @@ 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 reg2 reg3 + = line $ hcat [ + pprMnemonic name format, + pprOperand platform format op1, + comma, + pprReg platform format reg2, + comma, + pprReg platform format reg3 + ] + + pprFMAPermutation :: FMAPermutation -> Line doc + pprFMAPermutation FMA132 = text "132" + pprFMAPermutation FMA213 = text "213" + pprFMAPermutation FMA231 = text "231" + pprOpOp :: Line doc -> Format -> Operand -> Operand -> doc pprOpOp name format op1 op2 = line $ hcat [ @@ -987,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 [ @@ -1048,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, @@ -1061,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 @@ -383,7 +383,7 @@ -- CmmRegOff is an alias of MO_Add CmmRegOff reg i -> pprExpr platform $ CmmMachOp (MO_Add w) [CmmReg reg, CmmLit $ CmmInt (toInteger i) w] - where w = cmmRegWidth platform reg + where w = cmmRegWidth reg CmmMachOp mop args -> pprMachOpApp platform mop args @@ -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) @@ -529,11 +532,23 @@ pprMachOpApp' :: Platform -> MachOp -> [CmmExpr] -> SDoc pprMachOpApp' platform mop args = case args of + + -- ternary + 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" @@ -693,60 +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 '/' + -- Floating-point operations + 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 1 w -> + case w of + 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 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. @@ -754,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 @@ -861,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 @@ -924,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" @@ -959,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 @@ -1044,9 +1140,11 @@ | isFixedPtrReg r1 = mkAssign (mkP_ <> pprExpr1 platform r2) | Just ty <- strangeRegType r1 = mkAssign (parens ty <> pprExpr1 platform r2) | otherwise = mkAssign (pprExpr platform r2) - where mkAssign x = if r1 == CmmGlobal BaseReg - then text "ASSIGN_BaseReg" <> parens x <> semi - else pprReg r1 <> text " = " <> x <> semi + where mkAssign x = + case r1 of + CmmGlobal (GlobalRegUse BaseReg _) -> + text "ASSIGN_BaseReg" <> parens x <> semi + _ -> pprReg r1 <> text " = " <> x <> semi -- --------------------------------------------------------------------- -- Registers @@ -1061,17 +1159,16 @@ -- StgPtr. isFixedPtrReg :: CmmReg -> Bool isFixedPtrReg (CmmLocal _) = False -isFixedPtrReg (CmmGlobal r) = isFixedPtrGlobalReg r +isFixedPtrReg (CmmGlobal (GlobalRegUse r _)) = isFixedPtrGlobalReg r -- True if (pprAsPtrReg reg) will give an expression with type StgPtr -- JD: THIS IS HORRIBLE AND SHOULD BE RENAMED, AT THE VERY LEAST. -- THE GARBAGE WITH THE VNonGcPtr HELPS MATCH THE OLD CODE GENERATOR'S OUTPUT; -- I'M NOT SURE IF IT SHOULD REALLY STAY THAT WAY. isPtrReg :: CmmReg -> Bool -isPtrReg (CmmLocal _) = False -isPtrReg (CmmGlobal (VanillaReg _ VGcPtr)) = True -- if we print via pprAsPtrReg -isPtrReg (CmmGlobal (VanillaReg _ VNonGcPtr)) = False -- if we print via pprAsPtrReg -isPtrReg (CmmGlobal reg) = isFixedPtrGlobalReg reg +isPtrReg (CmmLocal _) = False +isPtrReg (CmmGlobal (GlobalRegUse (VanillaReg _) ty)) = isGcPtrType ty -- if we print via pprAsPtrReg +isPtrReg (CmmGlobal (GlobalRegUse reg _)) = isFixedPtrGlobalReg reg -- True if this global reg has type StgPtr isFixedPtrGlobalReg :: GlobalReg -> Bool @@ -1085,7 +1182,7 @@ -- (machRepCType (cmmRegType reg)), so it has to be cast. isStrangeTypeReg :: CmmReg -> Bool isStrangeTypeReg (CmmLocal _) = False -isStrangeTypeReg (CmmGlobal g) = isStrangeTypeGlobal g +isStrangeTypeReg (CmmGlobal (GlobalRegUse g _)) = isStrangeTypeGlobal g isStrangeTypeGlobal :: GlobalReg -> Bool isStrangeTypeGlobal CCCS = True @@ -1095,10 +1192,10 @@ isStrangeTypeGlobal r = isFixedPtrGlobalReg r strangeRegType :: CmmReg -> Maybe SDoc -strangeRegType (CmmGlobal CCCS) = Just (text "struct CostCentreStack_ *") -strangeRegType (CmmGlobal CurrentTSO) = Just (text "struct StgTSO_ *") -strangeRegType (CmmGlobal CurrentNursery) = Just (text "struct bdescr_ *") -strangeRegType (CmmGlobal BaseReg) = Just (text "struct StgRegTable_ *") +strangeRegType (CmmGlobal (GlobalRegUse CCCS _)) = Just (text "struct CostCentreStack_ *") +strangeRegType (CmmGlobal (GlobalRegUse CurrentTSO _)) = Just (text "struct StgTSO_ *") +strangeRegType (CmmGlobal (GlobalRegUse CurrentNursery _)) = Just (text "struct bdescr_ *") +strangeRegType (CmmGlobal (GlobalRegUse BaseReg _)) = Just (text "struct StgRegTable_ *") strangeRegType _ = Nothing -- pprReg just prints the register name. @@ -1106,16 +1203,16 @@ pprReg :: CmmReg -> SDoc pprReg r = case r of CmmLocal local -> pprLocalReg local - CmmGlobal global -> pprGlobalReg global + CmmGlobal (GlobalRegUse global _ ) -> pprGlobalReg global pprAsPtrReg :: CmmReg -> SDoc -pprAsPtrReg (CmmGlobal (VanillaReg n gcp)) - = warnPprTrace (gcp /= VGcPtr) "pprAsPtrReg" (ppr n) $ char 'R' <> int n <> text ".p" +pprAsPtrReg (CmmGlobal (GlobalRegUse (VanillaReg n) ty)) + = warnPprTrace (not $ isGcPtrType ty) "pprAsPtrReg" (ppr n) $ char 'R' <> int n <> text ".p" pprAsPtrReg other_reg = pprReg other_reg pprGlobalReg :: GlobalReg -> SDoc pprGlobalReg gr = case gr of - VanillaReg n _ -> char 'R' <> int n <> text ".w" + VanillaReg n -> char 'R' <> int n <> text ".w" -- pprGlobalReg prints a VanillaReg as a .w regardless -- Example: R1.w = R1.w & (-0x8UL); -- JMP_(*R1.p); @@ -1201,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 @@ -1222,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) @@ -1410,7 +1498,6 @@ doubleToWord64 :: Rational -> CmmLit doubleToWord64 r = CmmInt (toInteger (castDoubleToWord64 (fromRational r))) W64 - -- --------------------------------------------------------------------------- -- Utils @@ -1492,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 @@ -21,13 +21,16 @@ 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.Session +import GHC.Driver.DynFlags +import GHC.Platform ( platformArch, Arch(..) ) import GHC.Utils.Error import GHC.Data.FastString import GHC.Utils.Outputable @@ -43,9 +46,11 @@ -- | 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 @@ -81,38 +86,42 @@ 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 header + renderLlvm (llvmHeader cfg) (llvmHeader cfg) ghcInternalFunctions cmmMetaLlvmPrelude -- Procedures - a <- Stream.consume cmm_stream liftIO llvmGroupLlvmGens + a <- Stream.consume cmm_stream (GHC.CmmToLlvm.Base.liftUDSMT) (llvmGroupLlvmGens) -- Declare aliases for forward references - renderLlvm . pprLlvmData cfg =<< generateExternDecls + decls <- generateExternDecls + renderLlvm (pprLlvmData cfg decls) + (pprLlvmData cfg decls) -- Postamble cmmUsedLlvmGens return a - where - header :: SDoc - header = - let target = llvmCgLlvmTarget cfg - llvmCfg = llvmCgLlvmConfig cfg - in (text "target datalayout = \"" <> text (getDataLayout llvmCfg target) <> text "\"") - $+$ (text "target triple = \"" <> text target <> text "\"") +llvmHeader :: IsDoc doc => LlvmCgConfig -> doc +llvmHeader cfg = + let target = llvmCgLlvmTarget cfg + llvmCfg = llvmCgLlvmConfig cfg + in lines_ + [ text "target datalayout = \"" <> text (getDataLayout llvmCfg target) <> text "\"" + , text "target triple = \"" <> text target <> text "\"" ] + where getDataLayout :: LlvmConfig -> String -> String getDataLayout config target = case lookup target (llvmTargets config) of @@ -121,6 +130,8 @@ text "Target:" <+> text target $$ hang (text "Available targets:") 4 (vcat $ map (text . fst) $ llvmTargets config) +{-# SPECIALIZE llvmHeader :: LlvmCgConfig -> SDoc #-} +{-# SPECIALIZE llvmHeader :: LlvmCgConfig -> HDoc #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable llvmGroupLlvmGens :: RawCmmGroup -> LlvmM () llvmGroupLlvmGens cmm = do @@ -156,10 +167,11 @@ = funInsert l ty regGlobal _ = pure () mapM_ regGlobal gs - gss' <- mapM aliasify $ gs + gss' <- mapM aliasify gs cfg <- getConfig - renderLlvm $ pprLlvmData cfg (concat gss', concat tss) + renderLlvm (pprLlvmData cfg (concat gss', concat tss)) + (pprLlvmData cfg (concat gss', concat tss)) -- | Complete LLVM code generation phase for a single top-level chunk of Cmm. cmmLlvmGen ::RawCmmDecl -> LlvmM () @@ -175,12 +187,12 @@ -- generate llvm code from cmm llvmBC <- withClearVars $ genLlvmProc fixed_cmm - -- pretty print - (docs, ivars) <- fmap unzip $ mapM pprLlvmCmmDecl llvmBC - - -- Output, note down used variables - renderLlvm (vcat docs) - mapM_ markUsedVar $ concat ivars + -- pretty print - print as we go, since we produce HDocs, we know + -- no nesting state needs to be maintained for the SDocs. + forM_ llvmBC (\decl -> do + (hdoc, sdoc) <- pprLlvmCmmDecl decl + renderLlvm (hdoc $$ empty) (sdoc $$ empty) + ) cmmLlvmGen _ = return () @@ -190,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 @@ -203,9 +215,51 @@ -- just a name on its own. Previously `null` was accepted as the -- name. Nothing -> [ MetaStr name ] + + platform <- getPlatform cfg <- getConfig - renderLlvm $ ppLlvmMetas cfg metas + 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 -- @@ -229,4 +283,7 @@ lmUsed = LMGlobal lmUsedVar (Just usedArray) if null ivars then return () - else getConfig >>= renderLlvm . flip pprLlvmData ([lmUsed], []) + else do + cfg <- getConfig + renderLlvm (pprLlvmData cfg ([lmUsed], [])) + (pprLlvmData cfg ([lmUsed], [])) 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,27 +43,31 @@ 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 ) -import GHC.Driver.Session +import GHC.Driver.DynFlags import GHC.Data.FastString import GHC.Cmm hiding ( succ ) -import GHC.Cmm.Utils (regsOverlap) +import GHC.Cmm.Utils (globalRegsOverlap) import GHC.Utils.Outputable as Outp import GHC.Platform import GHC.Types.Unique.FM 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,47 +203,52 @@ ---------------------------------- -- 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 -- all use the same real regs on X86-64 (XMM registers). -- classes = NE.groupBy sharesClass fprLive - sharesClass a b = regsOverlap platform (norm a) (norm b) -- check if mapped to overlapping registers - norm x = CmmGlobal ((fpr_ctor x) 1) -- get the first register of the family + sharesClass a b = globalRegsOverlap platform (norm a) (norm b) -- check if mapped to overlapping registers + 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 @@ -371,13 +399,13 @@ liftIO $ putDumpFileMaybe logger flag hdr fmt doc -- | Prints the given contents to the output handle -renderLlvm :: Outp.SDoc -> LlvmM () -renderLlvm sdoc = do +renderLlvm :: Outp.HDoc -> Outp.SDoc -> LlvmM () +renderLlvm hdoc sdoc = do -- Write to output ctx <- llvmCgContext <$> getConfig out <- getEnv envOutput - liftIO $ Outp.bufLeftRenderSDoc ctx out sdoc + liftIO $ Outp.bPutHDoc out ctx hdoc -- Dump, if requested dumpIfSetLlvm Opt_D_dump_llvm "LLVM Code" FormatLLVM sdoc @@ -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 @@ -428,7 +456,7 @@ let n' = fsLit n decl = LlvmFunctionDecl n' ExternallyVisible CC_Ccc ret FixedArgs (tysToParams args) Nothing - renderLlvm $ ppLlvmFunctionDecl decl + renderLlvm (ppLlvmFunctionDecl decl) (ppLlvmFunctionDecl decl) funInsert n' (LMFunction decl) -- ---------------------------------------------------------------------------- @@ -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 @@ -12,6 +11,7 @@ import GHC.Platform.Regs ( activeStgRegs ) import GHC.Llvm +import GHC.Llvm.Types import GHC.CmmToLlvm.Base import GHC.CmmToLlvm.Config import GHC.CmmToLlvm.Regs @@ -23,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 @@ -54,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) @@ -67,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 @@ -82,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) @@ -110,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, []) @@ -131,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 @@ -171,43 +186,28 @@ 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 - statement $ Store castV dstV Nothing + statement $ Store castV dstV Nothing [] genCall (PrimTarget (MO_UF_Conv _)) [_] args = panic $ "genCall: Too many arguments to MO_UF_Conv. " ++ @@ -230,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 @@ -254,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 @@ -263,12 +262,12 @@ AMO_Or -> LAO_Or AMO_Xor -> LAO_Xor retVar <- doExprW targetTy $ AtomicRMW op ptrVar nVar SyncSeqCst - statement $ Store retVar dstVar Nothing + 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 + statement $ Store v1 dstV Nothing [] genCall (PrimTarget (MO_Cmpxchg _width)) [dst] [addr, old, new] = runStmtsDecls $ do @@ -278,21 +277,21 @@ 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 + 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 ptrExpr = Cast LM_Inttoptr addrVar ptrTy ptrVar <- doExprW ptrTy ptrExpr resVar <- doExprW (getVarType valVar) (AtomicRMW LAO_Xchg ptrVar valVar SyncSeqCst) - statement $ Store resVar dstV Nothing + statement $ Store resVar dstV Nothing [] genCall (PrimTarget (MO_AtomicWrite _width mem_ord)) [] [addr, val] = runStmtsDecls $ do addrVar <- exprToVarW addr @@ -351,10 +350,10 @@ 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) - statement $ Store retL dstRegL Nothing - statement $ Store retH dstRegH Nothing + (dstRegL, _dstL_ty) <- getCmmRegW (CmmLocal dstL) + (dstRegH, _dstH_ty) <- getCmmRegW (CmmLocal dstH) + statement $ Store retL dstRegL Nothing [] + statement $ Store retH dstRegH Nothing [] genCall (PrimTarget (MO_S_Mul2 w)) [dstC, dstH, dstL] [lhs, rhs] = runStmtsDecls $ do let width = widthToLlvmInt w @@ -382,12 +381,12 @@ 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) - statement $ Store retL dstRegL Nothing - statement $ Store retH dstRegH Nothing - statement $ Store retC dstRegC Nothing + (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 [] -- MO_U_QuotRem2 is another case we handle by widening the registers to double -- the width and use normal LLVM instructions (similarly to the MO_U_Mul2). The @@ -419,10 +418,10 @@ 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) - statement $ Store retDiv dstRegQ Nothing - statement $ Store retRem dstRegR Nothing + (dstRegQ, _dstQ_ty) <- lift $ getCmmReg (CmmLocal dstQ) + (dstRegR, _dstR_ty) <- lift $ getCmmReg (CmmLocal dstR) + statement $ Store retDiv dstRegQ Nothing [] + statement $ Store retRem dstRegR Nothing [] -- Handle the MO_{Add,Sub}IntC separately. LLVM versions return a record from -- which we need to extract the actual values. @@ -444,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 @@ -453,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" @@ -506,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 @@ -526,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 @@ -559,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. @@ -568,10 +589,10 @@ -- 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) - let storeV = Store value dstRegV Nothing - storeO = Store overflow dstRegO Nothing + (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) genCallWithOverflow _ _ _ _ = panic "genCallExtract: wrong ForeignTarget or number of arguments" @@ -618,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 @@ -789,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 @@ -1008,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 @@ -1051,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 @@ -1088,26 +1122,24 @@ -- 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 LMPointer _ | getVarType vval == llvmWord platform -> do (v, s1) <- doExpr ty $ Cast LM_Inttoptr vval ty - let s2 = Store v vreg Nothing + let s2 = Store v vreg Nothing [] return (stmts `snocOL` s1 `snocOL` s2, top2) LMVector _ _ -> do (v, s1) <- doExpr ty $ Cast LM_Bitcast vval ty - let s2 = mkStore v vreg NaturallyAligned + let s2 = mkStore v vreg NaturallyAligned [] return (stmts `snocOL` s1 `snocOL` s2, top2) _ -> do - let s1 = Store vval vreg Nothing + let s1 = Store vval vreg Nothing [] return (stmts `snocOL` s1, top2) @@ -1143,12 +1175,12 @@ -- | CmmStore operation -- This is a special case for storing to a global register pointer -- offset such as I32[Sp+8]. -genStore_fast :: CmmExpr -> GlobalReg -> Int -> CmmExpr -> AlignmentSpec +genStore_fast :: CmmExpr -> GlobalRegUse -> Int -> CmmExpr -> AlignmentSpec -> LlvmM StmtData genStore_fast addr r n val alignment = do platform <- getPlatform (gv, grt, s1) <- getCmmRegVal (CmmGlobal r) - meta <- getTBAARegMeta 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 @@ -1158,7 +1190,7 @@ case pLower grt == getVarType vval of -- were fine True -> do - let s3 = MetaStmt meta $ mkStore vval ptr alignment + let s3 = mkStore vval ptr alignment meta return (stmts `appOL` s1 `snocOL` s2 `snocOL` s3, top) @@ -1166,7 +1198,7 @@ False -> do let ty = (pLift . getVarType) vval (ptr', s3) <- doExpr ty $ Cast LM_Bitcast ptr ty - let s4 = MetaStmt meta $ mkStore vval ptr' alignment + let s4 = mkStore vval ptr' alignment meta return (stmts `appOL` s1 `snocOL` s2 `snocOL` s3 `snocOL` s4, top) @@ -1189,17 +1221,17 @@ -- sometimes we need to cast an int to a pointer before storing LMPointer ty@(LMPointer _) | getVarType vval == llvmWord platform -> do (v, s1) <- doExpr ty $ Cast LM_Inttoptr vval ty - let s2 = MetaStmt meta $ mkStore v vaddr alignment + let s2 = mkStore v vaddr alignment meta return (stmts `snocOL` s1 `snocOL` s2, top1 ++ top2) LMPointer _ -> do - let s1 = MetaStmt meta $ mkStore vval vaddr alignment + let s1 = mkStore vval vaddr alignment meta return (stmts `snocOL` s1, top1 ++ top2) i@(LMInt _) | i == llvmWord platform -> do let vty = pLift $ getVarType vval (vptr, s1) <- doExpr vty $ Cast LM_Inttoptr vaddr vty - let s2 = MetaStmt meta $ mkStore vval vptr alignment + let s2 = mkStore vval vptr alignment meta return (stmts `snocOL` s1 `snocOL` s2, top1 ++ top2) other -> @@ -1209,9 +1241,9 @@ text "Size of var:" <+> ppr (llvmWidthInBits platform other) $$ text "Var:" <+> ppVar cfg vaddr) -mkStore :: LlvmVar -> LlvmVar -> AlignmentSpec -> LlvmStatement -mkStore vval vptr alignment = - Store vval vptr align +mkStore :: LlvmVar -> LlvmVar -> AlignmentSpec -> [MetaAnnot] -> LlvmStatement +mkStore vval vptr alignment metas = + Store vval vptr align metas where ty = pLower (getVarType vptr) align = case alignment of @@ -1316,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 -- @@ -1388,8 +1437,7 @@ -> genMachOp opt op exprs CmmRegOff r i - -> do platform <- getPlatform - exprToVar $ expandCmmReg platform (r, i) + -> exprToVar $ expandCmmReg (r, i) CmmStackSlot _ _ -> panic "exprToVar: CmmStackSlot not supported!" @@ -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,6 +1526,11 @@ MO_F_Sub _ -> panicOp MO_F_Mul _ -> panicOp MO_F_Quot _ -> panicOp + MO_F_Min _ -> panicOp + MO_F_Max _ -> panicOp + + MO_FMA _ _ _ -> panicOp + MO_F_Eq _ -> panicOp MO_F_Ne _ -> panicOp MO_F_Ge _ -> panicOp @@ -1491,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 @@ -1554,7 +1620,7 @@ -- | Handle CmmMachOp expressions -- This is a specialised method that handles Global register manipulations like -- 'Sp - 16', using the getelementptr instruction. -genMachOp_fast :: EOption -> MachOp -> GlobalReg -> Int -> [CmmExpr] +genMachOp_fast :: EOption -> MachOp -> GlobalRegUse -> Int -> [CmmExpr] -> LlvmM ExprData genMachOp_fast opt op r n e = do (gv, grt, s1) <- getCmmRegVal (CmmGlobal r) @@ -1653,6 +1719,8 @@ MO_F_Mul _ -> genBinMach LM_MO_FMul MO_F_Quot _ -> genBinMach LM_MO_FDiv + MO_FMA _ _ _ -> panicOp + MO_And _ -> genBinMach LM_MO_And MO_Or _ -> genBinMach LM_MO_Or MO_Xor _ -> genBinMach LM_MO_Xor @@ -1664,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 @@ -1679,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 @@ -1751,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. @@ -1783,13 +1872,87 @@ pprPanic "isSMulOK: Not bit type! " $ lparen <> ppr word <> rparen - panicOp = panic $ "LLVM.CodeGen.genMachOp_slow: unary op encountered" + panicOp = panic $ "LLVM.CodeGen.genMachOp_slow: non-binary op encountered " ++ "with two arguments! (" ++ show op ++ ")" --- More than two expression, invalid! -genMachOp_slow _ _ _ = panic "genMachOp: More than 2 expressions in MachOp!" +genMachOp_slow _opt op [x, y, z] = do + let + panicOp = panic $ "LLVM.CodeGen.genMachOp_slow: non-ternary op encountered " + ++ "with three arguments! (" ++ show op ++ ")" + case op of + MO_FMA var lg width -> + case var of + -- LLVM only has the fmadd variant. + FMAdd -> genFmaOp x y z + -- Other fused multiply-add operations are implemented in terms of fmadd + -- This is sound: it does not lose any precision. + 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 + vx <- exprToVarW x + vy <- exprToVarW y + vz <- exprToVarW z + let tx = getVarType vx + ty = getVarType vy + tz = getVarType vz + Panic.massertPpr + (tx == ty && tx == tz) + (vcat [ text "fma: mismatched arg types" + , ppLlvmType tx, ppLlvmType ty, ppLlvmType tz ]) + let fname = case tx of + LMFloat -> fsLit "llvm.fma.f32" + LMDouble -> fsLit "llvm.fma.f64" + 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] + -- | Handle CmmLoad expression. genLoad :: Atomic -> CmmExpr -> CmmType -> AlignmentSpec -> LlvmM ExprData @@ -1822,12 +1985,12 @@ -- | Handle CmmLoad expression. -- This is a special case for loading from a global register pointer -- offset such as I32[Sp+8]. -genLoad_fast :: Atomic -> CmmExpr -> GlobalReg -> Int -> CmmType +genLoad_fast :: Atomic -> CmmExpr -> GlobalRegUse -> Int -> CmmType -> AlignmentSpec -> LlvmM ExprData genLoad_fast atomic e r n ty align = do platform <- getPlatform (gv, grt, s1) <- getCmmRegVal (CmmGlobal r) - meta <- getTBAARegMeta 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 @@ -1905,42 +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 onStack <- checkStackReg g +getCmmReg (CmmGlobal (GlobalRegUse reg _reg_ty)) + = do onStack <- checkStackReg reg platform <- getPlatform - if onStack - then return (lmGlobalRegVar platform g) - 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 + CmmGlobal gu@(GlobalRegUse g _) -> do onStack <- checkStackReg g platform <- getPlatform - if onStack then loadFromStack else do - let r = lmGlobalRegArg platform 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) @@ -1966,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, []) @@ -2046,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] @@ -2055,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 -> @@ -2064,24 +2252,38 @@ let (newv, stmts) = allocReg reg varInsert un (pLower $ getVarType newv) return stmts - CmmGlobal 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 @@ -2107,12 +2309,16 @@ let allRegs = activeStgRegs platform loads <- forM allRegs $ \r -> if -- load live registers - | r `elem` alwaysLive -> loadExpr r - | r `elem` live -> loadExpr 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 @@ -2122,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 @@ -2152,9 +2358,9 @@ -- | Expand CmmRegOff -expandCmmReg :: Platform -> (CmmReg, Int) -> CmmExpr -expandCmmReg platform (reg, off) - = let width = typeWidth (cmmRegType platform reg) +expandCmmReg :: (CmmReg, Int) -> CmmExpr +expandCmmReg (reg, off) + = let width = typeWidth (cmmRegType reg) voff = CmmLit $ CmmInt (fromIntegral off) width in CmmMachOp (MO_Add width) [CmmReg reg, voff] @@ -2185,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] @@ -2233,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/Mangler.hs b/GHC/CmmToLlvm/Mangler.hs --- a/GHC/CmmToLlvm/Mangler.hs +++ b/GHC/CmmToLlvm/Mangler.hs @@ -38,7 +38,7 @@ -- | These are the rewrites that the mangler will perform rewrites :: [Rewrite] -rewrites = [rewriteSymType, rewriteAVX, rewriteCall] +rewrites = [rewriteSymType, rewriteAVX, rewriteCall, rewriteJump] type Rewrite = Platform -> B.ByteString -> Maybe B.ByteString @@ -121,6 +121,29 @@ replaceOnce (B.pack call) (B.pack ("la\t" ++ reg ++ ",")) l where removePlt = replaceOnce (B.pack "@plt") (B.pack "") + appendInsn i = (`B.append` B.pack ("\n\t" ++ i)) + +-- | This rewrites bl and b jump inst to avoid creating PLT entries for +-- functions on loongarch64, because there is no separate call instruction +-- for function calls in loongarch64. Also, this replacement will load +-- the function address from the GOT, which is resolved to point to the +-- real address of the function. +rewriteJump :: Rewrite +rewriteJump platform l + | not isLoongArch64 = Nothing + | isBL l = Just $ replaceJump "bl" "$ra" "$ra" l + | isB l = Just $ replaceJump "b" "$zero" "$t0" l + | otherwise = Nothing + where + isLoongArch64 = platformArch platform == ArchLoongArch64 + isBL = B.isPrefixOf (B.pack "bl\t") + isB = B.isPrefixOf (B.pack "b\t") + + replaceJump jump rd rj l = + appendInsn ("jirl" ++ "\t" ++ rd ++ ", " ++ rj ++ ", 0") $ removeBracket $ + replaceOnce (B.pack (jump ++ "\t%plt(")) (B.pack ("la\t" ++ rj ++ ", ")) l + where + removeBracket = replaceOnce (B.pack ")") (B.pack "") appendInsn i = (`B.append` B.pack ("\n\t" ++ i)) -- | @replaceOnce match replace bs@ replaces the first occurrence of the diff --git a/GHC/CmmToLlvm/Ppr.hs b/GHC/CmmToLlvm/Ppr.hs --- a/GHC/CmmToLlvm/Ppr.hs +++ b/GHC/CmmToLlvm/Ppr.hs @@ -26,22 +26,28 @@ -- -- | Pretty print LLVM data code -pprLlvmData :: LlvmCgConfig -> LlvmData -> SDoc +pprLlvmData :: IsDoc doc => LlvmCgConfig -> LlvmData -> doc pprLlvmData cfg (globals, types) = - let ppLlvmTys (LMAlias a) = ppLlvmAlias a + let ppLlvmTys (LMAlias a) = line $ ppLlvmAlias a ppLlvmTys (LMFunction f) = ppLlvmFunctionDecl f ppLlvmTys _other = empty types' = vcat $ map ppLlvmTys types globals' = ppLlvmGlobals cfg globals - in types' $+$ globals' + in types' $$ globals' +{-# SPECIALIZE pprLlvmData :: LlvmCgConfig -> LlvmData -> SDoc #-} +{-# SPECIALIZE pprLlvmData :: LlvmCgConfig -> LlvmData -> HDoc #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable -- | Pretty print LLVM code -pprLlvmCmmDecl :: LlvmCmmDecl -> LlvmM (SDoc, [LlvmVar]) +-- The HDoc we return is used to produce the final LLVM file, with the +-- SDoc being returned alongside for use when @Opt_D_dump_llvm@ is set +-- as we can't (currently) dump HDocs. +pprLlvmCmmDecl :: LlvmCmmDecl -> LlvmM (HDoc, SDoc) pprLlvmCmmDecl (CmmData _ lmdata) = do opts <- getConfig - return (vcat $ map (pprLlvmData opts) lmdata, []) + return ( vcat $ map (pprLlvmData opts) lmdata + , vcat $ map (pprLlvmData opts) lmdata) pprLlvmCmmDecl (CmmProc mb_info entry_lbl live (ListGraph blks)) = do let lbl = case mb_info of @@ -92,7 +98,8 @@ (Just $ LMBitc (LMStaticPointer defVar) i8Ptr) - return (ppLlvmGlobal cfg alias $+$ ppLlvmFunction cfg fun', []) + return ( vcat [line $ ppLlvmGlobal cfg alias, ppLlvmFunction cfg fun'] + , vcat [line $ ppLlvmGlobal cfg alias, ppLlvmFunction cfg fun']) -- | The section we are putting info tables and their entry code into, should diff --git a/GHC/CmmToLlvm/Regs.hs b/GHC/CmmToLlvm/Regs.hs --- a/GHC/CmmToLlvm/Regs.hs +++ b/GHC/CmmToLlvm/Regs.hs @@ -14,39 +14,41 @@ 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 Hp -> ptrGlobal $ "Hp" ++ suf - VanillaReg 1 _ -> wordGlobal $ "R1" ++ suf - VanillaReg 2 _ -> wordGlobal $ "R2" ++ suf - VanillaReg 3 _ -> wordGlobal $ "R3" ++ suf - VanillaReg 4 _ -> wordGlobal $ "R4" ++ suf - VanillaReg 5 _ -> wordGlobal $ "R5" ++ suf - VanillaReg 6 _ -> wordGlobal $ "R6" ++ suf - VanillaReg 7 _ -> wordGlobal $ "R7" ++ suf - VanillaReg 8 _ -> wordGlobal $ "R8" ++ suf - VanillaReg 9 _ -> wordGlobal $ "R9" ++ suf - VanillaReg 10 _ -> wordGlobal $ "R10" ++ suf + VanillaReg 1 -> wordGlobal $ "R1" ++ suf + VanillaReg 2 -> wordGlobal $ "R2" ++ suf + VanillaReg 3 -> wordGlobal $ "R3" ++ suf + VanillaReg 4 -> wordGlobal $ "R4" ++ suf + VanillaReg 5 -> wordGlobal $ "R5" ++ suf + VanillaReg 6 -> wordGlobal $ "R6" ++ suf + VanillaReg 7 -> wordGlobal $ "R7" ++ suf + VanillaReg 8 -> wordGlobal $ "R8" ++ suf + VanillaReg 9 -> wordGlobal $ "R9" ++ suf + VanillaReg 10 -> wordGlobal $ "R10" ++ suf SpLim -> wordGlobal $ "SpLim" ++ suf FloatReg 1 -> floatGlobal $ "F1" ++ suf FloatReg 2 -> floatGlobal $ "F2" ++ 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)] @@ -129,8 +144,8 @@ -- | Get the correct TBAA metadata information for this register type getTBAA :: GlobalReg -> Unique -getTBAA BaseReg = baseN -getTBAA Sp = stackN -getTBAA Hp = heapN -getTBAA (VanillaReg _ _) = rxN -getTBAA _ = topN +getTBAA BaseReg = baseN +getTBAA Sp = stackN +getTBAA Hp = heapN +getTBAA (VanillaReg _) = rxN +getTBAA _ = topN 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) @@ -155,7 +159,7 @@ -- f_1 x_2 = let f_3 x_4 = x_4 + 1 -- in f_3 (x_2 - 2) -- @ --- But see Note [Shadowing] below. +-- But see Note [Shadowing in Core] below. -- -- 3. The resulting syntax tree undergoes type checking (which also deals with instantiating -- type class arguments) to yield a 'GHC.Hs.Expr.HsExpr' type that has 'GHC.Types.Id.Id' as it's names. @@ -292,7 +296,7 @@ -- This instance is a bit shady. It can only be used to compare AltCons for -- a single type constructor. Fortunately, it seems quite unlikely that we'll -- ever need to compare AltCons for different type constructors. --- The instance adheres to the order described in [Core case invariants] +-- The instance adheres to the order described in Note [Case expression invariants] instance Ord AltCon where compare (DataAlt con1) (DataAlt con2) = assert (dataConTyCon con1 == dataConTyCon con2) $ @@ -312,27 +316,18 @@ | Rec [(b, (Expr b))] deriving Data -{- -Note [Shadowing] -~~~~~~~~~~~~~~~~ -While various passes attempt to rename on-the-fly in a manner that -avoids "shadowing" (thereby simplifying downstream optimizations), -neither the simplifier nor any other pass GUARANTEES that shadowing is -avoided. Thus, all passes SHOULD work fine even in the presence of -arbitrary shadowing in their inputs. - -In particular, scrutinee variables `x` in expressions of the form -`Case e x t` are often renamed to variables with a prefix -"wild_". These "wild" variables may appear in the body of the -case-expression, and further, may be shadowed within the body. - -So the Unique in a Var is not really unique at all. Still, it's very -useful to give a constant-time equality/ordering for Vars, and to give -a key that can be used to make sets of Vars (VarSet), or mappings from -Vars to other things (VarEnv). Moreover, if you do want to eliminate -shadowing, you can give a new Unique to an Id without changing its -printable name, which makes debugging easier. +-- | 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] ~~~~~~~~~~~~~~~~~~~~~~~~~~~ Literal alternatives (LitAlt lit) are always for *un-lifted* literals. @@ -364,41 +359,73 @@ Here 'c' is a CoVar, which is lambda-bound, but it /occurs/ in a Coercion, (sym c). +Note [Shadowing in Core] +~~~~~~~~~~~~~~~~~~~~~~~~ +You might wonder if there is an invariant that a Core expression has no +"shadowing". For example, is this illegal? + \x. \x. blah -- x is shadowed +Answer; no! Core does /not/ have a no-shadowing invariant. + +Neither the simplifier nor any other pass GUARANTEES that shadowing is +avoided. Thus, all passes SHOULD work fine even in the presence of +arbitrary shadowing in their inputs. + +So the Unique in a Var is not really unique at all. Still, it's very +useful to give a constant-time equality/ordering for Vars, and to give +a key that can be used to make sets of Vars (VarSet), or mappings from +Vars to other things (VarEnv). Moreover, if you do want to eliminate +shadowing, you can give a new Unique to an Id without changing its +printable name, which makes debugging easier. + +It would in many ways be easier to have a no-shadowing invariant. And the +Simplifier does its best to clone variables that are shadowed. But it is +extremely difficult to GUARANTEE it: + +* We use `GHC.Types.Id.mkTemplateLocal` to make up local binders, with uniques + that are locally-unique (enough for the purpose) but not globally unique. + It is convenient not to have to plumb a unique supply to these functions. + +* It is very difficult for the Simplifier to gurantee a no-shadowing result. + See Note [Shadowing in the Simplifier] in GHC.Core.Opt.Simplify.Iteration. + +* See Note [Shadowing in CSE] in GHC.Core.Opt.CSE + +* See Note [Shadowing in SpecConstr] in GHC.Core.Opt.SpecContr + Note [Core letrec invariant] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The Core letrec invariant: - The right hand sides of all - /top-level/ or /recursive/ - bindings must be of lifted type - - There is one exception to this rule, top-level @let@s are - allowed to bind primitive string literals: see - Note [Core top-level string literals]. + The right hand sides of all /top-level/ or /recursive/ + bindings must be of lifted type See "Type#type_classification" in GHC.Core.Type -for the meaning of "lifted" vs. "unlifted"). - -For the non-top-level, non-recursive case see Note [Core let-can-float invariant]. +for the meaning of "lifted" vs. "unlifted". -Note [Compilation plan for top-level string literals] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Here is a summary on how top-level string literals are handled by various -parts of the compilation pipeline. +For the non-top-level, non-recursive case see +Note [Core let-can-float invariant]. -* In the source language, there is no way to bind a primitive string literal - at the top level. +At top level, however, there are two exceptions to this rule: -* In Core, we have a special rule that permits top-level Addr# bindings. See - Note [Core top-level string literals]. Core-to-core passes may introduce - new top-level string literals. +(TL1) A top-level binding is allowed to bind primitive string literal, + (which is unlifted). See Note [Core top-level string literals]. -* In STG, top-level string literals are explicitly represented in the syntax - tree. +(TL2) In Core, we generate a top-level binding for every non-newtype data +constructor worker or wrapper + e.g. data T = MkT Int + we generate + MkT :: Int -> T + MkT = \x. MkT x + (This binding looks recursive, but isn't; it defines a top-level, curried + function whose body just allocates and returns the data constructor.) -* A top-level string literal may end up exported from a module. In this case, - in the object file, the content of the exported literal is given a label with - the _bytes suffix. + 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 + S1 :: S -- A top-level unlifted binding + S1 = S1 + We allow this top-level unlifted binding to exist. Note [Core let-can-float invariant] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -428,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 @@ -452,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, @@ -496,6 +520,45 @@ in the object file, the content of the exported literal is given a label with the _bytes suffix. +Note [NON-BOTTOM-DICTS invariant] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +It is a global invariant (not checkable by Lint) that + + every non-newtype dictionary-typed expression is non-bottom. + +These conditions are captured by GHC.Core.Type.isTerminatingType. + +How are we so sure about this? Dictionaries are built by GHC in only two ways: + +* A dictionary function (DFun), arising from an instance declaration. + DFuns do no computation: they always return a data constructor immediately. + See DFunUnfolding in GHC.Core. So the result of a call to a DFun is always + non-bottom. + + Exception: newtype dictionaries. + + Plus: see the Very Nasty Wrinkle in Note [Speculative evaluation] + in GHC.CoreToStg.Prep + +* A superclass selection from some other dictionary. This is harder to guarantee: + see Note [Recursive superclasses] and Note [Solving superclass constraints] + in GHC.Tc.TyCl.Instance. + +A bad Core-to-Core pass could invalidate this reasoning, but that's too bad. +It's still an invariant of Core programs generated by GHC from Haskell, and +Core-to-Core passes maintain it. + +Why is it useful to know that dictionaries are non-bottom? + +1. It justifies the use of `-XDictsStrict`; + see `GHC.Core.Types.Demand.strictifyDictDmd` + +2. It means that (eq_sel d) is ok-for-speculation and thus + case (eq_sel d) of _ -> blah + can be discarded by the Simplifier. See these Notes: + Note [exprOkForSpeculation and type classes] in GHC.Core.Utils + Note[Speculative evaluation] in GHC.CoreToStg.Prep + Note [Case expression invariants] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Case expressions are one of the more complicated elements of the Core @@ -584,18 +647,14 @@ case (df @Int) of (co :: a ~# b) -> blah Which is very exotic, and I think never encountered; but see Note [Equality superclasses in quantified constraints] - in GHC.Tc.Solver.Canonical - -Note [Core case invariants] -~~~~~~~~~~~~~~~~~~~~~~~~~~~ -See Note [Case expression invariants] + in GHC.Tc.Solver.Dict Note [Representation polymorphism invariants] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 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 @@ -610,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 @@ -631,38 +683,32 @@ 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. See Note [Representation polymorphism checking] in GHC.Tc.Utils.Concrete for an overview of how we enforce these invariants in the typechecker. -Note [Core let goal] -~~~~~~~~~~~~~~~~~~~~ -* The simplifier tries to ensure that if the RHS of a let is a constructor - application, its arguments are trivial, so that the constructor can be - inlined vigorously. - Note [Empty case alternatives] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The alternatives of a case expression should be exhaustive. But @@ -707,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 @@ -984,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 @@ -1052,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 @@ -1072,6 +1187,10 @@ n <- get bh return $ NotOrphan n +instance NFData IsOrphan where + rnf IsOrphan = () + rnf (NotOrphan n) = rnf n + {- Note [Orphans] ~~~~~~~~~~~~~~ @@ -1107,7 +1226,7 @@ Orphan-hood is computed * For class instances: - when we make a ClsInst in GHC.Core.InstEnv.mkLocalInstance + when we make a ClsInst in GHC.Core.InstEnv.mkLocalClsInst (because it is needed during instance lookup) See Note [When exactly is an instance decl an orphan?] in GHC.Core.InstEnv @@ -1222,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 @@ -1242,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 @@ -1468,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 @@ -1511,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 @@ -1596,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 @@ -1610,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 @@ -1856,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)) @@ -1995,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] @@ -2071,6 +2235,17 @@ 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 -- being applied. Looking through casts and ticks to find it. collectFunSimple :: Expr b -> Expr b collectFunSimple expr @@ -2101,7 +2276,7 @@ stripNArgs n (App f _) = stripNArgs (n - 1) f stripNArgs _ _ = Nothing --- | Like @collectArgs@, but also collects looks through floatable +-- | Like @collectArgs@, but also looks through floatable -- ticks if it means that we can find more arguments. collectArgsTicks :: (CoreTickish -> Bool) -> Expr b -> (Expr b, [Arg b], [CoreTickish]) 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 @@ -8,7 +8,7 @@ module GHC.Core.Class ( Class, ClassOpItem, - ClassATItem(..), ATValidityInfo(..), + ClassATItem(..), TyFamEqnValidityInfo(..), ClassMinimalDef, DefMethInfo, pprDefMethInfo, @@ -17,8 +17,13 @@ mkClass, mkAbstractClass, classTyVars, classArity, classKey, className, classATs, classATItems, classTyCon, classMethods, classOpItems, classBigSig, classExtraBigSig, classTvsFds, classSCTheta, - classAllSelIds, classSCSelId, classSCSelIds, classMinimalDef, classHasFds, - isAbstractClass, + classHasSCs, classAllSelIds, classSCSelId, classSCSelIds, classMinimalDef, + classHasFds, + + -- Predicates + -- NB: other isXXlass predicates are defined in GHC.Core.Predicate + -- to avoid module loops + isAbstractClass ) where import GHC.Prelude @@ -26,16 +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 @@ -76,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) @@ -96,22 +98,46 @@ data ClassATItem = ATI TyCon -- See Note [Associated type tyvar names] - (Maybe (Type, ATValidityInfo)) - -- Default associated type (if any) from this template - -- Note [Associated type defaults] + (Maybe (Type, TyFamEqnValidityInfo)) + -- ^ Default associated type (if any) from this template. + -- + -- As per Note [Associated type defaults], the Type has been renamed + -- to use the class tyvars, while the 'TyFamEqnValidityInfo' uses + -- the original user-written type variables. --- | Information about an associated type family default implementation. This --- is used solely for validity checking. +-- | Information about a type family equation, used for validity checking +-- of closed type family equations and associated type family default equations. +-- +-- This type exists to delay validity-checking after typechecking type declaration +-- groups, to avoid cyclic evaluation inside the typechecking knot. +-- -- See @Note [Type-checking default assoc decls]@ in "GHC.Tc.TyCl". -data ATValidityInfo - = NoATVI -- Used for associated type families that are imported - -- from another module, for which we don't need to - -- perform any validity checking. +data TyFamEqnValidityInfo + -- | Used for equations which don't need any validity checking, + -- for example equations imported from another module. + = NoVI - | ATVI SrcSpan [Type] -- Used for locally defined associated type families. - -- The [Type] are the LHS patterns. + -- | Information necessary for validity checking of a type family equation. + | VI + { vi_loc :: SrcSpan + , vi_qtvs :: [TcTyVar] + -- ^ LHS quantified type variables + , vi_non_user_tvs :: TyVarSet + -- ^ non-user-written type variables (for error message reporting) + -- + -- Example: with -XPolyKinds, typechecking @type instance forall a. F = ()@ + -- introduces the kind variable @k@ for the kind of @a@. See #23734. + , vi_pats :: [Type] + -- ^ LHS patterns + , vi_rhs :: Type + -- ^ RHS of the equation + -- + -- NB: for associated type family default declarations, this is the RHS + -- *before* applying the substitution from + -- 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 @@ -166,10 +192,15 @@ * HOWEVER, in the internal ClassATItem we rename the RHS to match the tyConTyVars of the family TyCon. So in the example above we'd get a ClassATItem of - ATI F ((x,a) -> b) - So the tyConTyVars of the family TyCon bind the free vars of - the default Type rhs + ATI F (Just ((x,a) -> b, validity_info) + + That is, the type stored in the first component of the pair has been + renamed to use the class type variables. On the other hand, the + TyFamEqnValidityInfo, used for validity checking of the type family equation + (considered as a free-standing equation) uses the original types, e.g. + involving the type variables 'p', 'q', 'r'. + The @mkClass@ function fills in the indirect superclasses. The SrcSpan is for the entire original declaration. @@ -294,6 +325,9 @@ classSCTheta (Class { classBody = ConcreteClass { cls_sc_theta = theta_stuff }}) = theta_stuff classSCTheta _ = [] + +classHasSCs :: Class -> Bool +classHasSCs cls = not (null (classSCTheta cls)) classTvsFds :: Class -> ([TyVar], [FunDep TyVar]) classTvsFds c = (classTyVars c, classFunDeps c) diff --git a/GHC/Core/Coercion.hs b/GHC/Core/Coercion.hs --- a/GHC/Core/Coercion.hs +++ b/GHC/Core/Coercion.hs @@ -24,2759 +24,2784 @@ -- ** Functions over coercions coVarRType, coVarLType, coVarTypes, - coVarKind, coVarKindsTypesRole, coVarRole, - coercionType, mkCoercionType, - coercionKind, coercionLKind, coercionRKind,coercionKinds, - coercionRole, coercionKindRole, - - -- ** Constructing coercions - mkGReflCo, mkReflCo, mkRepReflCo, mkNomReflCo, - mkCoVarCo, mkCoVarCos, - mkAxInstCo, mkUnbranchedAxInstCo, - mkAxInstRHS, mkUnbranchedAxInstRHS, - mkAxInstLHS, mkUnbranchedAxInstLHS, - mkPiCo, mkPiCos, mkCoCast, - mkSymCo, mkTransCo, - mkSelCo, getNthFun, getNthFromType, mkLRCo, - mkInstCo, mkAppCo, mkAppCos, mkTyConAppCo, - mkFunCo1, mkFunCo2, mkFunCoNoFTF, mkFunResCo, - mkNakedFunCo1, mkNakedFunCo2, - mkForAllCo, mkForAllCos, mkHomoForAllCos, - mkPhantomCo, - mkHoleCo, mkUnivCo, mkSubCo, - mkAxiomInstCo, mkProofIrrelCo, - downgradeRole, mkAxiomRuleCo, - mkGReflRightCo, mkGReflLeftCo, mkCoherenceLeftCo, mkCoherenceRightCo, - mkKindCo, - castCoercionKind, castCoercionKind1, castCoercionKind2, - - mkPrimEqPred, mkReprPrimEqPred, mkPrimEqPredRole, - mkHeteroPrimEqPred, mkHeteroReprPrimEqPred, - - -- ** Decomposition - instNewTyCon_maybe, - - NormaliseStepper, NormaliseStepResult(..), composeSteppers, unwrapNewTypeStepper, - topNormaliseNewType_maybe, topNormaliseTypeX, - - decomposeCo, decomposeFunCo, decomposePiCos, getCoVar_maybe, - splitAppCo_maybe, - splitFunCo_maybe, - splitForAllCo_maybe, - splitForAllCo_ty_maybe, splitForAllCo_co_maybe, - - tyConRole, tyConRolesX, tyConRolesRepresentational, setNominalRole_maybe, - tyConRoleListX, tyConRoleListRepresentational, funRole, - pickLR, - - isGReflCo, isReflCo, isReflCo_maybe, isGReflCo_maybe, isReflexiveCo, isReflexiveCo_maybe, - isReflCoVar_maybe, isGReflMCo, mkGReflLeftMCo, mkGReflRightMCo, - mkCoherenceRightMCo, - - coToMCo, mkTransMCo, mkTransMCoL, mkTransMCoR, mkCastTyMCo, mkSymMCo, - mkHomoForAllMCo, mkFunResMCo, mkPiMCos, - isReflMCo, checkReflexiveMCo, - - -- ** Coercion variables - mkCoVar, isCoVar, coVarName, setCoVarName, setCoVarUnique, - - -- ** Free variables - tyCoVarsOfCo, tyCoVarsOfCos, coVarsOfCo, - tyCoFVsOfCo, tyCoFVsOfCos, tyCoVarsOfCoDSet, - coercionSize, anyFreeVarsOfCo, - - -- ** Substitution - CvSubstEnv, emptyCvSubstEnv, - lookupCoVar, - substCo, substCos, substCoVar, substCoVars, substCoWith, - substCoVarBndr, - extendTvSubstAndInScope, getCvSubstEnv, - - -- ** Lifting - liftCoSubst, liftCoSubstTyVar, liftCoSubstWith, liftCoSubstWithEx, - emptyLiftingContext, extendLiftingContext, extendLiftingContextAndInScope, - liftCoSubstVarBndrUsing, isMappedByLC, - - mkSubstLiftingContext, zapLiftingContext, - substForAllCoBndrUsingLC, lcSubst, lcInScopeSet, - - LiftCoEnv, LiftingContext(..), liftEnvSubstLeft, liftEnvSubstRight, - substRightCo, substLeftCo, swapLiftCoEnv, lcSubstLeft, lcSubstRight, - - -- ** Comparison - eqCoercion, eqCoercionX, - - -- ** Forcing evaluation of coercions - seqCo, - - -- * Pretty-printing - pprCo, pprParendCo, - pprCoAxiom, pprCoAxBranch, pprCoAxBranchLHS, - pprCoAxBranchUser, tidyCoAxBndrsForUser, - etaExpandCoAxBranch, - - -- * Tidying - tidyCo, tidyCos, - - -- * Other - promoteCoercion, buildCoercion, - - multToCo, mkRuntimeRepCo, - - hasCoercionHoleTy, hasCoercionHoleCo, hasThisCoercionHoleTy, - - setCoHoleType - ) where - -import {-# SOURCE #-} GHC.CoreToIface (toIfaceTyCon, tidyToIfaceTcArgs) - -import GHC.Prelude - -import GHC.Iface.Type -import GHC.Core.TyCo.Rep -import GHC.Core.TyCo.FVs -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.Type -import GHC.Core.TyCon -import GHC.Core.TyCon.RecWalk -import GHC.Core.Coercion.Axiom -import GHC.Types.Var -import GHC.Types.Var.Env -import GHC.Types.Var.Set -import GHC.Types.Name hiding ( varName ) -import GHC.Types.Basic -import GHC.Types.Unique -import GHC.Data.FastString -import GHC.Data.Pair -import GHC.Types.SrcLoc -import GHC.Builtin.Names -import GHC.Builtin.Types.Prim -import GHC.Data.List.SetOps -import GHC.Data.Maybe -import GHC.Types.Unique.FM -import GHC.Data.List.Infinite (Infinite (..)) -import qualified GHC.Data.List.Infinite as Inf - -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 - -{- -%************************************************************************ -%* * - -- The coercion arguments always *precisely* saturate - -- arity of (that branch of) the CoAxiom. If there are - -- any left over, we use AppCo. See - -- See [Coercion axioms applied to coercions] in GHC.Core.TyCo.Rep - -\subsection{Coercion variables} -%* * -%************************************************************************ --} - -coVarName :: CoVar -> Name -coVarName = varName - -setCoVarUnique :: CoVar -> Unique -> CoVar -setCoVarUnique = setVarUnique - -setCoVarName :: CoVar -> Name -> CoVar -setCoVarName = setVarName - -{- -%************************************************************************ -%* * - Pretty-printing CoAxioms -%* * -%************************************************************************ - -Defined here to avoid module loops. CoAxiom is loaded very early on. - --} - -etaExpandCoAxBranch :: CoAxBranch -> ([TyVar], [Type], Type) --- Return the (tvs,lhs,rhs) after eta-expanding, --- to the way in which the axiom was originally written --- See Note [Eta reduction for data families] in GHC.Core.Coercion.Axiom -etaExpandCoAxBranch (CoAxBranch { cab_tvs = tvs - , cab_eta_tvs = eta_tvs - , cab_lhs = lhs - , cab_rhs = rhs }) - -- ToDo: what about eta_cvs? - = (tvs ++ eta_tvs, lhs ++ eta_tys, mkAppTys rhs eta_tys) - where - eta_tys = mkTyVarTys eta_tvs - -pprCoAxiom :: CoAxiom br -> SDoc --- Used in debug-printing only -pprCoAxiom ax@(CoAxiom { co_ax_tc = tc, co_ax_branches = branches }) - = hang (text "axiom" <+> ppr ax) - 2 (braces $ vcat (map (pprCoAxBranchUser tc) (fromBranches branches))) - -pprCoAxBranchUser :: TyCon -> CoAxBranch -> SDoc --- Used when printing injectivity errors (FamInst.reportInjectivityErrors) --- and inaccessible branches (GHC.Tc.Validity.inaccessibleCoAxBranch) --- This happens in error messages: don't print the RHS of a data --- family axiom, which is meaningless to a user -pprCoAxBranchUser tc br - | isDataFamilyTyCon tc = pprCoAxBranchLHS tc br - | otherwise = pprCoAxBranch tc br - -pprCoAxBranchLHS :: TyCon -> CoAxBranch -> SDoc --- Print the family-instance equation when reporting --- a conflict between equations (FamInst.conflictInstErr) --- For type families the RHS is important; for data families not so. --- Indeed for data families the RHS is a mysterious internal --- type constructor, so we suppress it (#14179) --- See FamInstEnv Note [Family instance overlap conflicts] -pprCoAxBranchLHS = ppr_co_ax_branch pp_rhs - where - pp_rhs _ _ = empty - -pprCoAxBranch :: TyCon -> CoAxBranch -> SDoc -pprCoAxBranch = ppr_co_ax_branch ppr_rhs - where - ppr_rhs env rhs = equals <+> pprPrecTypeX env topPrec rhs - -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') - -- 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 - , ppUnless (null incomps) $ whenPprDebug $ - text "-- Incomps:" <+> vcat (map (pprCoAxBranch fam_tc) incomps) ] - ] - where - incomps = coAxBranchIncomps branch - loc = coAxBranchSpan branch - pp_loc | isGoodSrcSpan loc = text "at" <+> ppr (srcSpanStart loc) - | otherwise = text "in" <+> ppr loc - - -- Eta-expand LHS and RHS types, because sometimes data family - -- instances are eta-reduced. - -- See Note [Eta reduction for data families] in GHC.Core.Coercion.Axiom. - (ee_tvs, ee_lhs, ee_rhs) = etaExpandCoAxBranch branch - - pp_lhs = pprIfaceTypeApp topPrec (toIfaceTyCon fam_tc) - (tidyToIfaceTcArgs tidy_env fam_tc ee_lhs) - - (tidy_env, bndrs') = tidyCoAxBndrsForUser emptyTidyEnv ee_tvs - -tidyCoAxBndrsForUser :: TidyEnv -> [Var] -> (TidyEnv, [Var]) --- Tidy wildcards "_1", "_2" to "_", and do not return them --- in the list of binders to be printed --- This is so that in error messages we see --- forall a. F _ [a] _ = ... --- rather than --- forall a _1 _2. F _1 [a] _2 = ... --- --- This is a rather disgusting function --- See Note [Wildcard names] in GHC.Tc.Gen.HsType -tidyCoAxBndrsForUser init_env tcvs - = (tidy_env, reverse tidy_bndrs) - where - (tidy_env, tidy_bndrs) = foldl tidy_one (init_env, []) tcvs - - tidy_one (env@(occ_env, subst), rev_bndrs') bndr - | is_wildcard bndr = (env_wild, rev_bndrs') - | otherwise = (env', bndr' : rev_bndrs') - where - (env', bndr') = tidyVarBndr env bndr - env_wild = (occ_env, extendVarEnv subst bndr wild_bndr) - wild_bndr = setVarName bndr $ - tidyNameOcc (varName bndr) (mkTyVarOccFS (fsLit "_")) - -- Tidy the binder to "_" - - is_wildcard :: Var -> Bool - is_wildcard tv = case occNameString (getOccName tv) of - ('_' : rest) -> all isDigit rest - _ -> False - - -{- ********************************************************************* -* * - MCoercion -* * -********************************************************************* -} - -coToMCo :: Coercion -> MCoercion --- Convert a coercion to a MCoercion, --- It's not clear whether or not isReflexiveCo would be better here --- See #19815 for a bit of data and discussion on this point -coToMCo co | isReflCo co = MRefl - | otherwise = MCo co - -checkReflexiveMCo :: MCoercion -> MCoercion -checkReflexiveMCo MRefl = MRefl -checkReflexiveMCo (MCo co) | isReflexiveCo co = MRefl - | otherwise = MCo co - --- | Tests if this MCoercion is obviously generalized reflexive --- Guaranteed to work very quickly. -isGReflMCo :: MCoercion -> Bool -isGReflMCo MRefl = True -isGReflMCo (MCo co) | isGReflCo co = True -isGReflMCo _ = False - --- | Make a generalized reflexive coercion -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 - --- | Compose two MCoercions via transitivity -mkTransMCo :: MCoercion -> MCoercion -> MCoercion -mkTransMCo MRefl co2 = co2 -mkTransMCo co1 MRefl = co1 -mkTransMCo (MCo co1) (MCo co2) = MCo (mkTransCo co1 co2) - -mkTransMCoL :: MCoercion -> Coercion -> MCoercion -mkTransMCoL MRefl co2 = coToMCo co2 -mkTransMCoL (MCo co1) co2 = MCo (mkTransCo co1 co2) - -mkTransMCoR :: Coercion -> MCoercion -> MCoercion -mkTransMCoR co1 MRefl = coToMCo co1 -mkTransMCoR co1 (MCo co2) = MCo (mkTransCo co1 co2) - --- | Get the reverse of an 'MCoercion' -mkSymMCo :: MCoercion -> MCoercion -mkSymMCo MRefl = MRefl -mkSymMCo (MCo co) = MCo (mkSymCo co) - --- | Cast a type by an 'MCoercion' -mkCastTyMCo :: Type -> MCoercion -> Type -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) - -mkFunResMCo :: Id -> MCoercionR -> MCoercionR -mkFunResMCo _ MRefl = MRefl -mkFunResMCo arg_id (MCo co) = MCo (mkFunResCo Representational arg_id co) - -mkGReflLeftMCo :: Role -> Type -> MCoercionN -> Coercion -mkGReflLeftMCo r ty MRefl = mkReflCo r ty -mkGReflLeftMCo r ty (MCo co) = mkGReflLeftCo r ty co - -mkGReflRightMCo :: Role -> Type -> MCoercionN -> Coercion -mkGReflRightMCo r ty MRefl = mkReflCo r ty -mkGReflRightMCo r ty (MCo co) = mkGReflRightCo r ty co - --- | Like 'mkCoherenceRightCo', but with an 'MCoercion' -mkCoherenceRightMCo :: Role -> Type -> MCoercionN -> Coercion -> Coercion -mkCoherenceRightMCo _ _ MRefl co2 = co2 -mkCoherenceRightMCo r ty (MCo co) co2 = mkCoherenceRightCo r ty co co2 - -isReflMCo :: MCoercion -> Bool -isReflMCo MRefl = True -isReflMCo _ = False - -{- -%************************************************************************ -%* * - Destructing coercions -%* * -%************************************************************************ --} - --- | This breaks a 'Coercion' with type @T A B C ~ T D E F@ into --- a list of 'Coercion's of kinds @A ~ D@, @B ~ E@ and @E ~ F@. Hence: --- --- > decomposeCo 3 c [r1, r2, r3] = [nth r1 0 c, nth r2 1 c, nth r3 2 c] -decomposeCo :: Arity -> Coercion - -> Infinite Role -- the roles of the output coercions - -> [Coercion] -decomposeCo arity co rs - = [mkSelCo (SelTyCon n r) co | (n,r) <- [0..(arity-1)] `zip` Inf.toList rs ] - -- Remember, SelTyCon is zero-indexed - -decomposeFunCo :: HasDebugCallStack - => Coercion -- Input coercion - -> (CoercionN, Coercion, Coercion) --- Expects co :: (s1 %m1-> t1) ~ (s2 %m2-> t2) --- Returns (cow :: m1 ~N m2, co1 :: s1~s2, co2 :: t1~t2) --- actually cow will be a Phantom coercion if the input is a Phantom coercion - -decomposeFunCo (FunCo { fco_mult = w, fco_arg = co1, fco_res = co2 }) - = (w, co1, co2) - -- Short-circuits the calls to mkSelCo - -decomposeFunCo co - = assertPpr all_ok (ppr co) $ - ( mkSelCo (SelFun SelMult) co - , mkSelCo (SelFun SelArg) co - , mkSelCo (SelFun SelRes) co ) - where - Pair s1t1 s2t2 = coercionKind co - all_ok = isFunTy s1t1 && isFunTy s2t2 - -{- Note [Pushing a coercion into a pi-type] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose we have this: - (f |> co) t1 .. tn -Then we want to push the coercion into the arguments, so as to make -progress. For example of why you might want to do so, see Note -[Respecting definitional equality] in GHC.Core.TyCo.Rep. - -This is done by decomposePiCos. Specifically, if - decomposePiCos co [t1,..,tn] = ([co1,...,cok], cor) -then - (f |> co) t1 .. tn = (f (t1 |> co1) ... (tk |> cok)) |> cor) t(k+1) ... tn - -Notes: - -* k can be smaller than n! That is decomposePiCos can return *fewer* - coercions than there are arguments (ie k < n), if the kind provided - doesn't have enough binders. - -* If there is a type error, we might see - (f |> co) t1 - where co :: (forall a. ty) ~ (ty1 -> ty2) - Here 'co' is insoluble, but we don't want to crash in decoposePiCos. - So decomposePiCos carefully tests both sides of the coercion to check - they are both foralls or both arrows. Not doing this caused #15343. --} - -decomposePiCos :: HasDebugCallStack - => CoercionN -> Pair Type -- Coercion and its kind - -> [Type] - -> ([CoercionN], CoercionN) --- See Note [Pushing a coercion into a pi-type] -decomposePiCos orig_co (Pair orig_k1 orig_k2) orig_args - = go [] (orig_subst,orig_k1) orig_co (orig_subst,orig_k2) orig_args - where - orig_subst = mkEmptySubst $ mkInScopeSet $ - tyCoVarsOfTypes orig_args `unionVarSet` tyCoVarsOfCo orig_co - - go :: [CoercionN] -- accumulator for argument coercions, reversed - -> (Subst,Kind) -- Lhs kind of coercion - -> CoercionN -- coercion originally applied to the function - -> (Subst,Kind) -- Rhs kind of coercion - -> [Type] -- Arguments to that function - -> ([CoercionN], Coercion) - -- Invariant: co :: subst1(k1) ~ subst2(k2) - - go acc_arg_cos (subst1,k1) co (subst2,k2) (ty:tys) - | Just (a, t1) <- splitForAllTyCoVar_maybe k1 - , Just (b, t2) <- splitForAllTyCoVar_maybe k2 - -- know co :: (forall a:s1.t1) ~ (forall b:s2.t2) - -- function :: forall a:s1.t1 (the function is not passed to decomposePiCos) - -- a :: s1 - -- b :: s2 - -- ty :: s2 - -- need arg_co :: s2 ~ s1 - -- res_co :: t1[ty |> arg_co / a] ~ t2[ty / b] - = let arg_co = mkSelCo SelForAll (mkSymCo co) - res_co = mkInstCo co (mkGReflLeftCo Nominal ty arg_co) - subst1' = extendTCvSubst subst1 a (ty `CastTy` arg_co) - subst2' = extendTCvSubst subst2 b ty - in - go (arg_co : acc_arg_cos) (subst1', t1) res_co (subst2', t2) tys - - | Just (af1, _w1, _s1, t1) <- splitFunTy_maybe k1 - , Just (af2, _w1, _s2, t2) <- splitFunTy_maybe k2 - , af1 == af2 -- Same sort of arrow - -- know co :: (s1 -> t1) ~ (s2 -> t2) - -- function :: s1 -> t1 - -- ty :: s2 - -- need arg_co :: s2 ~ s1 - -- res_co :: t1 ~ t2 - = let (_, sym_arg_co, res_co) = decomposeFunCo co - -- It should be fine to ignore the multiplicity bit - -- of the coercion for a Nominal coercion. - arg_co = mkSymCo sym_arg_co - in - go (arg_co : acc_arg_cos) (subst1,t1) res_co (subst2,t2) tys - - | not (isEmptyTCvSubst subst1) || not (isEmptyTCvSubst subst2) - = go acc_arg_cos (zapSubst subst1, substTy subst1 k1) - co - (zapSubst subst2, substTy subst1 k2) - (ty:tys) - - -- tys might not be empty, if the left-hand type of the original coercion - -- didn't have enough binders - go acc_arg_cos _ki1 co _ki2 _tys = (reverse acc_arg_cos, co) - --- | Extract a covar, if possible. This check is dirty. Be ashamed --- of yourself. (It's dirty because it cares about the structure of --- a coercion, which is morally reprehensible.) -getCoVar_maybe :: Coercion -> Maybe CoVar -getCoVar_maybe (CoVarCo cv) = Just cv -getCoVar_maybe _ = Nothing - -multToCo :: Mult -> Coercion -multToCo r = mkNomReflCo r - --- first result has role equal to input; third result is Nominal -splitAppCo_maybe :: Coercion -> Maybe (Coercion, Coercion) --- ^ Attempt to take a coercion application apart. -splitAppCo_maybe (AppCo co arg) = Just (co, arg) -splitAppCo_maybe (TyConAppCo r tc args) - | args `lengthExceeds` tyConArity tc - , Just (args', arg') <- snocView args - = Just ( mkTyConAppCo r tc args', arg' ) - - | not (tyConMustBeSaturated tc) - -- Never create unsaturated type family apps! - , Just (args', arg') <- snocView args - , Just arg'' <- setNominalRole_maybe (tyConRole r tc (length args')) arg' - = Just ( mkTyConAppCo r tc args', arg'' ) - -- Use mkTyConAppCo to preserve the invariant - -- that identity coercions are always represented by Refl - -splitAppCo_maybe co - | Just (ty, r) <- isReflCo_maybe co - , Just (ty1, ty2) <- splitAppTy_maybe ty - = Just (mkReflCo r ty1, mkNomReflCo ty2) -splitAppCo_maybe _ = Nothing - --- Only used in specialise/Rules -splitFunCo_maybe :: Coercion -> Maybe (Coercion, Coercion) -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 - --- | 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 _ = 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 _ = Nothing - -------------------------------------------------------- --- and some coercion kind stuff - -coVarLType, coVarRType :: HasDebugCallStack => CoVar -> Type -coVarLType cv | (_, _, ty1, _, _) <- coVarKindsTypesRole cv = ty1 -coVarRType cv | (_, _, _, ty2, _) <- coVarKindsTypesRole cv = ty2 - -coVarTypes :: HasDebugCallStack => CoVar -> Pair Type -coVarTypes cv - | (_, _, ty1, ty2, _) <- coVarKindsTypesRole 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) - | otherwise - = pprPanic "coVarKindsTypesRole, non coercion variable" - (ppr cv $$ ppr (varType cv)) - -coVarKind :: CoVar -> Type -coVarKind cv - = assert (isCoVar cv ) - varType cv - -coVarRole :: CoVar -> Role -coVarRole cv - = eqTyConRole (case tyConAppTyCon_maybe (varType cv) of - Just tc0 -> tc0 - Nothing -> pprPanic "coVarRole: not tyconapp" (ppr cv)) - -eqTyConRole :: TyCon -> Role --- Given (~#) or (~R#) return the Nominal or Representational respectively -eqTyConRole tc - | tc `hasKey` eqPrimTyConKey - = Nominal - | tc `hasKey` eqReprPrimTyConKey - = Representational - | otherwise - = pprPanic "eqTyConRole: unknown tycon" (ppr tc) - --- | Given a coercion `co :: (t1 :: TYPE r1) ~ (t2 :: TYPE r2)` --- produce a coercion `rep_co :: r1 ~ r2` --- But actually it is possible that --- co :: (t1 :: CONSTRAINT r1) ~ (t2 :: CONSTRAINT r2) --- or co :: (t1 :: TYPE r1) ~ (t2 :: CONSTRAINT r2) --- or co :: (t1 :: CONSTRAINT r1) ~ (t2 :: TYPE r2) --- See Note [mkRuntimeRepCo] -mkRuntimeRepCo :: HasDebugCallStack => Coercion -> Coercion -mkRuntimeRepCo co - = assert (isTYPEorCONSTRAINT k1 && isTYPEorCONSTRAINT k2) $ - mkSelCo (SelTyCon 0 Nominal) kind_co - where - kind_co = mkKindCo co -- kind_co :: TYPE r1 ~ TYPE r2 - Pair k1 k2 = coercionKind kind_co - -{- Note [mkRuntimeRepCo] -~~~~~~~~~~~~~~~~~~~~~~~~ -Given - class C a where { op :: Maybe a } -we will get an axiom - axC a :: (C a :: CONSTRAINT r1) ~ (Maybe a :: TYPE r2) -(See Note [Type and Constraint are not apart] in GHC.Builtin.Types.Prim.) - -Then we may call mkRuntimeRepCo on (axC ty), and that will return - mkSelCo (SelTyCon 0 Nominal) (Kind (axC ty)) :: r1 ~ r2 - -So mkSelCo needs to be happy with decomposing a coercion of kind - CONSTRAINT r1 ~ TYPE r2 - -Hence the use of `tyConIsTYPEorCONSTRAINT` in the assertion `good_call` -in `mkSelCo`. See #23018 for a concrete example. (In this context it's -important that TYPE and CONSTRAINT have the same arity and kind, not -merely that they are not-apart; otherwise SelCo would not make sense.) --} - -isReflCoVar_maybe :: Var -> Maybe Coercion --- If cv :: t~t then isReflCoVar_maybe cv = Just (Refl t) --- Works on all kinds of Vars, not just CoVars -isReflCoVar_maybe cv - | isCoVar cv - , Pair ty1 ty2 <- coVarTypes cv - , ty1 `eqType` ty2 - = Just (mkReflCo (coVarRole cv) ty1) - | otherwise - = Nothing - --- | Tests if this coercion is obviously a generalized reflexive coercion. --- Guaranteed to work very quickly. -isGReflCo :: Coercion -> Bool -isGReflCo (GRefl{}) = True -isGReflCo (Refl{}) = True -- Refl ty == GRefl N ty MRefl -isGReflCo _ = False - --- | Tests if this coercion is obviously reflexive. Guaranteed to work --- very quickly. Sometimes a coercion can be reflexive, but not obviously --- so. c.f. 'isReflexiveCo' -isReflCo :: Coercion -> Bool -isReflCo (Refl{}) = True -isReflCo (GRefl _ _ mco) | isGReflMCo mco = True -isReflCo _ = False - --- | Returns the type coerced if this coercion is a generalized reflexive --- coercion. Guaranteed to work very quickly. -isGReflCo_maybe :: Coercion -> Maybe (Type, Role) -isGReflCo_maybe (GRefl r ty _) = Just (ty, r) -isGReflCo_maybe (Refl ty) = Just (ty, Nominal) -isGReflCo_maybe _ = Nothing - --- | Returns the type coerced if this coercion is reflexive. Guaranteed --- to work very quickly. Sometimes a coercion can be reflexive, but not --- obviously so. c.f. 'isReflexiveCo_maybe' -isReflCo_maybe :: Coercion -> Maybe (Type, Role) -isReflCo_maybe (Refl ty) = Just (ty, Nominal) -isReflCo_maybe (GRefl r ty mco) | isGReflMCo mco = Just (ty, r) -isReflCo_maybe _ = Nothing - --- | Slowly checks if the coercion is reflexive. Don't call this in a loop, --- as it walks over the entire coercion. -isReflexiveCo :: Coercion -> Bool -isReflexiveCo = isJust . isReflexiveCo_maybe - --- | Extracts the coerced type from a reflexive coercion. This potentially --- walks over the entire coercion, so avoid doing this in a loop. -isReflexiveCo_maybe :: Coercion -> Maybe (Type, Role) -isReflexiveCo_maybe (Refl ty) = Just (ty, Nominal) -isReflexiveCo_maybe (GRefl r ty mco) | isGReflMCo mco = Just (ty, r) -isReflexiveCo_maybe co - | ty1 `eqType` ty2 - = Just (ty1, r) - | otherwise - = Nothing - where (Pair ty1 ty2, r) = coercionKindRole co - - -{- -%************************************************************************ -%* * - Building coercions -%* * -%************************************************************************ - -These "smart constructors" maintain the invariants listed in the definition -of Coercion, and they perform very basic optimizations. - -Note [Role twiddling functions] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -There are a plethora of functions for twiddling roles: - -mkSubCo: Requires a nominal input coercion and always produces a -representational output. This is used when you (the programmer) are sure you -know exactly that role you have and what you want. - -downgradeRole_maybe: This function takes both the input role and the output role -as parameters. (The *output* role comes first!) It can only *downgrade* a -role -- that is, change it from N to R or P, or from R to P. This one-way -behavior is why there is the "_maybe". If an upgrade is requested, this -function produces Nothing. This is used when you need to change the role of a -coercion, but you're not sure (as you're writing the code) of which roles are -involved. - -This function could have been written using coercionRole to ascertain the role -of the input. But, that function is recursive, and the caller of downgradeRole_maybe -often knows the input role. So, this is more efficient. - -downgradeRole: This is just like downgradeRole_maybe, but it panics if the -conversion isn't a downgrade. - -setNominalRole_maybe: This is the only function that can *upgrade* a coercion. -The result (if it exists) is always Nominal. The input can be at any role. It -works on a "best effort" basis, as it should never be strictly necessary to -upgrade a coercion during compilation. It is currently only used within GHC in -splitAppCo_maybe. In order to be a proper inverse of mkAppCo, the second -coercion that splitAppCo_maybe returns must be nominal. But, it's conceivable -that splitAppCo_maybe is operating over a TyConAppCo that uses a -representational coercion. Hence the need for setNominalRole_maybe. -splitAppCo_maybe, in turn, is used only within coercion optimization -- thus, -it is not absolutely critical that setNominalRole_maybe be complete. - -Note that setNominalRole_maybe will never upgrade a phantom UnivCo. Phantom -UnivCos are perfectly type-safe, whereas representational and nominal ones are -not. (Nominal ones are no worse than representational ones, so this function *will* -change a UnivCo Representational to a UnivCo Nominal.) - -Conal Elliott also came across a need for this function while working with the -GHC API, as he was decomposing Core casts. The Core casts use representational -coercions, as they must, but his use case required nominal coercions (he was -building a GADT). So, that's why this function is exported from this module. - -One might ask: shouldn't downgradeRole_maybe just use setNominalRole_maybe as -appropriate? I (Richard E.) have decided not to do this, because upgrading a -role is bizarre and a caller should have to ask for this behavior explicitly. - --} - --- | Make a reflexive coercion -mkReflCo :: Role -> Type -> Coercion -mkReflCo Nominal ty = Refl ty -mkReflCo r ty = GRefl r ty MRefl - --- | Make a representational reflexive coercion -mkRepReflCo :: Type -> Coercion -mkRepReflCo ty = GRefl Representational ty MRefl - --- | Make a nominal reflexive coercion -mkNomReflCo :: Type -> Coercion -mkNomReflCo = Refl - --- | Apply a type constructor to a list of coercions. It is the --- caller's responsibility to get the roles correct on argument coercions. -mkTyConAppCo :: HasDebugCallStack => Role -> TyCon -> [Coercion] -> Coercion -mkTyConAppCo r tc cos - | Just co <- tyConAppFunCo_maybe r tc cos - = co - - -- Expand type synonyms - | ExpandsSyn tv_co_prs rhs_ty leftover_cos <- expandSynTyCon_maybe tc cos - = mkAppCos (liftCoSubst r (mkLiftingContext tv_co_prs) rhs_ty) leftover_cos - - | Just tys_roles <- traverse isReflCo_maybe cos - = mkReflCo r (mkTyConApp tc (map fst tys_roles)) - -- See Note [Refl invariant] - - | otherwise = TyConAppCo r tc cos - -mkFunCoNoFTF :: HasDebugCallStack => Role -> CoercionN -> Coercion -> Coercion -> Coercion --- This version of mkFunCo takes no FunTyFlags; it works them out -mkFunCoNoFTF r w arg_co res_co - = mkFunCo2 r afl afr w arg_co res_co - where - afl = chooseFunTyFlag argl_ty resl_ty - afr = chooseFunTyFlag argr_ty resr_ty - Pair argl_ty argr_ty = coercionKind arg_co - Pair resl_ty resr_ty = coercionKind res_co - --- | Build a function 'Coercion' from two other 'Coercion's. That is, --- given @co1 :: a ~ b@ and @co2 :: x ~ y@ produce @co :: (a -> x) ~ (b -> y)@ --- or @(a => x) ~ (b => y)@, depending on the kind of @a@/@b@. --- This (most common) version takes a single FunTyFlag, which is used --- for both fco_afl and ftf_afr of the FunCo -mkFunCo1 :: HasDebugCallStack => Role -> FunTyFlag -> CoercionN -> Coercion -> Coercion -> Coercion -mkFunCo1 r af w arg_co res_co - = mkFunCo2 r af af w arg_co res_co - -mkNakedFunCo1 :: Role -> FunTyFlag -> CoercionN -> Coercion -> Coercion -> Coercion --- This version of mkFunCo1 does not check FunCo invariants (checkFunCo) --- It is called during typechecking on un-zonked types; --- in particular there may be un-zonked coercion variables. -mkNakedFunCo1 r af w arg_co res_co - = mkNakedFunCo2 r af af w arg_co res_co - -mkFunCo2 :: HasDebugCallStack => Role -> FunTyFlag -> FunTyFlag - -> CoercionN -> Coercion -> Coercion -> Coercion --- This is the smart constructor for FunCo; it checks invariants -mkFunCo2 r afl afr w arg_co res_co - = assertPprMaybe (checkFunCo r afl afr w arg_co res_co) $ - mkNakedFunCo2 r afl afr w arg_co res_co - -mkNakedFunCo2 :: Role -> FunTyFlag -> FunTyFlag - -> CoercionN -> Coercion -> Coercion -> Coercion --- This is the smart constructor for FunCo --- "Naked"; it does not check invariants -mkNakedFunCo2 r afl afr w arg_co res_co - | Just (ty1, _) <- isReflCo_maybe arg_co - , Just (ty2, _) <- isReflCo_maybe res_co - , Just (w, _) <- isReflCo_maybe w - = mkReflCo r (mkFunTy afl w ty1 ty2) -- See Note [Refl invariant] - - | otherwise - = FunCo { fco_role = r, fco_afl = afl, fco_afr = afr - , fco_mult = w, fco_arg = arg_co, fco_res = res_co } - - -checkFunCo :: Role -> FunTyFlag -> FunTyFlag - -> CoercionN -> Coercion -> Coercion - -> Maybe SDoc --- Checks well-formed-ness for FunCo --- Used only in assertions and Lint -{-# NOINLINE checkFunCo #-} -checkFunCo _r afl afr _w arg_co res_co - | not (ok argl_ty && ok argr_ty && ok resl_ty && ok resr_ty) - = Just (hang (text "Bad arg or res types") 2 pp_inputs) - - | afl == computed_afl - , afr == computed_afr - = Nothing - | otherwise - = Just (vcat [ text "afl (provided,computed):" <+> ppr afl <+> ppr computed_afl - , text "afr (provided,computed):" <+> ppr afr <+> ppr computed_afr - , pp_inputs ]) - where - computed_afl = chooseFunTyFlag argl_ty resl_ty - computed_afr = chooseFunTyFlag argr_ty resr_ty - Pair argl_ty argr_ty = coercionKind arg_co - Pair resl_ty resr_ty = coercionKind res_co - - pp_inputs = vcat [ pp_ty "argl" argl_ty, pp_ty "argr" argr_ty - , pp_ty "resl" resl_ty, pp_ty "resr" resr_ty - , text "arg_co:" <+> ppr arg_co - , text "res_co:" <+> ppr res_co ] - - ok ty = isTYPEorCONSTRAINT (typeKind ty) - pp_ty str ty = text str <> colon <+> hang (ppr ty) - 2 (dcolon <+> ppr (typeKind ty)) - --- | Apply a 'Coercion' to another 'Coercion'. --- The second coercion must be Nominal, unless the first is Phantom. --- If the first is Phantom, then the second can be either Phantom or Nominal. -mkAppCo :: Coercion -- ^ :: t1 ~r t2 - -> Coercion -- ^ :: s1 ~N s2, where s1 :: k1, s2 :: k2 - -> Coercion -- ^ :: t1 s1 ~r t2 s2 -mkAppCo co arg - | Just (ty1, r) <- isReflCo_maybe co - , Just (ty2, _) <- isReflCo_maybe arg - = mkReflCo r (mkAppTy ty1 ty2) - - | Just (ty1, r) <- isReflCo_maybe co - , Just (tc, tys) <- splitTyConApp_maybe ty1 - -- Expand type synonyms; a TyConAppCo can't have a type synonym (#9102) - = mkTyConAppCo r tc (zip_roles (tyConRolesX r tc) tys) - where - zip_roles (Inf r1 _) [] = [downgradeRole r1 Nominal arg] - zip_roles (Inf r1 rs) (ty1:tys) = mkReflCo r1 ty1 : zip_roles rs tys - -mkAppCo (TyConAppCo r tc args) arg - = case r of - Nominal -> mkTyConAppCo Nominal tc (args ++ [arg]) - Representational -> mkTyConAppCo Representational tc (args ++ [arg']) - where new_role = tyConRolesRepresentational tc Inf.!! length args - arg' = downgradeRole new_role Nominal arg - Phantom -> mkTyConAppCo Phantom tc (args ++ [toPhantomCo arg]) -mkAppCo co arg = AppCo co arg --- Note, mkAppCo is careful to maintain invariants regarding --- where Refl constructors appear; see the comments in the definition --- of Coercion and the Note [Refl invariant] in GHC.Core.TyCo.Rep. - --- | Applies multiple 'Coercion's to another 'Coercion', from left to right. --- See also 'mkAppCo'. -mkAppCos :: Coercion - -> [Coercion] - -> 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. - -We chose (2) for two reasons: - -* 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. - -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. - -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. --} - - --- | 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 - --- | 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 - --- | 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) - | otherwise - = mkHomoForAllCos_NoRefl vs 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 --- See Note [mkCoVarCo] -mkCoVarCo cv = CoVarCo cv - -mkCoVarCos :: [CoVar] -> [Coercion] -mkCoVarCos = map mkCoVarCo - -{- Note [mkCoVarCo] -~~~~~~~~~~~~~~~~~~~ -In the past, mkCoVarCo optimised (c :: t~t) to (Refl t). That is -valid (although see Note [Unbound RULE binders] in GHC.Core.Rules), but -it's a relatively expensive test and perhaps better done in -optCoercion. Not a big deal either way. --} - -mkAxInstCo :: Role -> CoAxiom br -> BranchIndex -> [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 - | arity == n_tys = downgradeRole role ax_role $ - mkAxiomInstCo ax_br index (rtys `chkAppend` cos) - | otherwise = assert (arity < n_tys) $ - downgradeRole role ax_role $ - mkAppCos (mkAxiomInstCo ax_br index - (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 - --- worker function -mkAxiomInstCo :: CoAxiom Branched -> BranchIndex -> [Coercion] -> Coercion -mkAxiomInstCo ax index args - = assert (args `lengthIs` coAxiomArity ax index) $ - AxiomInstCo ax index args - --- 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 - -mkAxInstRHS :: CoAxiom br -> BranchIndex -> [Type] -> [Coercion] -> Type --- Instantiate the axiom with specified types, --- returning the instantiated RHS --- A companion to mkAxInstCo: --- mkAxInstRhs ax index tys = snd (coercionKind (mkAxInstCo ax index tys)) -mkAxInstRHS ax index tys cos - = assert (tvs `equalLength` tys1) $ - mkAppTys rhs' tys2 - where - branch = coAxiomNthBranch ax index - tvs = coAxBranchTyVars branch - cvs = coAxBranchCoVars branch - (tys1, tys2) = splitAtList tvs tys - rhs' = substTyWith tvs tys1 $ - substTyWithCoVars cvs cos $ - coAxBranchRHS branch - -mkUnbranchedAxInstRHS :: CoAxiom Unbranched -> [Type] -> [Coercion] -> Type -mkUnbranchedAxInstRHS ax = mkAxInstRHS ax 0 - --- | Return the left-hand type of the axiom, when the axiom is instantiated --- at the types given. -mkAxInstLHS :: CoAxiom br -> BranchIndex -> [Type] -> [Coercion] -> Type -mkAxInstLHS ax index tys cos - = assert (tvs `equalLength` tys1) $ - mkTyConApp fam_tc (lhs_tys `chkAppend` tys2) - where - branch = coAxiomNthBranch ax index - tvs = coAxBranchTyVars branch - cvs = coAxBranchCoVars branch - (tys1, tys2) = splitAtList tvs tys - lhs_tys = substTysWith tvs tys1 $ - substTysWithCoVars cvs cos $ - coAxBranchLHS branch - fam_tc = coAxiomTyCon ax - --- | Instantiate the left-hand side of an unbranched axiom -mkUnbranchedAxInstLHS :: CoAxiom Unbranched -> [Type] -> [Coercion] -> Type -mkUnbranchedAxInstLHS ax = mkAxInstLHS ax 0 - --- | Make a coercion from a coercion hole -mkHoleCo :: CoercionHole -> Coercion -mkHoleCo h = HoleCo h - --- | Make a universal coercion between two arbitrary types. -mkUnivCo :: UnivCoProvenance - -> Role -- ^ role of the built coercion, "r" - -> Type -- ^ t1 :: k1 - -> Type -- ^ t2 :: k2 - -> Coercion -- ^ :: t1 ~r t2 -mkUnivCo prov role ty1 ty2 - | ty1 `eqType` ty2 = mkReflCo role ty1 - | otherwise = UnivCo prov role ty1 ty2 - --- | 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 - --- | 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 - -mkSelCo :: HasDebugCallStack - => CoSel - -> Coercion - -> Coercion -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 -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 _) - = Just kind_co - -- If co :: (forall a1:k1. t1) ~ (forall a2:k2. t2) - -- then (nth SelForAll co :: k1 ~N k2) - -- If co :: (forall a1:t1 ~ t2. t1) ~ (forall a2:t3 ~ t4. t2) - -- then (nth SelForAll co :: (t1 ~ t2) ~N (t3 ~ t4)) - - go (SelFun fs) (FunCo _ _ _ w arg res) - = Just (getNthFun fs w arg res) - - go (SelTyCon i r) (TyConAppCo r0 tc arg_cos) - = assertPpr (r == tyConRole r0 tc i) - (vcat [ ppr tc, ppr arg_cos, ppr r0, ppr i, ppr r ]) $ - Just (arg_cos `getNth` i) - - go cs (SymCo co) -- Recurse, hoping to get to a TyConAppCo or FunCo - = do { co' <- go cs co; return (mkSymCo co') } - - go _ _ = Nothing - - -- Assertion checking - bad_call_msg = vcat [ text "Coercion =" <+> ppr co - , text "LHS ty =" <+> ppr ty1 - , text "RHS ty =" <+> ppr ty2 - , text "cs =" <+> ppr cs - , text "coercion role =" <+> ppr (coercionRole co) ] - - -- good_call checks the typing rules given in Note [SelCo] - good_call SelForAll - | Just (_tv1, _) <- splitForAllTyCoVar_maybe ty1 - , Just (_tv2, _) <- splitForAllTyCoVar_maybe ty2 - = True - - good_call (SelFun {}) - = isFunTy ty1 && isFunTy ty2 - - good_call (SelTyCon n r) - | Just (tc1, tys1) <- splitTyConApp_maybe ty1 - , Just (tc2, tys2) <- splitTyConApp_maybe ty2 - , let { len1 = length tys1 - ; len2 = length tys2 } - = (tc1 == tc2 || (tyConIsTYPEorCONSTRAINT tc1 && tyConIsTYPEorCONSTRAINT tc2)) - -- tyConIsTYPEorCONSTRAINT: see Note [mkRuntimeRepCo] - && len1 == len2 - && n < len1 - && r == tyConRole (coercionRole co) tc1 n - - good_call _ = False - --- | Extract the nth field of a FunCo -getNthFun :: FunSel - -> a -- ^ multiplicity - -> a -- ^ argument - -> a -- ^ result - -> a -- ^ One of the above three -getNthFun SelMult mult _ _ = mult -getNthFun SelArg _ arg _ = arg -getNthFun SelRes _ _ res = res - -mkLRCo :: LeftOrRight -> Coercion -> Coercion -mkLRCo lr co - | Just (ty, eq) <- isReflCo_maybe co - = mkReflCo eq (pickLR lr (splitAppTy ty)) - | otherwise - = LRCo lr co - --- | Instantiates a 'Coercion'. -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 arg = InstCo co arg - --- | Given @ty :: k1@, @co :: k1 ~ k2@, --- produces @co' :: ty ~r (ty |> co)@ -mkGReflRightCo :: Role -> Type -> CoercionN -> Coercion -mkGReflRightCo r ty co - | 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) - --- | Given @r@, @ty :: k1@, and @co :: k1 ~N k2@, --- produces @co' :: (ty |> co) ~r ty@ -mkGReflLeftCo :: Role -> Type -> CoercionN -> Coercion -mkGReflLeftCo r ty co - | 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) - --- | Given @ty :: k1@, @co :: k1 ~ k2@, @co2:: ty ~r ty'@, --- produces @co' :: (ty |> co) ~r ty' --- It is not only a utility function, but it saves allocation when co --- is a GRefl coercion. -mkCoherenceLeftCo :: Role -> Type -> CoercionN -> Coercion -> Coercion -mkCoherenceLeftCo r ty co co2 - | isGReflCo co = co2 - | otherwise = (mkSymCo $ GRefl r ty (MCo 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 r ty co co2 - | isGReflCo co = co2 - | otherwise = co2 `mkTransCo` GRefl r ty (MCo 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, - -- as it can lead to exponential behavior. But, we don't have nested mkKindCos, - -- so it's OK here. - , let tk1 = typeKind ty1 - tk2 = typeKind ty2 - , tk1 `eqType` tk2 - = Refl tk1 - | otherwise - = KindCo co - -mkSubCo :: HasDebugCallStack => Coercion -> Coercion --- Input coercion is Nominal, result is Representational --- see also Note [Role twiddling functions] -mkSubCo (Refl ty) = GRefl Representational ty MRefl -mkSubCo (GRefl Nominal ty co) = GRefl Representational ty co -mkSubCo (TyConAppCo Nominal tc cos) - = TyConAppCo Representational tc (applyRoles tc cos) -mkSubCo co@(FunCo { fco_role = Nominal, fco_arg = arg, fco_res = res }) - = co { fco_role = Representational - , fco_arg = downgradeRole Representational Nominal arg - , fco_res = downgradeRole Representational Nominal res } -mkSubCo co = assertPpr (coercionRole co == Nominal) (ppr co <+> ppr (coercionRole co)) $ - SubCo co - --- | Changes a role, but only a downgrade. See Note [Role twiddling functions] -downgradeRole_maybe :: Role -- ^ desired role - -> Role -- ^ current role - -> Coercion -> Maybe Coercion --- In (downgradeRole_maybe dr cr co) it's a precondition that --- cr = coercionRole co - -downgradeRole_maybe Nominal Nominal co = Just co -downgradeRole_maybe Nominal _ _ = Nothing - -downgradeRole_maybe Representational Nominal co = Just (mkSubCo co) -downgradeRole_maybe Representational Representational co = Just co -downgradeRole_maybe Representational Phantom _ = Nothing - -downgradeRole_maybe Phantom Phantom co = Just co -downgradeRole_maybe Phantom _ co = Just (toPhantomCo co) - --- | Like 'downgradeRole_maybe', but panics if the change isn't a downgrade. --- See Note [Role twiddling functions] -downgradeRole :: Role -- desired role - -> Role -- current role - -> Coercion -> Coercion -downgradeRole r1 r2 co - = case downgradeRole_maybe r1 r2 co of - 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 - -> Coercion -- ^ g1 :: phi1 - -> Coercion -- ^ g2 :: phi2 - -> Coercion -- ^ :: g1 ~r g2 - --- if the two coercion prove the same fact, I just don't care what --- 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) - -{- -%************************************************************************ -%* * - Roles -%* * -%************************************************************************ --} - --- | Converts a coercion to be nominal, if possible. --- See Note [Role twiddling functions] -setNominalRole_maybe :: Role -- of input coercion - -> Coercion -> Maybe CoercionN -setNominalRole_maybe r co - | r == Nominal = Just co - | otherwise = setNominalRole_maybe_helper co - where - setNominalRole_maybe_helper (SubCo co) = Just co - setNominalRole_maybe_helper co@(Refl _) = Just co - setNominalRole_maybe_helper (GRefl _ ty co) = Just $ GRefl Nominal ty co - setNominalRole_maybe_helper (TyConAppCo Representational tc cos) - = do { cos' <- zipWithM setNominalRole_maybe (tyConRoleListX Representational tc) cos - ; return $ TyConAppCo Nominal tc cos' } - setNominalRole_maybe_helper co@(FunCo { fco_role = Representational - , fco_arg = co1, fco_res = co2 }) - = do { co1' <- setNominalRole_maybe Representational co1 - ; co2' <- setNominalRole_maybe Representational co2 - ; return $ co { fco_role = Nominal, fco_arg = co1', fco_res = co2' } - } - setNominalRole_maybe_helper (SymCo co) - = SymCo <$> setNominalRole_maybe_helper co - setNominalRole_maybe_helper (TransCo co1 co2) - = 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 (SelCo cs co) = - -- NB, this case recurses via setNominalRole_maybe, not - -- setNominalRole_maybe_helper! - case cs of - SelTyCon n _r -> - -- Remember to update the role in SelTyCon to nominal; - -- not doing this caused #23362. - -- See the typing rule in Note [SelCo] in GHC.Core.TyCo.Rep. - SelCo (SelTyCon n Nominal) <$> setNominalRole_maybe (coercionRole co) co - SelFun fs -> - SelCo (SelFun fs) <$> setNominalRole_maybe (coercionRole co) co - SelForAll -> - 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 _ = Nothing - --- | Make a phantom coercion between two types. The coercion passed --- in must be a nominal coercion between the kinds of the --- types. -mkPhantomCo :: Coercion -> Type -> Type -> Coercion -mkPhantomCo h t1 t2 - = mkUnivCo (PhantomProv h) Phantom t1 t2 - --- takes any coercion and turns it into a Phantom coercion -toPhantomCo :: Coercion -> Coercion -toPhantomCo co - = mkPhantomCo (mkKindCo co) ty1 ty2 - where Pair ty1 ty2 = coercionKind co - --- Convert args to a TyConAppCo Nominal to the same TyConAppCo Representational -applyRoles :: TyCon -> [Coercion] -> [Coercion] -applyRoles = zipWith (`downgradeRole` Nominal) . tyConRoleListRepresentational - --- The Role parameter is the Role of the TyConAppCo --- defined here because this is intimately concerned with the implementation --- of TyConAppCo --- Always returns an infinite list (with a infinite tail of Nominal) -tyConRolesX :: Role -> TyCon -> Infinite Role -tyConRolesX Representational tc = tyConRolesRepresentational tc -tyConRolesX role _ = Inf.repeat role - -tyConRoleListX :: Role -> TyCon -> [Role] -tyConRoleListX role = Inf.toList . tyConRolesX role - --- Returns the roles of the parameters of a tycon, with an infinite tail --- of Nominal -tyConRolesRepresentational :: TyCon -> Infinite Role -tyConRolesRepresentational tc = tyConRoles tc Inf.++ Inf.repeat Nominal - --- Returns the roles of the parameters of a tycon, with an infinite tail --- of Nominal -tyConRoleListRepresentational :: TyCon -> [Role] -tyConRoleListRepresentational = Inf.toList . tyConRolesRepresentational - -tyConRole :: Role -> TyCon -> Int -> Role -tyConRole Nominal _ _ = Nominal -tyConRole Phantom _ _ = Phantom -tyConRole Representational tc n = tyConRolesRepresentational tc Inf.!! n - -funRole :: Role -> FunSel -> Role -funRole Nominal _ = Nominal -funRole Phantom _ = Phantom -funRole Representational fs = funRoleRepresentational fs - -funRoleRepresentational :: FunSel -> Role -funRoleRepresentational SelMult = Nominal -funRoleRepresentational SelArg = Representational -funRoleRepresentational SelRes = Representational - -ltRole :: Role -> Role -> Bool --- Is one role "less" than another? --- Nominal < Representational < Phantom -ltRole Phantom _ = False -ltRole Representational Phantom = True -ltRole Representational _ = False -ltRole Nominal Nominal = False -ltRole Nominal _ = True - -------------------------------- - --- | like mkKindCo, but aggressively & recursively optimizes to avoid using --- a KindCo constructor. The output role is nominal. -promoteCoercion :: Coercion -> CoercionN - --- First cases handles anything that should yield refl. -promoteCoercion co = case co of - - Refl _ -> mkNomReflCo ki1 - - GRefl _ _ MRefl -> mkNomReflCo ki1 - - GRefl _ _ (MCo co) -> co - - _ | ki1 `eqType` ki2 - -> mkNomReflCo (typeKind ty1) - -- No later branch should return refl - -- The assert (False )s throughout - -- are these cases explicitly, but they should never fire. - - TyConAppCo _ tc args - | Just co' <- instCoercions (mkNomReflCo (tyConKind tc)) args - -> co' - | otherwise - -> mkKindCo co - - AppCo co1 arg - | Just co' <- instCoercion (coercionKind (mkKindCo co1)) - (promoteCoercion co1) arg - -> co' - | otherwise - -> mkKindCo co - - ForAllCo tv _ g - | isTyVar tv - -> promoteCoercion g - - ForAllCo {} - -> assert False $ - -- (ForAllCo {} :: (forall cv.t1) ~ (forall cv.t2) - -- The tyvar case is handled above, so the bound var is a - -- 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 - 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 - - SymCo g - -> mkSymCo (promoteCoercion g) - - TransCo co1 co2 - -> mkTransCo (promoteCoercion co1) (promoteCoercion co2) - - SelCo n co1 - | Just co' <- mkSelCo_maybe n co1 - -> promoteCoercion co' - - | otherwise - -> mkKindCo co - - LRCo lr co1 - | Just (lco, rco) <- splitAppCo_maybe co1 - -> case lr of - CLeft -> promoteCoercion lco - CRight -> promoteCoercion rco - - | otherwise - -> mkKindCo co - - InstCo g _ - | isForAllTy_ty ty1 - -> assert (isForAllTy_ty ty2) $ - promoteCoercion g - | otherwise - -> assert False $ - mkNomReflCo liftedTypeKind - -- See Note [Weird typing rule for ForAllTy] in GHC.Core.TyCo.Rep - - KindCo _ - -> assert False $ -- See the first equation above - mkNomReflCo liftedTypeKind - - SubCo g - -> promoteCoercion g - - where - Pair ty1 ty2 = coercionKind co - ki1 = typeKind ty1 - ki2 = typeKind ty2 - --- | say @g = promoteCoercion h@. Then, @instCoercion g w@ yields @Just g'@, --- where @g' = promoteCoercion (h w)@. --- fails if this is not possible, if @g@ coerces between a forall and an -> --- or if second parameter has a representational role and can't be used --- with an InstCo. -instCoercion :: Pair Type -- g :: lty ~ rty - -> CoercionN -- ^ must be nominal - -> Coercion - -> Maybe CoercionN -instCoercion (Pair lty rty) g w - | (isForAllTy_ty lty && isForAllTy_ty rty) - || (isForAllTy_co lty && isForAllTy_co rty) - , Just w' <- setNominalRole_maybe (coercionRole w) w - -- g :: (forall t1. t2) ~ (forall t1. t3) - -- w :: s1 ~ s2 - -- returns mkInstCo g w' :: t2 [t1 |-> s1 ] ~ t3 [t1 |-> s2] - = Just $ mkInstCo g w' - - | isFunTy lty && isFunTy rty - -- g :: (t1 -> t2) ~ (t3 -> t4) - -- returns t2 ~ t4 - = Just $ mkSelCo (SelFun SelRes) g -- extract result type - - | otherwise -- one forall, one funty... - = Nothing - --- | Repeated use of 'instCoercion' -instCoercions :: CoercionN -> [Coercion] -> Maybe CoercionN -instCoercions g ws - = let arg_ty_pairs = map coercionKind ws in - snd <$> foldM go (coercionKind g, g) (zip arg_ty_pairs ws) - where - go :: (Pair Type, Coercion) -> (Pair Type, Coercion) - -> Maybe (Pair Type, Coercion) - go (g_tys, g) (w_tys, w) - = do { g' <- instCoercion g_tys g w - ; return (piResultTy <$> g_tys <*> w_tys, g') } - --- | Creates a new coercion with both of its types casted by different casts --- @castCoercionKind2 g r t1 t2 h1 h2@, where @g :: t1 ~r t2@, --- has type @(t1 |> h1) ~r (t2 |> h2)@. --- @h1@ and @h2@ must be nominal. -castCoercionKind2 :: Coercion -> Role -> Type -> Type - -> CoercionN -> CoercionN -> Coercion -castCoercionKind2 g r t1 t2 h1 h2 - = mkCoherenceRightCo r t2 h2 (mkCoherenceLeftCo r t1 h1 g) - --- | @castCoercionKind1 g r t1 t2 h@ = @coercionKind g r t1 t2 h h@ --- That is, it's a specialised form of castCoercionKind, where the two --- kind coercions are identical --- @castCoercionKind1 g r t1 t2 h@, where @g :: t1 ~r t2@, --- has type @(t1 |> h) ~r (t2 |> h)@. --- @h@ must be nominal. --- See Note [castCoercionKind1] -castCoercionKind1 :: Coercion -> Role -> Type -> Type - -> CoercionN -> Coercion -castCoercionKind1 g r t1 t2 h - = case g of - Refl {} -> assert (r == Nominal) $ -- Refl is always Nominal - 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) - _ -> castCoercionKind2 g r t1 t2 h h - --- | Creates a new coercion with both of its types casted by different casts --- @castCoercionKind g h1 h2@, where @g :: t1 ~r t2@, --- has type @(t1 |> h1) ~r (t2 |> h2)@. --- @h1@ and @h2@ must be nominal. --- It calls @coercionKindRole@, so it's quite inefficient (which 'I' stands for) --- Use @castCoercionKind2@ instead if @t1@, @t2@, and @r@ are known beforehand. -castCoercionKind :: Coercion -> CoercionN -> CoercionN -> Coercion -castCoercionKind g h1 h2 - = castCoercionKind2 g r t1 t2 h1 h2 - where - (Pair t1 t2, r) = coercionKindRole g - -mkPiCos :: Role -> [Var] -> Coercion -> Coercion -mkPiCos r vs co = foldr (mkPiCo r) co vs - --- | 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 - | 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 - -- want it to be r. It is only called in 'mkPiCos', which is - -- only used in GHC.Core.Opt.Simplify.Utils, where we are sure for - -- now (Aug 2018) v won't occur in co. - mkFunResCo r v co - | otherwise = mkFunResCo r v co - -mkFunResCo :: Role -> Id -> Coercion -> Coercion --- Given res_co :: res1 ~ res2, --- mkFunResCo r m arg res_co :: (arg -> res1) ~r (arg -> res2) --- Reflexive in the multiplicity argument -mkFunResCo role id res_co - = mkFunCoNoFTF role mult arg_co res_co - where - arg_co = mkReflCo role (varType id) - mult = multToCo (varMult 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 --- Lifted and unlifted equalities take different numbers of arguments, --- so we have to make sure to supply the right parameter to decomposeCo. --- Also, note that the role of the first coercion is the same as the role of --- the equalities related by the second coercion. The second coercion is --- itself always representational. -mkCoCast :: Coercion -> CoercionR -> Coercion -mkCoCast c g - | (g2:g1:_) <- reverse co_list - = mkSymCo g1 `mkTransCo` c `mkTransCo` g2 - - | otherwise - = pprPanic "mkCoCast" (ppr g $$ ppr (coercionKind g)) - where - -- g :: (s1 ~# t1) ~# (s2 ~# t2) - -- g1 :: s1 ~# s2 - -- g2 :: t1 ~# t2 - (tc, _) = splitTyConApp (coercionLKind g) - co_list = decomposeCo (tyConArity tc) g (tyConRolesRepresentational tc) - -{- Note [castCoercionKind1] -~~~~~~~~~~~~~~~~~~~~~~~~~~~ -castCoercionKind1 deals with the very important special case of castCoercionKind2 -where the two kind coercions are identical. In that case we can exploit the -situation where the main coercion is reflexive, via the special cases for Refl -and GRefl. - -This is important when rewriting (ty |> co). We rewrite ty, yielding - fco :: ty ~ ty' -and now we want a coercion xco between - xco :: (ty |> co) ~ (ty' |> co) -That's exactly what castCoercionKind1 does. And it's very very common for -fco to be Refl. In that case we do NOT want to get some terrible composition -of mkLeftCoherenceCo and mkRightCoherenceCo, which is what castCoercionKind2 -has to do in its full generality. See #18413. --} - -{- -%************************************************************************ -%* * - Newtypes -%* * -%************************************************************************ --} - --- | If `instNewTyCon_maybe T ts = Just (rep_ty, co)` --- then `co :: T ts ~R# rep_ty` --- --- Checks for a newtype, and for being saturated -instNewTyCon_maybe :: TyCon -> [Type] -> Maybe (Type, Coercion) -instNewTyCon_maybe tc tys - | Just (tvs, ty, co_tc) <- unwrapNewTyConEtad_maybe tc -- Check for newtype - , tvs `leLength` tys -- Check saturated enough - = Just (applyTysX tvs ty tys, mkUnbranchedAxInstCo Representational co_tc tys []) - | otherwise - = Nothing - -{- -************************************************************************ -* * - Type normalisation -* * -************************************************************************ --} - --- | A function to check if we can reduce a type by one step. Used --- with 'topNormaliseTypeX'. -type NormaliseStepper ev = RecTcChecker - -> TyCon -- tc - -> [Type] -- tys - -> NormaliseStepResult ev - --- | The result of stepping in a normalisation function. --- See 'topNormaliseTypeX'. -data NormaliseStepResult ev - = NS_Done -- ^ Nothing more to do - | NS_Abort -- ^ Utter failure. The outer function should fail too. - | NS_Step RecTcChecker Type ev -- ^ We stepped, yielding new bits; - -- ^ ev is evidence; - -- Usually a co :: old type ~ new type - deriving (Functor) - -instance Outputable ev => Outputable (NormaliseStepResult ev) where - ppr NS_Done = text "NS_Done" - ppr NS_Abort = text "NS_Abort" - ppr (NS_Step _ ty ev) = sep [text "NS_Step", ppr ty, ppr ev] - --- | Try one stepper and then try the next, if the first doesn't make --- progress. --- So if it returns NS_Done, it means that both steppers are satisfied -composeSteppers :: NormaliseStepper ev -> NormaliseStepper ev - -> NormaliseStepper ev -composeSteppers step1 step2 rec_nts tc tys - = case step1 rec_nts tc tys of - success@(NS_Step {}) -> success - NS_Done -> step2 rec_nts tc tys - NS_Abort -> NS_Abort - --- | A 'NormaliseStepper' that unwraps newtypes, careful not to fall into --- a loop. If it would fall into a loop, it produces 'NS_Abort'. -unwrapNewTypeStepper :: NormaliseStepper Coercion -unwrapNewTypeStepper rec_nts tc tys - | Just (ty', co) <- instNewTyCon_maybe tc tys - = -- pprTrace "unNS" (ppr tc <+> ppr (getUnique tc) <+> ppr tys $$ ppr ty' $$ ppr rec_nts) $ - case checkRecTc rec_nts tc of - Just rec_nts' -> NS_Step rec_nts' ty' co - Nothing -> NS_Abort - - | otherwise - = NS_Done - --- | A general function for normalising the top-level of a type. It continues --- to use the provided 'NormaliseStepper' until that function fails, and then --- this function returns. The roles of the coercions produced by the --- 'NormaliseStepper' must all be the same, which is the role returned from --- the call to 'topNormaliseTypeX'. --- --- Typically ev is Coercion. --- --- If topNormaliseTypeX step plus ty = Just (ev, ty') --- then ty ~ev1~ t1 ~ev2~ t2 ... ~evn~ ty' --- and ev = ev1 `plus` ev2 `plus` ... `plus` evn --- If it returns Nothing then no newtype unwrapping could happen -topNormaliseTypeX :: NormaliseStepper ev - -> (ev -> ev -> ev) - -> Type -> Maybe (ev, Type) -topNormaliseTypeX stepper plus ty - | Just (tc, tys) <- splitTyConApp_maybe ty - -- SPJ: The default threshold for initRecTc is 100 which is extremely dangerous - -- for certain type synonyms, we should think about reducing it (see #20990) - , NS_Step rec_nts ty' ev <- stepper initRecTc tc tys - = go rec_nts ev ty' - | otherwise - = Nothing - where - go rec_nts ev ty - | Just (tc, tys) <- splitTyConApp_maybe ty - = case stepper rec_nts tc tys of - NS_Step rec_nts' ty' ev' -> go rec_nts' (ev `plus` ev') ty' - NS_Done -> Just (ev, ty) - NS_Abort -> Nothing - - | otherwise - = Just (ev, ty) - -topNormaliseNewType_maybe :: Type -> Maybe (Coercion, Type) --- ^ Sometimes we want to look through a @newtype@ and get its associated coercion. --- This function strips off @newtype@ layers enough to reveal something that isn't --- a @newtype@. Specifically, here's the invariant: --- --- > topNormaliseNewType_maybe rec_nts ty = Just (co, ty') --- --- then (a) @co : ty ~R ty'@. --- (b) ty' is not a newtype. --- --- The function returns @Nothing@ for non-@newtypes@, --- or unsaturated applications --- --- This function does *not* look through type families, because it has no access to --- the type family environment. If you do have that at hand, consider to use --- topNormaliseType_maybe, which should be a drop-in replacement for --- topNormaliseNewType_maybe --- If topNormliseNewType_maybe ty = Just (co, ty'), then co : ty ~R ty' -topNormaliseNewType_maybe ty - = topNormaliseTypeX unwrapNewTypeStepper mkTransCo ty - -{- -%************************************************************************ -%* * - Comparison of coercions -%* * -%************************************************************************ --} - --- | Syntactic equality of coercions -eqCoercion :: Coercion -> Coercion -> Bool -eqCoercion = eqType `on` coercionType - --- | Compare two 'Coercion's, with respect to an RnEnv2 -eqCoercionX :: RnEnv2 -> Coercion -> Coercion -> Bool -eqCoercionX env = eqTypeX env `on` coercionType - -{- -%************************************************************************ -%* * - "Lifting" substitution - [(TyCoVar,Coercion)] -> Type -> Coercion -%* * -%************************************************************************ - -Note [Lifting coercions over types: liftCoSubst] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The KPUSH rule deals with this situation - data T a = K (a -> Maybe a) - g :: T t1 ~ T t2 - x :: t1 -> Maybe t1 - - case (K @t1 x) |> g of - K (y:t2 -> Maybe t2) -> rhs - -We want to push the coercion inside the constructor application. -So we do this - - g' :: t1~t2 = SelCo (SelTyCon 0) g - - case K @t2 (x |> g' -> Maybe g') of - K (y:t2 -> Maybe t2) -> rhs - -The crucial operation is that we - * take the type of K's argument: a -> Maybe a - * and substitute g' for a -thus giving *coercion*. This is what liftCoSubst does. - -In the presence of kind coercions, this is a bit -of a hairy operation. So, we refer you to the paper introducing kind coercions, -available at www.cis.upenn.edu/~sweirich/papers/fckinds-extended.pdf - -Note [extendLiftingContextEx] -~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider we have datatype - K :: /\k. /\a::k. P -> T k -- P be some type - g :: T k1 ~ T k2 - - case (K @k1 @t1 x) |> g of - K y -> rhs - -We want to push the coercion inside the constructor application. -We first get the coercion mapped by the universal type variable k: - lc = k |-> SelCo (SelTyCon 0) g :: k1~k2 - -Here, the important point is that the kind of a is coerced, and P might be -dependent on the existential type variable a. -Thus we first get the coercion of a's kind - g2 = liftCoSubst lc k :: k1 ~ k2 - -Then we store a new mapping into the lifting context - lc2 = a |-> (t1 ~ t1 |> g2), lc - -So later when we can correctly deal with the argument type P - liftCoSubst lc2 P :: P [k|->k1][a|->t1] ~ P[k|->k2][a |-> (t1|>g2)] - -This is exactly what extendLiftingContextEx does. -* For each (tyvar:k, ty) pair, we product the mapping - tyvar |-> (ty ~ ty |> (liftCoSubst lc k)) -* For each (covar:s1~s2, ty) pair, we produce the mapping - covar |-> (co ~ co') - co' = Sym (liftCoSubst lc s1) ;; covar ;; liftCoSubst lc s2 :: s1'~s2' - -This follows the lifting context extension definition in the -"FC with Explicit Kind Equality" paper. --} - --- ---------------------------------------------------- --- See Note [Lifting coercions over types: liftCoSubst] --- ---------------------------------------------------- - -data LiftingContext = LC Subst LiftCoEnv - -- in optCoercion, we need to lift when optimizing InstCo. - -- See Note [Optimising InstCo] in GHC.Core.Coercion.Opt - -- We thus propagate the substitution from GHC.Core.Coercion.Opt here. - -instance Outputable LiftingContext where - ppr (LC _ env) = hang (text "LiftingContext:") 2 (ppr env) - -type LiftCoEnv = VarEnv Coercion - -- Maps *type variables* to *coercions*. - -- That's the whole point of this function! - -- 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 - -> [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)) - -liftCoSubstWith :: Role -> [TyCoVar] -> [Coercion] -> Type -> Coercion -liftCoSubstWith r tvs cos ty - = liftCoSubst r (mkLiftingContext $ zipEqual "liftCoSubstWith" tvs cos) ty - --- | @liftCoSubst role lc ty@ produces a coercion (at role @role@) --- that coerces between @lc_left(ty)@ and @lc_right(ty)@, where --- @lc_left@ is a substitution mapping type variables to the left-hand --- types of the mapped coercions in @lc@, and similar for @lc_right@. -liftCoSubst :: HasDebugCallStack => Role -> LiftingContext -> Type -> Coercion -{-# INLINE liftCoSubst #-} --- Inlining this function is worth 2% of allocation in T9872d, -liftCoSubst r lc@(LC subst env) ty - | isEmptyVarEnv env = mkReflCo r (substTy subst ty) - | otherwise = ty_co_subst lc r ty - -emptyLiftingContext :: InScopeSet -> LiftingContext -emptyLiftingContext in_scope = LC (mkEmptySubst in_scope) emptyVarEnv - -mkLiftingContext :: [(TyCoVar,Coercion)] -> LiftingContext -mkLiftingContext pairs - = LC (mkEmptySubst $ mkInScopeSet $ tyCoVarsOfCos (map snd pairs)) - (mkVarEnv pairs) - -mkSubstLiftingContext :: Subst -> LiftingContext -mkSubstLiftingContext subst = LC subst emptyVarEnv - --- | Extend a lifting context with a new mapping. -extendLiftingContext :: LiftingContext -- ^ original LC - -> TyCoVar -- ^ new variable to map... - -> Coercion -- ^ ...to this lifted version - -> LiftingContext - -- mappings to reflexive coercions are just substitutions -extendLiftingContext (LC subst env) tv arg - | Just (ty, _) <- isReflCo_maybe arg - = LC (extendTCvSubst subst tv ty) env - | otherwise - = LC subst (extendVarEnv env tv arg) - --- | Extend a lifting context with a new mapping, and extend the in-scope set -extendLiftingContextAndInScope :: LiftingContext -- ^ Original LC - -> TyCoVar -- ^ new variable to map... - -> Coercion -- ^ to this coercion - -> LiftingContext -extendLiftingContextAndInScope (LC subst env) tv co - = extendLiftingContext (LC (extendSubstInScopeSet subst (tyCoVarsOfCo co)) env) tv co - --- | Extend a lifting context with existential-variable bindings. --- See Note [extendLiftingContextEx] -extendLiftingContextEx :: LiftingContext -- ^ original lifting context - -> [(TyCoVar,Type)] -- ^ ex. var / value pairs - -> LiftingContext --- Note that this is more involved than extendLiftingContext. That function --- takes a coercion to extend with, so it's assumed that the caller has taken --- into account any of the kind-changing stuff worried about here. -extendLiftingContextEx lc [] = lc -extendLiftingContextEx lc@(LC subst env) ((v,ty):rest) --- This function adds bindings for *Nominal* coercions. Why? Because it --- works with existentially bound variables, which are considered to have --- nominal roles. - | isTyVar v - = let lc' = LC (subst `extendSubstInScopeSet` tyCoVarsOfType ty) - (extendVarEnv env v $ - mkGReflRightCo Nominal - ty - (ty_co_subst lc Nominal (tyVarKind v))) - in extendLiftingContextEx lc' rest - | CoercionTy co <- ty - = -- co :: s1 ~r s2 - -- lift_s1 :: s1 ~r s1' - -- lift_s2 :: s2 ~r s2' - -- kco :: (s1 ~r s2) ~N (s1' ~r s2') - assert (isCoVar v) $ - let (_, _, s1, s2, r) = coVarKindsTypesRole v - lift_s1 = ty_co_subst lc r s1 - lift_s2 = ty_co_subst lc r s2 - kco = mkTyConAppCo Nominal (equalityTyCon r) - [ mkKindCo lift_s1, mkKindCo lift_s2 - , lift_s1 , lift_s2 ] - lc' = LC (subst `extendSubstInScopeSet` tyCoVarsOfCo co) - (extendVarEnv env v - (mkProofIrrelCo Nominal kco co $ - (mkSymCo lift_s1) `mkTransCo` co `mkTransCo` lift_s2)) - in extendLiftingContextEx lc' rest - | otherwise - = pprPanic "extendLiftingContextEx" (ppr v <+> text "|->" <+> ppr ty) - - --- | Erase the environments in a lifting context -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') - where - (subst', tv', co') = substForAllCoBndrUsing sym sco subst tv co - --- | The \"lifting\" operation which substitutes coercions for type --- variables in a type to produce a coercion. --- --- For the inverse operation, see 'liftCoMatch' -ty_co_subst :: LiftingContext -> Role -> Type -> Coercion -ty_co_subst !lc role ty - -- !lc: making this function strict in lc allows callers to - -- pass its two components separately, rather than boxing them. - -- Unfortunately, Boxity Analysis concludes that we need lc boxed - -- because it's used that way in liftCoSubstTyVarBndrUsing. - = go role ty - where - go :: Role -> Type -> Coercion - 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" $ - 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) = mkFunCo1 r af (go Nominal w) (go r t1) (go r t2) - go r t@(ForAllTy (Bndr v _) 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 - else pprPanic "ty_co_subst: covar is not almost devoid" (ppr t) - go r ty@(LitTy {}) = assert (r == Nominal) $ - mkNomReflCo ty - go r (CastTy ty co) = castCoercionKind (go r ty) (substLeftCo lc co) - (substRightCo lc co) - go r (CoercionTy co) = mkProofIrrelCo r kco (substLeftCo lc co) - (substRightCo lc co) - where kco = go Nominal (coercionType co) - - lift_phantom ty = mkPhantomCo (go Nominal (typeKind ty)) - (substTy (lcSubstLeft lc) ty) - (substTy (lcSubstRight lc) ty) - -{- -Note [liftCoSubstTyVar] -~~~~~~~~~~~~~~~~~~~~~~~~~ -This function can fail if a coercion in the environment is of too low a role. - -liftCoSubstTyVar is called from two places: in liftCoSubst (naturally), and -also in matchAxiom in GHC.Core.Coercion.Opt. From liftCoSubst, the so-called lifting -lemma guarantees that the roles work out. If we fail in this -case, we really should panic -- something is deeply wrong. But, in matchAxiom, -failing is fine. matchAxiom is trying to find a set of coercions -that match, but it may fail, and this is healthy behavior. --} - --- See Note [liftCoSubstTyVar] -liftCoSubstTyVar :: LiftingContext -> Role -> TyVar -> Maybe Coercion -liftCoSubstTyVar (LC subst env) r v - | Just co_arg <- lookupVarEnv env v - = downgradeRole_maybe r (coercionRole co_arg) co_arg - - | otherwise - = Just $ mkReflCo r (substTyVar subst v) - -{- Note [liftCoSubstVarBndr] - ~~~~~~~~~~~~~~~~~~~~~~~~~ -callback: - 'liftCoSubstVarBndrUsing' needs to be general enough to work in two - situations: - - - in this module, which manipulates 'Coercion's, and - - in GHC.Core.FamInstEnv, where we work with 'Reduction's, which contain - a coercion as well as a type. - - To achieve this, we require that the return type of the 'callback' function - contain a coercion within it. This is witnessed by the first argument - to 'liftCoSubstVarBndrUsing': a getter, which allows us to retrieve - the coercion inside the return type. Thus: - - - in this module, we simply pass 'id' as the getter, - - in GHC.Core.FamInstEnv, we pass 'reductionCoercion' as the getter. - -liftCoSubstTyVarBndrUsing: - Given - forall tv:k. t - We want to get - forall (tv:k1) (kind_co :: k1 ~ k2) body_co - - We lift the kind k to get the kind_co - kind_co = ty_co_subst k :: k1 ~ k2 - - Now in the LiftingContext, we add the new mapping - tv |-> (tv :: k1) ~ ((tv |> kind_co) :: k2) - -liftCoSubstCoVarBndrUsing: - Given - forall cv:(s1 ~ s2). t - We want to get - forall (cv:s1'~s2') (kind_co :: (s1'~s2') ~ (t1 ~ t2)) body_co - - We lift s1 and s2 respectively to get - eta1 :: s1' ~ t1 - eta2 :: s2' ~ t2 - And - kind_co = TyConAppCo Nominal (~#) eta1 eta2 - - Now in the liftingContext, we add the new mapping - cv |-> (cv :: s1' ~ s2') ~ ((sym eta1;cv;eta2) :: t1 ~ t2) --} - --- See Note [liftCoSubstVarBndr] -liftCoSubstVarBndr :: LiftingContext -> TyCoVar - -> (LiftingContext, TyCoVar, Coercion) -liftCoSubstVarBndr lc tv - = liftCoSubstVarBndrUsing id callback lc tv - where - callback lc' ty' = ty_co_subst lc' Nominal ty' - --- the callback must produce a nominal coercion -liftCoSubstVarBndrUsing :: (r -> CoercionN) -- ^ coercion getter - -> (LiftingContext -> Type -> r) -- ^ callback - -> LiftingContext -> TyCoVar - -> (LiftingContext, TyCoVar, r) -liftCoSubstVarBndrUsing view_co fun lc old_var - | isTyVar old_var - = liftCoSubstTyVarBndrUsing view_co fun lc old_var - | otherwise - = liftCoSubstCoVarBndrUsing view_co fun lc old_var - --- Works for tyvar binder -liftCoSubstTyVarBndrUsing :: (r -> CoercionN) -- ^ coercion getter - -> (LiftingContext -> Type -> r) -- ^ callback - -> LiftingContext -> TyVar - -> (LiftingContext, TyVar, r) -liftCoSubstTyVarBndrUsing view_co fun lc@(LC subst cenv) old_var - = assert (isTyVar old_var) $ - ( LC (subst `extendSubstInScope` new_var) new_cenv - , new_var, stuff ) - where - old_kind = tyVarKind old_var - stuff = fun lc old_kind - eta = view_co stuff - k1 = coercionLKind eta - new_var = uniqAway (getSubstInScope subst) (setVarType old_var k1) - - lifted = mkGReflRightCo Nominal (TyVarTy new_var) eta - -- :: new_var ~ new_var |> eta - new_cenv = extendVarEnv cenv old_var lifted - --- Works for covar binder -liftCoSubstCoVarBndrUsing :: (r -> CoercionN) -- ^ coercion getter - -> (LiftingContext -> Type -> r) -- ^ callback - -> LiftingContext -> CoVar - -> (LiftingContext, CoVar, r) -liftCoSubstCoVarBndrUsing view_co fun lc@(LC subst cenv) old_var - = assert (isCoVar old_var) $ - ( LC (subst `extendSubstInScope` new_var) new_cenv - , new_var, stuff ) - where - old_kind = coVarKind old_var - stuff = fun lc old_kind - eta = view_co stuff - k1 = coercionLKind eta - new_var = uniqAway (getSubstInScope subst) (setVarType old_var k1) - - -- old_var :: s1 ~r s2 - -- eta :: (s1' ~r s2') ~N (t1 ~r t2) - -- eta1 :: s1' ~r t1 - -- eta2 :: s2' ~r t2 - -- co1 :: s1' ~r s2' - -- co2 :: t1 ~r t2 - -- lifted :: co1 ~N co2 - - role = coVarRole old_var - eta' = downgradeRole role Nominal eta - eta1 = mkSelCo (SelTyCon 2 role) eta' - eta2 = mkSelCo (SelTyCon 3 role) eta' - - co1 = mkCoVarCo new_var - co2 = mkSymCo eta1 `mkTransCo` co1 `mkTransCo` eta2 - lifted = mkProofIrrelCo Nominal eta co1 co2 - - new_cenv = extendVarEnv cenv old_var lifted - --- | Is a var in the domain of a lifting context? -isMappedByLC :: TyCoVar -> LiftingContext -> Bool -isMappedByLC tv (LC _ env) = tv `elemVarEnv` env - --- If [a |-> g] is in the substitution and g :: t1 ~ t2, substitute a for t1 --- If [a |-> (g1, g2)] is in the substitution, substitute a for g1 -substLeftCo :: LiftingContext -> Coercion -> Coercion -substLeftCo lc co - = substCo (lcSubstLeft lc) co - --- Ditto, but for t2 and g2 -substRightCo :: LiftingContext -> Coercion -> Coercion -substRightCo lc co - = substCo (lcSubstRight lc) co - --- | Apply "sym" to all coercions in a 'LiftCoEnv' -swapLiftCoEnv :: LiftCoEnv -> LiftCoEnv -swapLiftCoEnv = mapVarEnv mkSymCo - -lcSubstLeft :: LiftingContext -> Subst -lcSubstLeft (LC subst lc_env) = liftEnvSubstLeft subst lc_env - -lcSubstRight :: LiftingContext -> Subst -lcSubstRight (LC subst lc_env) = liftEnvSubstRight subst lc_env - -liftEnvSubstLeft :: Subst -> LiftCoEnv -> Subst -liftEnvSubstLeft = liftEnvSubst pFst - -liftEnvSubstRight :: Subst -> LiftCoEnv -> Subst -liftEnvSubstRight = liftEnvSubst pSnd - -liftEnvSubst :: (forall a. Pair a -> a) -> Subst -> LiftCoEnv -> Subst -liftEnvSubst selector subst lc_env - = composeTCvSubst (Subst in_scope emptyIdSubstEnv tenv cenv) subst - where - pairs = nonDetUFMToList lc_env - -- It's OK to use nonDetUFMToList here because we - -- immediately forget the ordering by creating - -- a VarEnv - (tpairs, cpairs) = partitionWith ty_or_co pairs - -- Make sure the in-scope set is wide enough to cover the range of the - -- substitution (#22235). - in_scope = mkInScopeSet $ - tyCoVarsOfTypes (map snd tpairs) `unionVarSet` - tyCoVarsOfCos (map snd cpairs) - tenv = mkVarEnv_Directly tpairs - cenv = mkVarEnv_Directly cpairs - - ty_or_co :: (Unique, Coercion) -> Either (Unique, Type) (Unique, Coercion) - ty_or_co (u, co) - | Just equality_co <- isCoercionTy_maybe equality_ty - = Right (u, equality_co) - | otherwise - = Left (u, equality_ty) - where - equality_ty = selector (coercionKind co) - --- | Extract the underlying substitution from the LiftingContext -lcSubst :: LiftingContext -> Subst -lcSubst (LC subst _) = subst - --- | Get the 'InScopeSet' from a 'LiftingContext' -lcInScopeSet :: LiftingContext -> InScopeSet -lcInScopeSet (LC subst _) = getSubstInScope subst - -{- -%************************************************************************ -%* * - Sequencing on coercions -%* * -%************************************************************************ --} - -seqMCo :: MCoercion -> () -seqMCo MRefl = () -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 _) = () - -seqCos :: [Coercion] -> () -seqCos [] = () -seqCos (co:cos) = seqCo co `seq` seqCos cos - -{- -%************************************************************************ -%* * - The kind of a type, and of a coercion -%* * -%************************************************************************ --} - --- | Apply 'coercionKind' to multiple 'Coercion's -coercionKinds :: [Coercion] -> Pair [Type] -coercionKinds tys = sequenceA $ map coercionKind tys - --- | Get a coercion's kind and role. -coercionKindRole :: Coercion -> (Pair Type, Role) -coercionKindRole co = (coercionKind co, coercionRole co) - -coercionType :: Coercion -> Type -coercionType co = case coercionKindRole co of - (Pair ty1 ty2, r) -> mkCoercionType r ty1 ty2 - ------------------- --- | If it is the case that --- --- > c :: (t1 ~ t2) --- --- i.e. the kind of @c@ relates @t1@ and @t2@, then @coercionKind c = Pair t1 t2@. - -coercionKind :: Coercion -> Pair Type -coercionKind co = Pair (coercionLKind co) (coercionRKind co) - -coercionLKind :: Coercion -> Type -coercionLKind co - = go 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_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_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) - -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 - - 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) - - 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 - -- 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 - - go_forall subst (ForAllCo tv1 k_co co) - -- See Note [Nested ForAllCos] - | isTyVar tv1 - = mkInfForAllTy tv2 (go_forall subst' co) - where - k2 = coercionRKind k_co - tv2 = setTyVarKind tv1 (substTy subst k2) - subst' | isGReflCo k_co = extendSubstInScope subst tv1 - -- kind_co always has kind @Type@, thus @isGReflCo@ - | otherwise = extendTvSubst (extendSubstInScope subst tv2) tv1 $ - TyVarTy tv2 `mkCastTy` mkSymCo k_co - - go_forall subst (ForAllCo cv1 k_co co) - | isCoVar cv1 - = mkTyCoInvForAllTy cv2 (go_forall subst' co) - where - k2 = coercionRKind k_co - r = coVarRole cv1 - k_co' = downgradeRole r Nominal k_co - eta1 = mkSelCo (SelTyCon 2 r) k_co' - eta2 = mkSelCo (SelTyCon 3 r) k_co' - - -- k_co :: (t1 ~r t2) ~N (s1 ~r s2) - -- k1 = t1 ~r t2 - -- k2 = s1 ~r s2 - -- cv1 :: t1 ~r t2 - -- cv2 :: s1 ~r s2 - -- eta1 :: t1 ~r s1 - -- eta2 :: t2 ~r s2 - -- n_subst = (eta1 ; cv2 ; sym eta2) :: t1 ~r t2 - - cv2 = setVarType cv1 (substTy subst k2) - n_subst = eta1 `mkTransCo` (mkCoVarCo cv2) `mkTransCo` (mkSymCo eta2) - subst' | isReflCo k_co = extendSubstInScope subst cv1 - | otherwise = extendCvSubst (extendSubstInScope subst cv2) - cv1 n_subst - - go_forall 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. - -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 -being spent in coercionKind! The reason was that we had - (g @ ty1 @ ty2 .. @ ty100) -- The "@s" are InstCos -where - g :: forall a1 a2 .. a100. phi -If we deal with the InstCos one at a time, we'll do this: - 1. Find the kind of (g @ ty1 .. @ ty99) : forall a100. phi' - 2. Substitute phi'[ ty100/a100 ], a single tyvar->type subst -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). - --} - --- | 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 Phantom = \ty1 ty2 -> - let ki1 = typeKind ty1 - ki2 = typeKind ty2 - in - TyConApp eqPhantPrimTyCon [ki1, ki2, ty1, ty2] - --- | Creates a primitive type equality predicate. --- 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 - --- | 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 type equality predicate with explicit kinds -mkHeteroPrimEqPred :: Kind -> Kind -> Type -> Type -> Type -mkHeteroPrimEqPred k1 k2 ty1 ty2 = mkTyConApp eqPrimTyCon [k1, k2, ty1, ty2] - --- | Creates a primitive representational type equality predicate --- with explicit kinds -mkHeteroReprPrimEqPred :: Kind -> Kind -> Type -> Type -> Type -mkHeteroReprPrimEqPred k1 k2 ty1 ty2 - = mkTyConApp eqReprPrimTyCon [k1, k2, ty1, ty2] - -mkReprPrimEqPred :: Type -> Type -> Type -mkReprPrimEqPred ty1 ty2 - = mkTyConApp eqReprPrimTyCon [k1, k2, ty1, ty2] - where - k1 = typeKind ty1 - k2 = typeKind 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 orig_ty1 orig_ty2 = go orig_ty1 orig_ty2 - where - go ty1 ty2 | Just ty1' <- coreView ty1 = go ty1' ty2 - | Just ty2' <- coreView ty2 = go ty1 ty2' - - go (CastTy ty1 co) ty2 - = let co' = go ty1 ty2 - r = coercionRole co' - in mkCoherenceLeftCo r ty1 co co' - - go ty1 (CastTy ty2 co) - = let co' = go ty1 ty2 - r = coercionRole co' - in mkCoherenceRightCo r ty2 co co' - - go ty1@(TyVarTy tv1) _tyvarty - = assert (case _tyvarty of - { TyVarTy tv2 -> tv1 == tv2 - ; _ -> False }) $ - mkNomReflCo ty1 - - 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 }) - = assert (af1 == af2) $ - mkFunCo1 Nominal af1 (go w1 w2) (go arg1 arg2) (go res1 res2) - - go (TyConApp tc1 args1) (TyConApp tc2 args2) - = assert (tc1 == tc2) $ - mkTyConAppCo Nominal tc1 (zipWith go args1 args2) - - go (AppTy ty1a ty1b) ty2 - | Just (ty2a, ty2b) <- splitAppTyNoView_maybe ty2 - = mkAppCo (go ty1a ty2a) (go ty1b ty2b) - - go ty1 (AppTy ty2a ty2b) - | Just (ty1a, ty1b) <- splitAppTyNoView_maybe ty1 - = mkAppCo (go ty1a ty2a) (go ty1b ty2b) - - go (ForAllTy (Bndr tv1 _flag1) ty1) (ForAllTy (Bndr tv2 _flag2) ty2) - | isTyVar tv1 - = assert (isTyVar tv2) $ - mkForAllCo tv1 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) - = assert (isCoVar cv1 && isCoVar cv2) $ - mkForAllCo cv1 kind_co (go ty1 ty2') - where s1 = varType cv1 - s2 = varType cv2 - kind_co = go s1 s2 - - -- s1 = t1 ~r t2 - -- s2 = t3 ~r t4 - -- kind_co :: (t1 ~r t2) ~N (t3 ~r t4) - -- eta1 :: t1 ~r t3 - -- eta2 :: t2 ~r t4 - - r = coVarRole cv1 - kind_co' = downgradeRole r Nominal kind_co - eta1 = mkSelCo (SelTyCon 2 r) kind_co' - eta2 = mkSelCo (SelTyCon 3 r) kind_co' - - subst = mkEmptySubst $ mkInScopeSet $ - tyCoVarsOfType ty2 `unionVarSet` tyCoVarsOfCo kind_co - ty2' = substTy (extendCvSubst subst cv2 $ mkSymCo eta1 `mkTransCo` - mkCoVarCo cv1 `mkTransCo` - eta2) - ty2 - - go ty1@(LitTy lit1) _lit2 - = assert (case _lit2 of - { LitTy lit2 -> lit1 == lit2 - ; _ -> False }) $ - mkNomReflCo ty1 - - go (CoercionTy co1) (CoercionTy co2) - = mkProofIrrelCo Nominal kind_co co1 co2 - where - kind_co = go (coercionType co1) (coercionType co2) - - go ty1 ty2 - = pprPanic "buildKindCoercion" (vcat [ ppr orig_ty1, ppr orig_ty2 - , ppr ty1, ppr ty2 ]) - - -{- -%************************************************************************ -%* * - Coercion holes -%* * -%************************************************************************ --} - -has_co_hole_ty :: Type -> Monoid.Any -has_co_hole_co :: Coercion -> Monoid.Any -(has_co_hole_ty, _, has_co_hole_co, _) - = foldTyCo folder () - where - folder = TyCoFolder { tcf_view = noView - , tcf_tyvar = const2 (Monoid.Any False) - , tcf_covar = const2 (Monoid.Any False) - , tcf_hole = const2 (Monoid.Any True) - , tcf_tycobinder = const2 - } - --- | Is there a coercion hole in this type? -hasCoercionHoleTy :: Type -> Bool -hasCoercionHoleTy = Monoid.getAny . has_co_hole_ty - --- | Is there a 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 - } - --- | Set the type of a 'CoercionHole' -setCoHoleType :: CoercionHole -> Type -> CoercionHole -setCoHoleType h t = setCoHoleCoVar h (setVarType (coHoleCoVar h) t) + coVarKind, coVarTypesRole, coVarRole, + coercionType, mkCoercionType, + coercionKind, coercionLKind, coercionRKind,coercionKinds, + coercionRole, coercionKindRole, + + -- ** Constructing coercions + mkGReflCo, mkGReflMCo, mkReflCo, mkRepReflCo, mkNomReflCo, + mkCoVarCo, mkCoVarCos, + mkAxInstCo, mkUnbranchedAxInstCo, + mkAxInstRHS, mkUnbranchedAxInstRHS, + mkAxInstLHS, mkUnbranchedAxInstLHS, + mkPiCo, mkPiCos, mkCoCast, + mkSymCo, mkTransCo, + mkSelCo, mkSelCoResRole, getNthFun, selectFromType, mkLRCo, + mkInstCo, mkAppCo, mkAppCos, mkTyConAppCo, + mkFunCo, mkFunCo2, mkFunCoNoFTF, mkFunResCo, + mkNakedFunCo, + mkNakedForAllCo, mkForAllCo, mkForAllVisCos, mkHomoForAllCos, + mkPhantomCo, mkAxiomCo, + mkHoleCo, mkUnivCo, mkSubCo, + mkProofIrrelCo, + downgradeRole, + mkGReflRightCo, mkGReflLeftCo, mkCoherenceLeftCo, mkCoherenceRightCo, + mkKindCo, + castCoercionKind, castCoercionKind1, castCoercionKind2, + + -- ** Decomposition + instNewTyCon_maybe, + + NormaliseStepper, NormaliseStepResult(..), composeSteppers, unwrapNewTypeStepper, + topNormaliseNewType_maybe, topNormaliseTypeX, + + decomposeCo, decomposeFunCo, decomposePiCos, getCoVar_maybe, + splitAppCo_maybe, + splitFunCo_maybe, + splitForAllCo_maybe, + splitForAllCo_ty_maybe, splitForAllCo_co_maybe, + + tyConRole, tyConRolesX, tyConRolesRepresentational, setNominalRole_maybe, + tyConRoleListX, tyConRoleListRepresentational, funRole, + pickLR, + + isGReflCo, isReflCo, isReflCo_maybe, isGReflCo_maybe, isReflexiveCo, isReflexiveCo_maybe, + isReflCoVar_maybe, isGReflMCo, mkGReflLeftMCo, mkGReflRightMCo, + mkCoherenceRightMCo, + + coToMCo, mkTransMCo, mkTransMCoL, mkTransMCoR, mkCastTyMCo, mkSymMCo, + mkFunResMCo, mkPiMCos, + isReflMCo, checkReflexiveMCo, + + -- ** Coercion variables + mkCoVar, isCoVar, coVarName, setCoVarName, setCoVarUnique, + + -- ** Free variables + tyCoVarsOfCo, tyCoVarsOfCos, coVarsOfCo, + tyCoFVsOfCo, tyCoFVsOfCos, tyCoVarsOfCoDSet, + coercionSize, anyFreeVarsOfCo, + + -- ** Substitution + CvSubstEnv, emptyCvSubstEnv, + lookupCoVar, + substCo, substCos, substCoVar, substCoVars, substCoWith, + substCoVarBndr, + extendTvSubstAndInScope, getCvSubstEnv, + + -- ** Lifting + liftCoSubst, liftCoSubstTyVar, liftCoSubstWith, liftCoSubstWithEx, + emptyLiftingContext, extendLiftingContext, extendLiftingContextAndInScope, + liftCoSubstVarBndrUsing, isMappedByLC, extendLiftingContextCvSubst, + updateLCSubst, + + mkSubstLiftingContext, liftingContextSubst, zapLiftingContext, + lcLookupCoVar, lcInScopeSet, + + LiftCoEnv, LiftingContext(..), liftEnvSubstLeft, liftEnvSubstRight, + substRightCo, substLeftCo, swapLiftCoEnv, lcSubstLeft, lcSubstRight, + + -- ** Comparison + eqCoercion, eqCoercionX, + + -- ** Forcing evaluation of coercions + seqCo, + + -- * Pretty-printing + pprCo, pprParendCo, + pprCoAxiom, pprCoAxBranch, pprCoAxBranchLHS, + pprCoAxBranchUser, tidyCoAxBndrsForUser, + etaExpandCoAxBranch, + + -- * Tidying + tidyCo, tidyCos, + + -- * Other + promoteCoercion, buildCoercion, + + multToCo, mkRuntimeRepCo, + + hasCoercionHole, + setCoHoleType + ) where + +import {-# SOURCE #-} GHC.CoreToIface (toIfaceTyCon, tidyToIfaceTcArgs) + +import GHC.Prelude + +import GHC.Iface.Type +import GHC.Core.TyCo.Rep +import GHC.Core.TyCo.FVs +import GHC.Core.TyCo.Ppr +import GHC.Core.TyCo.Subst +import GHC.Core.TyCo.Tidy +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 +import GHC.Types.Var +import GHC.Types.Var.Env +import GHC.Types.Var.Set +import GHC.Types.Name hiding ( varName ) +import GHC.Types.Basic +import GHC.Types.Unique +import GHC.Data.FastString +import GHC.Data.Pair +import GHC.Types.SrcLoc +import GHC.Builtin.Names +import GHC.Builtin.Types.Prim +import GHC.Data.List.SetOps +import GHC.Data.Maybe +import GHC.Types.Unique.FM +import GHC.Data.List.Infinite (Infinite (..)) +import qualified GHC.Data.List.Infinite as Inf + +import GHC.Utils.Misc +import GHC.Utils.Outputable +import GHC.Utils.Panic + +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 + +{- +%************************************************************************ +%* * + -- The coercion arguments always *precisely* saturate + -- arity of (that branch of) the CoAxiom. If there are + -- any left over, we use AppCo. See + -- See [Coercion axioms applied to coercions] in GHC.Core.TyCo.Rep + +\subsection{Coercion variables} +%* * +%************************************************************************ +-} + +coVarName :: CoVar -> Name +coVarName = varName + +setCoVarUnique :: CoVar -> Unique -> CoVar +setCoVarUnique = setVarUnique + +setCoVarName :: CoVar -> Name -> CoVar +setCoVarName = setVarName + +{- +%************************************************************************ +%* * + Pretty-printing CoAxioms +%* * +%************************************************************************ + +Defined here to avoid module loops. CoAxiom is loaded very early on. + +-} + +etaExpandCoAxBranch :: CoAxBranch -> ([TyVar], [Type], Type) +-- Return the (tvs,lhs,rhs) after eta-expanding, +-- to the way in which the axiom was originally written +-- See Note [Eta reduction for data families] in GHC.Core.Coercion.Axiom +etaExpandCoAxBranch (CoAxBranch { cab_tvs = tvs + , cab_eta_tvs = eta_tvs + , cab_lhs = lhs + , cab_rhs = rhs }) + -- ToDo: what about eta_cvs? + = (tvs ++ eta_tvs, lhs ++ eta_tys, mkAppTys rhs eta_tys) + where + eta_tys = mkTyVarTys eta_tvs + +pprCoAxiom :: CoAxiom br -> SDoc +-- Used in debug-printing only +pprCoAxiom ax@(CoAxiom { co_ax_tc = tc, co_ax_branches = branches }) + = hang (text "axiom" <+> ppr ax) + 2 (braces $ vcat (map (pprCoAxBranchUser tc) (fromBranches branches))) + +pprCoAxBranchUser :: TyCon -> CoAxBranch -> SDoc +-- Used when printing injectivity errors (FamInst.reportInjectivityErrors) +-- and inaccessible branches (GHC.Tc.Validity.inaccessibleCoAxBranch) +-- This happens in error messages: don't print the RHS of a data +-- family axiom, which is meaningless to a user +pprCoAxBranchUser tc br + | isDataFamilyTyCon tc = pprCoAxBranchLHS tc br + | otherwise = pprCoAxBranch tc br + +pprCoAxBranchLHS :: TyCon -> CoAxBranch -> SDoc +-- Print the family-instance equation when reporting +-- a conflict between equations (FamInst.conflictInstErr) +-- For type families the RHS is important; for data families not so. +-- Indeed for data families the RHS is a mysterious internal +-- type constructor, so we suppress it (#14179) +-- See FamInstEnv Note [Family instance overlap conflicts] +pprCoAxBranchLHS = ppr_co_ax_branch pp_rhs + where + pp_rhs _ _ = empty + +pprCoAxBranch :: TyCon -> CoAxBranch -> SDoc +pprCoAxBranch = ppr_co_ax_branch ppr_rhs + where + ppr_rhs env rhs = equals <+> pprPrecTypeX env topPrec rhs + +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') :| + -- 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 + , ppUnless (null incomps) $ whenPprDebug $ + text "-- Incomps:" <+> vcat (map (pprCoAxBranch fam_tc) incomps) ] ) : + [] + where + incomps = coAxBranchIncomps branch + loc = coAxBranchSpan branch + pp_loc | isGoodSrcSpan loc = text "at" <+> ppr (srcSpanStart loc) + | otherwise = text "in" <+> ppr loc + + -- Eta-expand LHS and RHS types, because sometimes data family + -- instances are eta-reduced. + -- See Note [Eta reduction for data families] in GHC.Core.Coercion.Axiom. + (ee_tvs, ee_lhs, ee_rhs) = etaExpandCoAxBranch branch + + pp_lhs = pprIfaceTypeApp topPrec (toIfaceTyCon fam_tc) + (tidyToIfaceTcArgs tidy_env fam_tc ee_lhs) + + (tidy_env, bndrs') = tidyCoAxBndrsForUser emptyTidyEnv ee_tvs + +tidyCoAxBndrsForUser :: TidyEnv -> [Var] -> (TidyEnv, [Var]) +-- Tidy wildcards "_1", "_2" to "_", and do not return them +-- in the list of binders to be printed +-- This is so that in error messages we see +-- forall a. F _ [a] _ = ... +-- rather than +-- forall a _1 _2. F _1 [a] _2 = ... +-- +-- This is a rather disgusting function +-- See Note [Wildcard names] in GHC.Tc.Gen.HsType +tidyCoAxBndrsForUser init_env tcvs + = (tidy_env, reverse tidy_bndrs) + where + (tidy_env, tidy_bndrs) = foldl tidy_one (init_env, []) tcvs + + tidy_one (env@(occ_env, subst), rev_bndrs') bndr + | is_wildcard bndr = (env_wild, rev_bndrs') + | otherwise = (env', bndr' : rev_bndrs') + where + (env', bndr') = tidyVarBndr env bndr + env_wild = (occ_env, extendVarEnv subst bndr wild_bndr) + wild_bndr = setVarName bndr $ + tidyNameOcc (varName bndr) (mkTyVarOccFS (fsLit "_")) + -- Tidy the binder to "_" + + is_wildcard :: Var -> Bool + is_wildcard tv = case occNameString (getOccName tv) of + ('_' : rest) -> all isDigit rest + _ -> False + + +{- ********************************************************************* +* * + MCoercion +* * +********************************************************************* -} + +coToMCo :: Coercion -> MCoercion +-- Convert a coercion to a MCoercion, +-- It's not clear whether or not isReflexiveCo would be better here +-- See #19815 for a bit of data and discussion on this point +coToMCo co | isReflCo co = MRefl + | otherwise = MCo co + +checkReflexiveMCo :: MCoercion -> MCoercion +checkReflexiveMCo MRefl = MRefl +checkReflexiveMCo (MCo co) | isReflexiveCo co = MRefl + | otherwise = MCo co + +-- | Tests if this MCoercion is obviously generalized reflexive +-- Guaranteed to work very quickly. +isGReflMCo :: MCoercion -> Bool +isGReflMCo MRefl = True +isGReflMCo (MCo co) | isGReflCo co = True +isGReflMCo _ = False + +-- | Make a generalized reflexive coercion +mkGReflCo :: Role -> Type -> MCoercionN -> Coercion +mkGReflCo r ty mco + | isGReflMCo mco = if r == Nominal then Refl ty + 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 +mkTransMCo co1 MRefl = co1 +mkTransMCo (MCo co1) (MCo co2) = MCo (mkTransCo co1 co2) + +mkTransMCoL :: MCoercion -> Coercion -> MCoercion +mkTransMCoL MRefl co2 = coToMCo co2 +mkTransMCoL (MCo co1) co2 = MCo (mkTransCo co1 co2) + +mkTransMCoR :: Coercion -> MCoercion -> MCoercion +mkTransMCoR co1 MRefl = coToMCo co1 +mkTransMCoR co1 (MCo co2) = MCo (mkTransCo co1 co2) + +-- | Get the reverse of an 'MCoercion' +mkSymMCo :: MCoercion -> MCoercion +mkSymMCo MRefl = MRefl +mkSymMCo (MCo co) = MCo (mkSymCo co) + +-- | Cast a type by an 'MCoercion' +mkCastTyMCo :: Type -> MCoercion -> Type +mkCastTyMCo ty MRefl = ty +mkCastTyMCo ty (MCo co) = ty `mkCastTy` co + +mkPiMCos :: [Var] -> MCoercion -> MCoercion +mkPiMCos _ MRefl = MRefl +mkPiMCos vs (MCo co) = MCo (mkPiCos Representational vs co) + +mkFunResMCo :: Id -> MCoercionR -> MCoercionR +mkFunResMCo _ MRefl = MRefl +mkFunResMCo arg_id (MCo co) = MCo (mkFunResCo Representational arg_id co) + +mkGReflLeftMCo :: Role -> Type -> MCoercionN -> Coercion +mkGReflLeftMCo r ty MRefl = mkReflCo r ty +mkGReflLeftMCo r ty (MCo co) = mkGReflLeftCo r ty co + +mkGReflRightMCo :: Role -> Type -> MCoercionN -> Coercion +mkGReflRightMCo r ty MRefl = mkReflCo r ty +mkGReflRightMCo r ty (MCo co) = mkGReflRightCo r ty co + +-- | Like 'mkCoherenceRightCo', but with an 'MCoercion' +mkCoherenceRightMCo :: Role -> Type -> MCoercionN -> Coercion -> Coercion +mkCoherenceRightMCo _ _ MRefl co2 = co2 +mkCoherenceRightMCo r ty (MCo co) co2 = mkCoherenceRightCo r ty co co2 + +isReflMCo :: MCoercion -> Bool +isReflMCo MRefl = True +isReflMCo _ = False + +{- +%************************************************************************ +%* * + Destructing coercions +%* * +%************************************************************************ +-} + +-- | This breaks a 'Coercion' with type @T A B C ~ T D E F@ into +-- a list of 'Coercion's of kinds @A ~ D@, @B ~ E@ and @E ~ F@. Hence: +-- +-- > decomposeCo 3 c [r1, r2, r3] = [nth r1 0 c, nth r2 1 c, nth r3 2 c] +decomposeCo :: Arity -> Coercion + -> Infinite Role -- the roles of the output coercions + -> [Coercion] +decomposeCo arity co rs + = [mkSelCo (SelTyCon n r) co | (n,r) <- [0..(arity-1)] `zip` Inf.toList rs ] + -- Remember, SelTyCon is zero-indexed + +decomposeFunCo :: HasDebugCallStack + => Coercion -- Input coercion + -> (CoercionN, Coercion, Coercion) +-- Expects co :: (s1 %m1-> t1) ~ (s2 %m2-> t2) +-- Returns (cow :: m1 ~N m2, co1 :: s1~s2, co2 :: t1~t2) +-- actually cow will be a Phantom coercion if the input is a Phantom coercion + +decomposeFunCo (FunCo { fco_mult = w, fco_arg = co1, fco_res = co2 }) + = (w, co1, co2) + -- Short-circuits the calls to mkSelCo + +decomposeFunCo co + = assertPpr all_ok (ppr co) $ + ( mkSelCo (SelFun SelMult) co + , mkSelCo (SelFun SelArg) co + , mkSelCo (SelFun SelRes) co ) + where + Pair s1t1 s2t2 = coercionKind co + all_ok = isFunTy s1t1 && isFunTy s2t2 + +{- Note [Pushing a coercion into a pi-type] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we have this: + (f |> co) t1 .. tn +Then we want to push the coercion into the arguments, so as to make +progress. For example of why you might want to do so, see Note +[Respecting definitional equality] in GHC.Core.TyCo.Rep. + +This is done by decomposePiCos. Specifically, if + decomposePiCos co [t1,..,tn] = ([co1,...,cok], cor) +then + (f |> co) t1 .. tn = (f (t1 |> co1) ... (tk |> cok)) |> cor) t(k+1) ... tn + +Notes: + +* k can be smaller than n! That is decomposePiCos can return *fewer* + coercions than there are arguments (ie k < n), if the kind provided + doesn't have enough binders. + +* If there is a type error, we might see + (f |> co) t1 + where co :: (forall a. ty) ~ (ty1 -> ty2) + Here 'co' is insoluble, but we don't want to crash in decoposePiCos. + So decomposePiCos carefully tests both sides of the coercion to check + they are both foralls or both arrows. Not doing this caused #15343. +-} + +decomposePiCos :: HasDebugCallStack + => CoercionN -> Pair Type -- Coercion and its kind + -> [Type] + -> ([CoercionN], CoercionN) +-- See Note [Pushing a coercion into a pi-type] +decomposePiCos orig_co (Pair orig_k1 orig_k2) orig_args + = go [] (orig_subst,orig_k1) orig_co (orig_subst,orig_k2) orig_args + where + orig_subst = mkEmptySubst $ mkInScopeSet $ + tyCoVarsOfTypes orig_args `unionVarSet` tyCoVarsOfCo orig_co + + go :: [CoercionN] -- accumulator for argument coercions, reversed + -> (Subst,Kind) -- Lhs kind of coercion + -> CoercionN -- coercion originally applied to the function + -> (Subst,Kind) -- Rhs kind of coercion + -> [Type] -- Arguments to that function + -> ([CoercionN], Coercion) + -- Invariant: co :: subst1(k1) ~ subst2(k2) + + go acc_arg_cos (subst1,k1) co (subst2,k2) (ty:tys) + | Just (a, t1) <- splitForAllTyCoVar_maybe k1 + , Just (b, t2) <- splitForAllTyCoVar_maybe k2 + -- know co :: (forall a:s1.t1) ~ (forall b:s2.t2) + -- function :: forall a:s1.t1 (the function is not passed to decomposePiCos) + -- a :: s1 + -- b :: s2 + -- ty :: s2 + -- need arg_co :: s2 ~ s1 + -- res_co :: t1[ty |> arg_co / a] ~ t2[ty / b] + = let arg_co = mkSelCo SelForAll (mkSymCo co) + res_co = mkInstCo co (mkGReflLeftCo Nominal ty arg_co) + subst1' = extendTCvSubst subst1 a (ty `CastTy` arg_co) + subst2' = extendTCvSubst subst2 b ty + in + go (arg_co : acc_arg_cos) (subst1', t1) res_co (subst2', t2) tys + + | Just (af1, _w1, _s1, t1) <- splitFunTy_maybe k1 + , Just (af2, _w1, _s2, t2) <- splitFunTy_maybe k2 + , af1 == af2 -- Same sort of arrow + -- know co :: (s1 -> t1) ~ (s2 -> t2) + -- function :: s1 -> t1 + -- ty :: s2 + -- need arg_co :: s2 ~ s1 + -- res_co :: t1 ~ t2 + = let (_, sym_arg_co, res_co) = decomposeFunCo co + -- It should be fine to ignore the multiplicity bit + -- of the coercion for a Nominal coercion. + arg_co = mkSymCo sym_arg_co + in + go (arg_co : acc_arg_cos) (subst1,t1) res_co (subst2,t2) tys + + | not (isEmptyTCvSubst subst1) || not (isEmptyTCvSubst subst2) + = go acc_arg_cos (zapSubst subst1, substTy subst1 k1) + co + (zapSubst subst2, substTy subst1 k2) + (ty:tys) + + -- tys might not be empty, if the left-hand type of the original coercion + -- didn't have enough binders + go acc_arg_cos _ki1 co _ki2 _tys = (reverse acc_arg_cos, co) + +-- | Extract a covar, if possible. This check is dirty. Be ashamed +-- of yourself. (It's dirty because it cares about the structure of +-- a coercion, which is morally reprehensible.) +getCoVar_maybe :: Coercion -> Maybe CoVar +getCoVar_maybe (CoVarCo cv) = Just cv +getCoVar_maybe _ = Nothing + +multToCo :: Mult -> Coercion +multToCo r = mkNomReflCo r + +-- first result has role equal to input; third result is Nominal +splitAppCo_maybe :: Coercion -> Maybe (Coercion, Coercion) +-- ^ Attempt to take a coercion application apart. +splitAppCo_maybe (AppCo co arg) = Just (co, arg) +splitAppCo_maybe (TyConAppCo r tc args) + | args `lengthExceeds` tyConArity tc + , Just (args', arg') <- snocView args + = Just ( mkTyConAppCo r tc args', arg' ) + + | not (tyConMustBeSaturated tc) + -- Never create unsaturated type family apps! + , Just (args', arg') <- snocView args + , Just arg'' <- setNominalRole_maybe (tyConRole r tc (length args')) arg' + = Just ( mkTyConAppCo r tc args', arg'' ) + -- Use mkTyConAppCo to preserve the invariant + -- that identity coercions are always represented by Refl + +splitAppCo_maybe co + | Just (ty, r) <- isReflCo_maybe co + , Just (ty1, ty2) <- splitAppTy_maybe ty + = Just (mkReflCo r ty1, mkNomReflCo ty2) +splitAppCo_maybe _ = Nothing + +-- Only used in specialise/Rules +splitFunCo_maybe :: Coercion -> Maybe (Coercion, Coercion) +splitFunCo_maybe (FunCo { fco_arg = arg, fco_res = res }) = Just (arg, res) +splitFunCo_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, 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, 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, _, _) <- coVarTypesRole cv = ty1 +coVarRType cv | (_, ty2, _) <- coVarTypesRole cv = ty2 + +coVarTypes :: HasDebugCallStack => CoVar -> Pair Type +coVarTypes cv | (ty1, ty2, _) <- coVarTypesRole cv = Pair ty1 ty2 + +coVarTypesRole :: HasDebugCallStack => CoVar -> (Type,Type,Role) +coVarTypesRole cv + | Just (tc, [_,_,ty1,ty2]) <- splitTyConApp_maybe (varType cv) + = (ty1, ty2, eqTyConRole tc) + | otherwise + = pprPanic "coVarTypesRole, non coercion variable" + (ppr cv $$ ppr (varType cv)) + +coVarKind :: CoVar -> Type +coVarKind cv + = assert (isCoVar cv ) + varType cv + +coVarRole :: CoVar -> Role +coVarRole cv + = eqTyConRole (case tyConAppTyCon_maybe (varType cv) of + Just tc0 -> tc0 + Nothing -> pprPanic "coVarRole: not tyconapp" (ppr cv)) + +eqTyConRole :: TyCon -> Role +-- Given (~#) or (~R#) return the Nominal or Representational respectively +eqTyConRole tc + | tc `hasKey` eqPrimTyConKey + = Nominal + | tc `hasKey` eqReprPrimTyConKey + = Representational + | otherwise + = pprPanic "eqTyConRole: unknown tycon" (ppr tc) + +-- | Given a coercion `co :: (t1 :: TYPE r1) ~ (t2 :: TYPE r2)` +-- produce a coercion `rep_co :: r1 ~ r2` +-- But actually it is possible that +-- co :: (t1 :: CONSTRAINT r1) ~ (t2 :: CONSTRAINT r2) +-- or co :: (t1 :: TYPE r1) ~ (t2 :: CONSTRAINT r2) +-- or co :: (t1 :: CONSTRAINT r1) ~ (t2 :: TYPE r2) +-- See Note [mkRuntimeRepCo] +mkRuntimeRepCo :: HasDebugCallStack => Coercion -> Coercion +mkRuntimeRepCo co + = assert (isTYPEorCONSTRAINT k1 && isTYPEorCONSTRAINT k2) $ + mkSelCo (SelTyCon 0 Nominal) kind_co + where + kind_co = mkKindCo co -- kind_co :: TYPE r1 ~ TYPE r2 + Pair k1 k2 = coercionKind kind_co + +{- Note [mkRuntimeRepCo] +~~~~~~~~~~~~~~~~~~~~~~~~ +Given + class C a where { op :: Maybe a } +we will get an axiom + axC a :: (C a :: CONSTRAINT r1) ~ (Maybe a :: TYPE r2) +(See Note [Type and Constraint are not apart] in GHC.Builtin.Types.Prim.) + +Then we may call mkRuntimeRepCo on (axC ty), and that will return + mkSelCo (SelTyCon 0 Nominal) (Kind (axC ty)) :: r1 ~ r2 + +So mkSelCo needs to be happy with decomposing a coercion of kind + CONSTRAINT r1 ~ TYPE r2 + +Hence the use of `tyConIsTYPEorCONSTRAINT` in the assertion `good_call` +in `mkSelCo`. See #23018 for a concrete example. (In this context it's +important that TYPE and CONSTRAINT have the same arity and kind, not +merely that they are not-apart; otherwise SelCo would not make sense.) +-} + +isReflCoVar_maybe :: Var -> Maybe Coercion +-- If cv :: t~t then isReflCoVar_maybe cv = Just (Refl t) +-- Works on all kinds of Vars, not just CoVars +isReflCoVar_maybe cv + | isCoVar cv + , Pair ty1 ty2 <- coVarTypes cv + , ty1 `eqType` ty2 + = Just (mkReflCo (coVarRole cv) ty1) + | otherwise + = Nothing + +-- | Tests if this coercion is obviously a generalized reflexive coercion. +-- Guaranteed to work very quickly. +isGReflCo :: Coercion -> Bool +isGReflCo (GRefl{}) = True +isGReflCo (Refl{}) = True -- Refl ty == GRefl N ty MRefl +isGReflCo _ = False + +-- | Tests if this coercion is obviously reflexive. Guaranteed to work +-- very quickly. Sometimes a coercion can be reflexive, but not obviously +-- so. c.f. 'isReflexiveCo' +isReflCo :: Coercion -> Bool +isReflCo (Refl{}) = True +isReflCo (GRefl _ _ mco) | isGReflMCo mco = True +isReflCo _ = False + +-- | Returns the type coerced if this coercion is a generalized reflexive +-- coercion. Guaranteed to work very quickly. +isGReflCo_maybe :: Coercion -> Maybe (Type, Role) +isGReflCo_maybe (GRefl r ty _) = Just (ty, r) +isGReflCo_maybe (Refl ty) = Just (ty, Nominal) +isGReflCo_maybe _ = Nothing + +-- | Returns the type coerced if this coercion is reflexive. Guaranteed +-- to work very quickly. Sometimes a coercion can be reflexive, but not +-- obviously so. c.f. 'isReflexiveCo_maybe' +isReflCo_maybe :: Coercion -> Maybe (Type, Role) +isReflCo_maybe (Refl ty) = Just (ty, Nominal) +isReflCo_maybe (GRefl r ty mco) | isGReflMCo mco = Just (ty, r) +isReflCo_maybe _ = Nothing + +-- | Slowly checks if the coercion is reflexive. Don't call this in a loop, +-- as it walks over the entire coercion. +isReflexiveCo :: Coercion -> Bool +isReflexiveCo = isJust . isReflexiveCo_maybe + +-- | Extracts the coerced type from a reflexive coercion. This potentially +-- walks over the entire coercion, so avoid doing this in a loop. +isReflexiveCo_maybe :: Coercion -> Maybe (Type, Role) +isReflexiveCo_maybe (Refl ty) = Just (ty, Nominal) +isReflexiveCo_maybe (GRefl r ty mco) | isGReflMCo mco = Just (ty, r) +isReflexiveCo_maybe co + | ty1 `eqType` ty2 + = Just (ty1, r) + | otherwise + = Nothing + where (Pair ty1 ty2, r) = coercionKindRole co + + +{- +%************************************************************************ +%* * + Building coercions +%* * +%************************************************************************ + +These "smart constructors" maintain the invariants listed in the definition +of Coercion, and they perform very basic optimizations. + +Note [Role twiddling functions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +There are a plethora of functions for twiddling roles: + +mkSubCo: Requires a nominal input coercion and always produces a +representational output. This is used when you (the programmer) are sure you +know exactly that role you have and what you want. + +downgradeRole_maybe: This function takes both the input role and the output role +as parameters. (The *output* role comes first!) It can only *downgrade* a +role -- that is, change it from N to R or P, or from R to P. This one-way +behavior is why there is the "_maybe". If an upgrade is requested, this +function produces Nothing. This is used when you need to change the role of a +coercion, but you're not sure (as you're writing the code) of which roles are +involved. + +This function could have been written using coercionRole to ascertain the role +of the input. But, that function is recursive, and the caller of downgradeRole_maybe +often knows the input role. So, this is more efficient. + +downgradeRole: This is just like downgradeRole_maybe, but it panics if the +conversion isn't a downgrade. + +setNominalRole_maybe: This is the only function that can *upgrade* a coercion. +The result (if it exists) is always Nominal. The input can be at any role. It +works on a "best effort" basis, as it should never be strictly necessary to +upgrade a coercion during compilation. It is currently only used within GHC in +splitAppCo_maybe. In order to be a proper inverse of mkAppCo, the second +coercion that splitAppCo_maybe returns must be nominal. But, it's conceivable +that splitAppCo_maybe is operating over a TyConAppCo that uses a +representational coercion. Hence the need for setNominalRole_maybe. +splitAppCo_maybe, in turn, is used only within coercion optimization -- thus, +it is not absolutely critical that setNominalRole_maybe be complete. + +Note that setNominalRole_maybe will never upgrade a phantom UnivCo. Phantom +UnivCos are perfectly type-safe, whereas representational and nominal ones are +not. (Nominal ones are no worse than representational ones, so this function *will* +change a UnivCo Representational to a UnivCo Nominal.) + +Conal Elliott also came across a need for this function while working with the +GHC API, as he was decomposing Core casts. The Core casts use representational +coercions, as they must, but his use case required nominal coercions (he was +building a GADT). So, that's why this function is exported from this module. + +One might ask: shouldn't downgradeRole_maybe just use setNominalRole_maybe as +appropriate? I (Richard E.) have decided not to do this, because upgrading a +role is bizarre and a caller should have to ask for this behavior explicitly. + +-} + +-- | Make a reflexive coercion +mkReflCo :: Role -> Type -> Coercion +mkReflCo Nominal ty = Refl ty +mkReflCo r ty = GRefl r ty MRefl + +-- | Make a representational reflexive coercion +mkRepReflCo :: Type -> Coercion +mkRepReflCo ty = GRefl Representational ty MRefl + +-- | Make a nominal reflexive coercion +mkNomReflCo :: Type -> Coercion +mkNomReflCo = Refl + +-- | Apply a type constructor to a list of coercions. It is the +-- caller's responsibility to get the roles correct on argument coercions. +mkTyConAppCo :: HasDebugCallStack => Role -> TyCon -> [Coercion] -> Coercion +mkTyConAppCo r tc cos + | Just co <- tyConAppFunCo_maybe r tc cos + = co + + -- Expand type synonyms + | ExpandsSyn tv_co_prs rhs_ty leftover_cos <- expandSynTyCon_maybe tc cos + = mkAppCos (liftCoSubst r (mkLiftingContext tv_co_prs) rhs_ty) leftover_cos + + | Just tys_roles <- traverse isReflCo_maybe cos + = mkReflCo r (mkTyConApp tc (map fst tys_roles)) + -- See Note [Refl invariant] + + | otherwise = TyConAppCo r tc cos + +mkFunCoNoFTF :: HasDebugCallStack => Role -> CoercionN -> Coercion -> Coercion -> Coercion +-- This version of mkFunCo takes no FunTyFlags; it works them out +mkFunCoNoFTF r w arg_co res_co + = mkFunCo2 r afl afr w arg_co res_co + where + afl = chooseFunTyFlag argl_ty resl_ty + afr = chooseFunTyFlag argr_ty resr_ty + Pair argl_ty argr_ty = coercionKind arg_co + Pair resl_ty resr_ty = coercionKind res_co + +-- | Build a function 'Coercion' from two other 'Coercion's. That is, +-- given @co1 :: a ~ b@ and @co2 :: x ~ y@ produce @co :: (a -> x) ~ (b -> y)@ +-- or @(a => x) ~ (b => y)@, depending on the kind of @a@/@b@. +-- This (most common) version takes a single FunTyFlag, which is used +-- for both fco_afl and ftf_afr of the FunCo +mkFunCo :: Role -> FunTyFlag -> CoercionN -> Coercion -> Coercion -> Coercion +mkFunCo r af w arg_co res_co + = mkFunCo2 r af af w arg_co res_co + +mkNakedFunCo :: Role -> FunTyFlag -> CoercionN -> Coercion -> Coercion -> Coercion +-- This version of mkFunCo does not check FunCo invariants (checkFunCo) +-- It's a historical vestige; See Note [No assertion check on mkFunCo] +mkNakedFunCo = mkFunCo + +mkFunCo2 :: Role -> FunTyFlag -> FunTyFlag + -> CoercionN -> Coercion -> Coercion -> Coercion +-- This is the smart constructor for FunCo; it checks invariants +mkFunCo2 r afl afr w arg_co res_co + -- See Note [No assertion check on mkFunCo] + | Just (ty1, _) <- isReflCo_maybe arg_co + , Just (ty2, _) <- isReflCo_maybe res_co + , Just (w, _) <- isReflCo_maybe w + = mkReflCo r (mkFunTy afl w ty1 ty2) -- See Note [Refl invariant] + + | otherwise + = FunCo { fco_role = r, fco_afl = afl, fco_afr = afr + , fco_mult = w, fco_arg = arg_co, fco_res = res_co } + + +{- Note [No assertion check on mkFunCo] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We used to have a checkFunCo assertion on mkFunCo, but during typechecking +we can (legitimately) have not-full-zonked types or coercion variables, so +the assertion spuriously fails (test T11480b is a case in point). Lint +checks all these things anyway. + +We used to get around the problem by calling mkNakedFunCo from within the +typechecker, which dodged the assertion check. But then mkAppCo calls +mkTyConAppCo, which calls tyConAppFunCo_maybe, which calls mkFunCo. +Duplicating this stack of calls with "naked" versions of each seems too much. + +-- Commented out: see Note [No assertion check on mkFunCo] +checkFunCo :: Role -> FunTyFlag -> FunTyFlag + -> CoercionN -> Coercion -> Coercion + -> Maybe SDoc +-- Checks well-formed-ness for FunCo +-- Used only in assertions and Lint +{-# NOINLINE checkFunCo #-} +checkFunCo _r afl afr _w arg_co res_co + | not (ok argl_ty && ok argr_ty && ok resl_ty && ok resr_ty) + = Just (hang (text "Bad arg or res types") 2 pp_inputs) + + | afl == computed_afl + , afr == computed_afr + = Nothing + | otherwise + = Just (vcat [ text "afl (provided,computed):" <+> ppr afl <+> ppr computed_afl + , text "afr (provided,computed):" <+> ppr afr <+> ppr computed_afr + , pp_inputs ]) + where + computed_afl = chooseFunTyFlag argl_ty resl_ty + computed_afr = chooseFunTyFlag argr_ty resr_ty + Pair argl_ty argr_ty = coercionKind arg_co + Pair resl_ty resr_ty = coercionKind res_co + + pp_inputs = vcat [ pp_ty "argl" argl_ty, pp_ty "argr" argr_ty + , pp_ty "resl" resl_ty, pp_ty "resr" resr_ty + , text "arg_co:" <+> ppr arg_co + , text "res_co:" <+> ppr res_co ] + + ok ty = isTYPEorCONSTRAINT (typeKind ty) + pp_ty str ty = text str <> colon <+> hang (ppr ty) + 2 (dcolon <+> ppr (typeKind ty)) +-} + +-- | Apply a 'Coercion' to another 'Coercion'. +-- The second coercion must be Nominal, unless the first is Phantom. +-- If the first is Phantom, then the second can be either Phantom or Nominal. +mkAppCo :: Coercion -- ^ :: t1 ~r t2 + -> Coercion -- ^ :: s1 ~N s2, where s1 :: k1, s2 :: k2 + -> Coercion -- ^ :: t1 s1 ~r t2 s2 +mkAppCo co arg + | Just (ty1, r) <- isReflCo_maybe co + , Just (ty2, _) <- isReflCo_maybe arg + = mkReflCo r (mkAppTy ty1 ty2) + + | Just (ty1, r) <- isReflCo_maybe co + , Just (tc, tys) <- splitTyConApp_maybe ty1 + -- Expand type synonyms; a TyConAppCo can't have a type synonym (#9102) + = mkTyConAppCo r tc (zip_roles (tyConRolesX r tc) tys) + where + zip_roles (Inf r1 _) [] = [downgradeRole r1 Nominal arg] + zip_roles (Inf r1 rs) (ty1:tys) = mkReflCo r1 ty1 : zip_roles rs tys + +mkAppCo (TyConAppCo r tc args) arg + = case r of + Nominal -> mkTyConAppCo Nominal tc (args ++ [arg]) + Representational -> mkTyConAppCo Representational tc (args ++ [arg']) + where new_role = tyConRolesRepresentational tc Inf.!! length args + arg' = downgradeRole new_role Nominal arg + Phantom -> mkTyConAppCo Phantom tc (args ++ [toPhantomCo arg]) +mkAppCo co arg = AppCo co arg +-- Note, mkAppCo is careful to maintain invariants regarding +-- where Refl constructors appear; see the comments in the definition +-- of Coercion and the Note [Refl invariant] in GHC.Core.TyCo.Rep. + +-- | Applies multiple 'Coercion's to another 'Coercion', from left to right. +-- See also 'mkAppCo'. +mkAppCos :: Coercion + -> [Coercion] + -> Coercion +mkAppCos co1 cos = foldl' mkAppCo co1 cos + + +-- | 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) + + | otherwise + = mkForAllCo_NoRefl v visL visR kind_co co + +-- 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)) + +-- | 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 + +-- | 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 + + | otherwise + = 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 + + 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 ] + + +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 + = ForAllCo { fco_tcv = tv, fco_visL = visL, fco_visR = visR + , fco_kind = kind_co, fco_body = co } + + +mkCoVarCo :: CoVar -> Coercion +-- cv :: s ~# t +-- See Note [mkCoVarCo] +mkCoVarCo cv = CoVarCo cv + +mkCoVarCos :: [CoVar] -> [Coercion] +mkCoVarCos = map mkCoVarCo + +{- Note [mkCoVarCo] +~~~~~~~~~~~~~~~~~~~ +In the past, mkCoVarCo optimised (c :: t~t) to (Refl t). That is +valid (although see Note [Unbound RULE binders] in GHC.Core.Rules), but +it's a relatively expensive test and perhaps better done in +optCoercion. Not a big deal either way. +-} + +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 +-- Only called with BranchedAxiom or UnbranchedAxiom +mkAxInstCo role axr tys cos + | arity == n_tys = downgradeRole role ax_role $ + AxiomCo axr (rtys `chkAppend` cos) + | otherwise = assert (arity < n_tys) $ + downgradeRole role ax_role $ + mkAppCos (AxiomCo axr (ax_args `chkAppend` cos)) + leftover_args + where + (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 +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 (UnbranchedAxiom ax) tys cos + +mkAxInstRHS :: CoAxiom br -> BranchIndex -> [Type] -> [Coercion] -> Type +-- Instantiate the axiom with specified types, +-- returning the instantiated RHS +-- A companion to mkAxInstCo: +-- mkAxInstRhs ax index tys = snd (coercionKind (mkAxInstCo ax index tys)) +mkAxInstRHS ax index tys cos + = assert (tvs `equalLength` tys1) $ + mkAppTys rhs' tys2 + where + branch = coAxiomNthBranch ax index + tvs = coAxBranchTyVars branch + cvs = coAxBranchCoVars branch + (tys1, tys2) = splitAtList tvs tys + rhs' = substTyWith tvs tys1 $ + substTyWithCoVars cvs cos $ + coAxBranchRHS branch + +mkUnbranchedAxInstRHS :: CoAxiom Unbranched -> [Type] -> [Coercion] -> Type +mkUnbranchedAxInstRHS ax = mkAxInstRHS ax 0 + +-- | Return the left-hand type of the axiom, when the axiom is instantiated +-- at the types given. +mkAxInstLHS :: CoAxiom br -> BranchIndex -> [Type] -> [Coercion] -> Type +mkAxInstLHS ax index tys cos + = assert (tvs `equalLength` tys1) $ + mkTyConApp fam_tc (lhs_tys `chkAppend` tys2) + where + branch = coAxiomNthBranch ax index + tvs = coAxBranchTyVars branch + cvs = coAxBranchCoVars branch + (tys1, tys2) = splitAtList tvs tys + lhs_tys = substTysWith tvs tys1 $ + substTysWithCoVars cvs cos $ + coAxBranchLHS branch + fam_tc = coAxiomTyCon ax + +-- | Instantiate the left-hand side of an unbranched axiom +mkUnbranchedAxInstLHS :: CoAxiom Unbranched -> [Type] -> [Coercion] -> Type +mkUnbranchedAxInstLHS ax = mkAxInstLHS ax 0 + +-- | Make a coercion from a coercion hole +mkHoleCo :: CoercionHole -> Coercion +mkHoleCo h = HoleCo h + +-- | 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 deps role ty1 ty2 + | ty1 `eqType` ty2 = mkReflCo role ty1 + | 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, 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 + +-- | 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 +-- Note [mkSelCo precondition] +mkSelCo_maybe cs co + = assertPpr (good_call cs) bad_call_msg $ + go cs co + where + + 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) + -- If co :: (forall a1:t1 ~ t2. t1) ~ (forall a2:t3 ~ t4. t2) + -- then (nth SelForAll co :: (t1 ~ t2) ~N (t3 ~ t4)) + + go (SelFun fs) (FunCo _ _ _ w arg res) + = Just (getNthFun fs w arg res) + + go (SelTyCon i r) (TyConAppCo r0 tc arg_cos) + = assertPpr (r == tyConRole r0 tc i) + (vcat [ ppr tc, ppr arg_cos, ppr r0, ppr i, ppr r ]) $ + Just (arg_cos `getNth` i) + + go cs (SymCo co) -- Recurse, hoping to get to a TyConAppCo or FunCo + = do { co' <- go cs co; return (mkSymCo co') } + + 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. + + | 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 + , text "cs =" <+> ppr cs + , text "coercion role =" <+> ppr (coercionRole co) ] + + -- good_call checks the typing rules given in Note [SelCo] + good_call SelForAll + | Just (_tv1, _) <- splitForAllTyCoVar_maybe ty1 + , Just (_tv2, _) <- splitForAllTyCoVar_maybe ty2 + = True + + good_call (SelFun {}) + = isFunTy ty1 && isFunTy ty2 + + good_call (SelTyCon n r) + | Just (tc1, tys1) <- splitTyConApp_maybe ty1 + , Just (tc2, tys2) <- splitTyConApp_maybe ty2 + , let { len1 = length tys1 + ; len2 = length tys2 } + = (tc1 == tc2 || (tyConIsTYPEorCONSTRAINT tc1 && tyConIsTYPEorCONSTRAINT tc2)) + -- tyConIsTYPEorCONSTRAINT: see Note [mkRuntimeRepCo] + && len1 == len2 + && n < len1 + && r == tyConRole (coercionRole co) tc1 n + + 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 + -> a -- ^ argument + -> a -- ^ result + -> a -- ^ One of the above three +getNthFun SelMult mult _ _ = mult +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 + = mkReflCo eq (pickLR lr (splitAppTy ty)) + | otherwise + = LRCo lr co + +-- | Instantiates a 'Coercion'. +-- Works for both tyvar and covar +mkInstCo :: Coercion -> CoercionN -> Coercion +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@, +-- produces @co' :: ty ~r (ty |> co)@ +mkGReflRightCo :: Role -> Type -> CoercionN -> Coercion +mkGReflRightCo r ty co + | isGReflCo co = mkReflCo r ty + -- the kinds of @k1@ and @k2@ are the same, thus @isGReflCo@ + -- instead of @isReflCo@ + | otherwise = mkGReflMCo r ty co + +-- | Given @r@, @ty :: k1@, and @co :: k1 ~N k2@, +-- produces @co' :: (ty |> co) ~r ty@ +mkGReflLeftCo :: Role -> Type -> CoercionN -> Coercion +mkGReflLeftCo r ty co + | isGReflCo co = mkReflCo r ty + -- the kinds of @k1@ and @k2@ are the same, thus @isGReflCo@ + -- instead of @isReflCo@ + | otherwise = mkSymCo $ mkGReflMCo r ty co + +-- | Given @ty :: k1@, @co :: k1 ~ k2@, @co2:: ty ~r ty'@, +-- produces @co' :: (ty |> co) ~r ty' +-- It is not only a utility function, but it saves allocation when co +-- is a GRefl coercion. +mkCoherenceLeftCo :: Role -> Type -> CoercionN -> Coercion -> Coercion +mkCoherenceLeftCo r ty co co2 + | isGReflCo co = 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 :: HasDebugCallStack => Role -> Type -> CoercionN -> Coercion -> Coercion +mkCoherenceRightCo r ty co co2 + | isGReflCo co = co2 + | 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 co + | Pair ty1 ty2 <- coercionKind co + -- 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 + tk2 = typeKind ty2 + , tk1 `eqType` tk2 + = Refl tk1 + | otherwise + = KindCo co + +mkSubCo :: HasDebugCallStack => Coercion -> Coercion +-- Input coercion is Nominal, result is Representational +-- see also Note [Role twiddling functions] +mkSubCo (Refl ty) = GRefl Representational ty MRefl +mkSubCo (GRefl Nominal ty co) = GRefl Representational ty co +mkSubCo (TyConAppCo Nominal tc cos) + = TyConAppCo Representational tc (applyRoles tc cos) +mkSubCo co@(FunCo { fco_role = Nominal, fco_arg = arg, fco_res = res }) + = co { fco_role = Representational + , fco_arg = downgradeRole Representational Nominal arg + , fco_res = downgradeRole Representational Nominal res } +mkSubCo co = assertPpr (coercionRole co == Nominal) (ppr co <+> ppr (coercionRole co)) $ + SubCo co + +-- | Changes a role, but only a downgrade. See Note [Role twiddling functions] +downgradeRole_maybe :: Role -- ^ desired role + -> Role -- ^ current role + -> Coercion -> Maybe Coercion +-- In (downgradeRole_maybe dr cr co) it's a precondition that +-- cr = coercionRole co + +downgradeRole_maybe Nominal Nominal co = Just co +downgradeRole_maybe Nominal _ _ = Nothing + +downgradeRole_maybe Representational Nominal co = Just (mkSubCo co) +downgradeRole_maybe Representational Representational co = Just co +downgradeRole_maybe Representational Phantom _ = Nothing + +downgradeRole_maybe Phantom Phantom co = Just co +downgradeRole_maybe Phantom _ co = Just (toPhantomCo co) + +-- | Like 'downgradeRole_maybe', but panics if the change isn't a downgrade. +-- See Note [Role twiddling functions] +downgradeRole :: Role -- desired role + -> Role -- current role + -> Coercion -> Coercion +downgradeRole r1 r2 co + = case downgradeRole_maybe r1 r2 co of + Just co' -> co' + Nothing -> pprPanic "downgradeRole" (ppr co) + +-- | Make a "coercion between coercions". +mkProofIrrelCo :: Role -- ^ role of the created coercion, "r" + -> CoercionN -- ^ :: phi1 ~N phi2 + -> Coercion -- ^ g1 :: phi1 + -> Coercion -- ^ g2 :: phi2 + -> Coercion -- ^ :: g1 ~r g2 + +-- if the two coercion prove the same fact, I just don't care what +-- 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) + +{- +%************************************************************************ +%* * + Roles +%* * +%************************************************************************ +-} + +-- | Converts a coercion to be nominal, if possible. +-- See Note [Role twiddling functions] +setNominalRole_maybe :: Role -- of input coercion + -> Coercion -> Maybe CoercionN +setNominalRole_maybe r co + | r == Nominal = Just co + | otherwise = setNominalRole_maybe_helper co + where + setNominalRole_maybe_helper (SubCo co) = Just co + setNominalRole_maybe_helper co@(Refl _) = Just co + setNominalRole_maybe_helper (GRefl _ ty co) = Just $ GRefl Nominal ty co + setNominalRole_maybe_helper (TyConAppCo Representational tc cos) + = do { cos' <- zipWithM setNominalRole_maybe (tyConRoleListX Representational tc) cos + ; return $ TyConAppCo Nominal tc cos' } + setNominalRole_maybe_helper co@(FunCo { fco_role = Representational + , fco_arg = co1, fco_res = co2 }) + = do { co1' <- setNominalRole_maybe Representational co1 + ; co2' <- setNominalRole_maybe Representational co2 + ; return $ co { fco_role = Nominal, fco_arg = co1', fco_res = co2' } + } + setNominalRole_maybe_helper (SymCo co) + = SymCo <$> setNominalRole_maybe_helper co + setNominalRole_maybe_helper (TransCo co1 co2) + = 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 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! + case cs of + SelTyCon n _r -> + -- Remember to update the role in SelTyCon to nominal; + -- not doing this caused #23362. + -- See the typing rule in Note [SelCo] in GHC.Core.TyCo.Rep. + SelCo (SelTyCon n Nominal) <$> setNominalRole_maybe (coercionRole co) co + SelFun fs -> + SelCo (SelFun fs) <$> setNominalRole_maybe (coercionRole co) co + SelForAll -> + 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 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 +-- in must be a nominal coercion between the kinds of the +-- types. +mkPhantomCo :: Coercion -> Type -> Type -> Coercion +mkPhantomCo h t1 t2 + = mkUnivCo PhantomProv [h] Phantom t1 t2 + +-- takes any coercion and turns it into a Phantom coercion +toPhantomCo :: Coercion -> Coercion +toPhantomCo co + = mkPhantomCo (mkKindCo co) ty1 ty2 + where Pair ty1 ty2 = coercionKind co + +-- Convert args to a TyConAppCo Nominal to the same TyConAppCo Representational +applyRoles :: TyCon -> [Coercion] -> [Coercion] +applyRoles = zipWith (`downgradeRole` Nominal) . tyConRoleListRepresentational + +-- The Role parameter is the Role of the TyConAppCo +-- defined here because this is intimately concerned with the implementation +-- of TyConAppCo +-- Always returns an infinite list (with a infinite tail of Nominal) +tyConRolesX :: Role -> TyCon -> Infinite Role +tyConRolesX Representational tc = tyConRolesRepresentational tc +tyConRolesX role _ = Inf.repeat role + +tyConRoleListX :: Role -> TyCon -> [Role] +tyConRoleListX role = Inf.toList . tyConRolesX role + +-- Returns the roles of the parameters of a tycon, with an infinite tail +-- of Nominal +tyConRolesRepresentational :: TyCon -> Infinite Role +tyConRolesRepresentational tc = tyConRoles tc Inf.++ Inf.repeat Nominal + +-- Returns the roles of the parameters of a tycon, with an infinite tail +-- of Nominal +tyConRoleListRepresentational :: TyCon -> [Role] +tyConRoleListRepresentational = Inf.toList . tyConRolesRepresentational + +tyConRole :: Role -> TyCon -> Int -> Role +tyConRole Nominal _ _ = Nominal +tyConRole Phantom _ _ = Phantom +tyConRole Representational tc n = tyConRolesRepresentational tc Inf.!! n + +funRole :: Role -> FunSel -> Role +funRole Nominal _ = Nominal +funRole Phantom _ = Phantom +funRole Representational fs = funRoleRepresentational fs + +funRoleRepresentational :: FunSel -> Role +funRoleRepresentational SelMult = Nominal +funRoleRepresentational SelArg = Representational +funRoleRepresentational SelRes = Representational + +ltRole :: Role -> Role -> Bool +-- Is one role "less" than another? +-- Nominal < Representational < Phantom +ltRole Phantom _ = False +ltRole Representational Phantom = True +ltRole Representational _ = False +ltRole Nominal Nominal = False +ltRole Nominal _ = True + +------------------------------- + +-- | like mkKindCo, but aggressively & recursively optimizes to avoid using +-- a KindCo constructor. The output role is nominal. +promoteCoercion :: HasDebugCallStack => Coercion -> CoercionN + +-- First cases handles anything that should yield refl. +promoteCoercion co = case co of + + Refl _ -> mkNomReflCo ki1 + + GRefl _ _ MRefl -> mkNomReflCo ki1 + + GRefl _ _ (MCo co) -> co + + _ | ki1 `eqType` ki2 + -> mkNomReflCo (typeKind ty1) + -- No later branch should return refl + -- The assert (False )s throughout + -- are these cases explicitly, but they should never fire. + + TyConAppCo _ tc args + | Just co' <- instCoercions (mkNomReflCo (tyConKind tc)) args + -> co' + | otherwise + -> mkKindCo co + + AppCo co1 arg + | Just co' <- instCoercion (coercionKind (mkKindCo co1)) + (promoteCoercion co1) arg + -> co' + | otherwise + -> mkKindCo co + + ForAllCo { fco_tcv = tv, fco_body = g } + | isTyVar tv + -> promoteCoercion g + + ForAllCo {} + -> assert False $ + -- (ForAllCo {} :: (forall cv.t1) ~ (forall cv.t2) + -- The tyvar case is handled above, so the bound var is a + -- 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. 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 + 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) + + TransCo co1 co2 + -> mkTransCo (promoteCoercion co1) (promoteCoercion co2) + + SelCo n co1 + | Just co' <- mkSelCo_maybe n co1 + -> promoteCoercion co' + + | otherwise + -> mkKindCo co + + LRCo lr co1 + | Just (lco, rco) <- splitAppCo_maybe co1 + -> case lr of + CLeft -> promoteCoercion lco + CRight -> promoteCoercion rco + + | otherwise + -> mkKindCo co + + InstCo g _ + | isForAllTy_ty ty1 + -> assert (isForAllTy_ty ty2) $ + promoteCoercion g + | otherwise + -> assert False $ + mkNomReflCo liftedTypeKind + -- See Note [Weird typing rule for ForAllTy] in GHC.Core.TyCo.Rep + + KindCo _ + -> assert False $ -- See the first equation above + mkNomReflCo liftedTypeKind + + SubCo g + -> promoteCoercion g + + where + Pair ty1 ty2 = coercionKind co + ki1 = typeKind ty1 + ki2 = typeKind ty2 + +-- | say @g = promoteCoercion h@. Then, @instCoercion g w@ yields @Just g'@, +-- where @g' = promoteCoercion (h w)@. +-- fails if this is not possible, if @g@ coerces between a forall and an -> +-- or if second parameter has a representational role and can't be used +-- with an InstCo. +instCoercion :: Pair Type -- g :: lty ~ rty + -> CoercionN -- ^ must be nominal + -> Coercion + -> Maybe CoercionN +instCoercion (Pair lty rty) g w + | (isForAllTy_ty lty && isForAllTy_ty rty) + || (isForAllTy_co lty && isForAllTy_co rty) + , Just w' <- setNominalRole_maybe (coercionRole w) w + -- g :: (forall t1. t2) ~ (forall t1. t3) + -- w :: s1 ~ s2 + -- returns mkInstCo g w' :: t2 [t1 |-> s1 ] ~ t3 [t1 |-> s2] + = Just $ mkInstCo g w' + + | isFunTy lty && isFunTy rty + -- g :: (t1 -> t2) ~ (t3 -> t4) + -- returns t2 ~ t4 + = Just $ mkSelCo (SelFun SelRes) g -- extract result type + + | otherwise -- one forall, one funty... + = Nothing + +-- | Repeated use of 'instCoercion' +instCoercions :: CoercionN -> [Coercion] -> Maybe CoercionN +instCoercions g ws + = let arg_ty_pairs = map coercionKind ws in + snd <$> foldM go (coercionKind g, g) (zip arg_ty_pairs ws) + where + go :: (Pair Type, Coercion) -> (Pair Type, Coercion) + -> Maybe (Pair Type, Coercion) + go (g_tys, g) (w_tys, w) + = do { g' <- instCoercion g_tys g w + ; return (piResultTy <$> g_tys <*> w_tys, g') } + +-- | Creates a new coercion with both of its types casted by different casts +-- @castCoercionKind2 g r t1 t2 h1 h2@, where @g :: t1 ~r t2@, +-- has type @(t1 |> h1) ~r (t2 |> h2)@. +-- @h1@ and @h2@ must be nominal. +castCoercionKind2 :: Coercion -> Role -> Type -> Type + -> CoercionN -> CoercionN -> Coercion +castCoercionKind2 g r t1 t2 h1 h2 + = mkCoherenceRightCo r t2 h2 (mkCoherenceLeftCo r t1 h1 g) + +-- | @castCoercionKind1 g r t1 t2 h@ = @coercionKind g r t1 t2 h h@ +-- That is, it's a specialised form of castCoercionKind, where the two +-- kind coercions are identical +-- @castCoercionKind1 g r t1 t2 h@, where @g :: t1 ~r t2@, +-- has type @(t1 |> h) ~r (t2 |> h)@. +-- @h@ must be nominal. +-- See Note [castCoercionKind1] +castCoercionKind1 :: Coercion -> Role -> Type -> Type + -> CoercionN -> Coercion +castCoercionKind1 g r t1 t2 h + = case g of + Refl {} -> assert (r == Nominal) $ -- Refl is always Nominal + mkNomReflCo (mkCastTy t2 h) + GRefl _ _ mco -> case mco of + MRefl -> mkReflCo r (mkCastTy t2 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 +-- @castCoercionKind g h1 h2@, where @g :: t1 ~r t2@, +-- has type @(t1 |> h1) ~r (t2 |> h2)@. +-- @h1@ and @h2@ must be nominal. +-- It calls @coercionKindRole@, so it's quite inefficient (which 'I' stands for) +-- Use @castCoercionKind2@ instead if @t1@, @t2@, and @r@ are known beforehand. +castCoercionKind :: Coercion -> CoercionN -> CoercionN -> Coercion +castCoercionKind g h1 h2 + = castCoercionKind2 g r t1 t2 h1 h2 + where + (Pair t1 t2, r) = coercionKindRole g + +mkPiCos :: Role -> [Var] -> Coercion -> Coercion +mkPiCos r vs co = foldr (mkPiCo r) co vs + +-- | 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 [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 + -- want it to be r. It is only called in 'mkPiCos', which is + -- only used in GHC.Core.Opt.Simplify.Utils, where we are sure for + -- now (Aug 2018) v won't occur in co. + mkFunResCo r v co + | otherwise = mkFunResCo r v co + +mkFunResCo :: Role -> Id -> Coercion -> Coercion +-- Given res_co :: res1 ~ res2, +-- mkFunResCo r m arg res_co :: (arg -> res1) ~r (arg -> res2) +-- Reflexive in the multiplicity argument +mkFunResCo role id res_co + = mkFunCoNoFTF role mult arg_co res_co + where + arg_co = mkReflCo role (varType 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 +-- Lifted and unlifted equalities take different numbers of arguments, +-- so we have to make sure to supply the right parameter to decomposeCo. +-- Also, note that the role of the first coercion is the same as the role of +-- the equalities related by the second coercion. The second coercion is +-- itself always representational. +mkCoCast :: Coercion -> CoercionR -> Coercion +mkCoCast c g + | (g2:g1:_) <- reverse co_list + = mkSymCo g1 `mkTransCo` c `mkTransCo` g2 + + | otherwise + = pprPanic "mkCoCast" (ppr g $$ ppr (coercionKind g)) + where + -- g :: (s1 ~# t1) ~# (s2 ~# t2) + -- g1 :: s1 ~# s2 + -- g2 :: t1 ~# t2 + (tc, _) = splitTyConApp (coercionLKind g) + co_list = decomposeCo (tyConArity tc) g (tyConRolesRepresentational tc) + +{- Note [castCoercionKind1] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +castCoercionKind1 deals with the very important special case of castCoercionKind2 +where the two kind coercions are identical. In that case we can exploit the +situation where the main coercion is reflexive, via the special cases for Refl +and GRefl. + +This is important when rewriting (ty |> co). We rewrite ty, yielding + fco :: ty ~ ty' +and now we want a coercion xco between + xco :: (ty |> co) ~ (ty' |> co) +That's exactly what castCoercionKind1 does. And it's very very common for +fco to be Refl. In that case we do NOT want to get some terrible composition +of mkLeftCoherenceCo and mkRightCoherenceCo, which is what castCoercionKind2 +has to do in its full generality. See #18413. +-} + +{- +%************************************************************************ +%* * + Newtypes +%* * +%************************************************************************ +-} + +-- | If `instNewTyCon_maybe T ts = Just (rep_ty, co)` +-- then `co :: T ts ~R# rep_ty` +-- +-- Checks for a newtype, and for being saturated +instNewTyCon_maybe :: TyCon -> [Type] -> Maybe (Type, Coercion) +instNewTyCon_maybe tc tys + | Just (tvs, ty, co_tc) <- unwrapNewTyConEtad_maybe tc -- Check for newtype + , tvs `leLength` tys -- Check saturated enough + = Just (applyTysX tvs ty tys, mkUnbranchedAxInstCo Representational co_tc tys []) + | otherwise + = Nothing + +{- +************************************************************************ +* * + Type normalisation +* * +************************************************************************ +-} + +-- | A function to check if we can reduce a type by one step. Used +-- with 'topNormaliseTypeX'. +type NormaliseStepper ev = RecTcChecker + -> TyCon -- tc + -> [Type] -- tys + -> NormaliseStepResult ev + +-- | The result of stepping in a normalisation function. +-- See 'topNormaliseTypeX'. +data NormaliseStepResult ev + = NS_Done -- ^ Nothing more to do + | NS_Abort -- ^ Utter failure. The outer function should fail too. + | NS_Step RecTcChecker Type ev -- ^ We stepped, yielding new bits; + -- ^ ev is evidence; + -- Usually a co :: old type ~ new type + deriving (Functor) + +instance Outputable ev => Outputable (NormaliseStepResult ev) where + ppr NS_Done = text "NS_Done" + ppr NS_Abort = text "NS_Abort" + ppr (NS_Step _ ty ev) = sep [text "NS_Step", ppr ty, ppr ev] + +-- | Try one stepper and then try the next, if the first doesn't make +-- progress. +-- So if it returns NS_Done, it means that both steppers are satisfied +composeSteppers :: NormaliseStepper ev -> NormaliseStepper ev + -> NormaliseStepper ev +composeSteppers step1 step2 rec_nts tc tys + = case step1 rec_nts tc tys of + success@(NS_Step {}) -> success + NS_Done -> step2 rec_nts tc tys + NS_Abort -> NS_Abort + +-- | A 'NormaliseStepper' that unwraps newtypes, careful not to fall into +-- a loop. If it would fall into a loop, it produces 'NS_Abort'. +unwrapNewTypeStepper :: NormaliseStepper Coercion +unwrapNewTypeStepper rec_nts tc tys + | Just (ty', co) <- instNewTyCon_maybe tc tys + = -- pprTrace "unNS" (ppr tc <+> ppr (getUnique tc) <+> ppr tys $$ ppr ty' $$ ppr rec_nts) $ + case checkRecTc rec_nts tc of + Just rec_nts' -> NS_Step rec_nts' ty' co + Nothing -> NS_Abort + + | otherwise + = NS_Done + +-- | A general function for normalising the top-level of a type. It continues +-- to use the provided 'NormaliseStepper' until that function fails, and then +-- this function returns. The roles of the coercions produced by the +-- 'NormaliseStepper' must all be the same, which is the role returned from +-- the call to 'topNormaliseTypeX'. +-- +-- Typically ev is Coercion. +-- +-- If topNormaliseTypeX step plus ty = Just (ev, ty') +-- then ty ~ev1~ t1 ~ev2~ t2 ... ~evn~ ty' +-- and ev = ev1 `plus` ev2 `plus` ... `plus` evn +-- If it returns Nothing then no newtype unwrapping could happen +topNormaliseTypeX :: NormaliseStepper ev + -> (ev -> ev -> ev) + -> Type -> Maybe (ev, Type) +topNormaliseTypeX stepper plus ty + | Just (tc, tys) <- splitTyConApp_maybe ty + -- SPJ: The default threshold for initRecTc is 100 which is extremely dangerous + -- for certain type synonyms, we should think about reducing it (see #20990) + , NS_Step rec_nts ty' ev <- stepper initRecTc tc tys + = go rec_nts ev ty' + | otherwise + = Nothing + where + go rec_nts ev ty + | Just (tc, tys) <- splitTyConApp_maybe ty + = case stepper rec_nts tc tys of + NS_Step rec_nts' ty' ev' -> go rec_nts' (ev `plus` ev') ty' + NS_Done -> Just (ev, ty) + NS_Abort -> Nothing + + | otherwise + = Just (ev, ty) + +topNormaliseNewType_maybe :: Type -> Maybe (Coercion, Type) +-- ^ Sometimes we want to look through a @newtype@ and get its associated coercion. +-- This function strips off @newtype@ layers enough to reveal something that isn't +-- a @newtype@. Specifically, here's the invariant: +-- +-- > topNormaliseNewType_maybe rec_nts ty = Just (co, ty') +-- +-- then (a) @co : ty ~R ty'@. +-- (b) ty' is not a newtype. +-- +-- The function returns @Nothing@ for non-@newtypes@, +-- or unsaturated applications +-- +-- This function does *not* look through type families, because it has no access to +-- the type family environment. If you do have that at hand, consider to use +-- topNormaliseType_maybe, which should be a drop-in replacement for +-- topNormaliseNewType_maybe +-- If topNormliseNewType_maybe ty = Just (co, ty'), then co : ty ~R ty' +topNormaliseNewType_maybe ty + = topNormaliseTypeX unwrapNewTypeStepper mkTransCo ty + +{- +%************************************************************************ +%* * + Comparison of coercions +%* * +%************************************************************************ +-} + +-- | Syntactic equality of coercions +eqCoercion :: Coercion -> Coercion -> Bool +eqCoercion = eqType `on` coercionType + +-- | Compare two 'Coercion's, with respect to an RnEnv2 +eqCoercionX :: RnEnv2 -> Coercion -> Coercion -> Bool +eqCoercionX env = eqTypeX env `on` coercionType + +{- +%************************************************************************ +%* * + "Lifting" substitution + [(TyCoVar,Coercion)] -> Type -> Coercion +%* * +%************************************************************************ + +Note [Lifting coercions over types: liftCoSubst] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The KPUSH rule deals with this situation + data T a = K (a -> Maybe a) + g :: T t1 ~ T t2 + x :: t1 -> Maybe t1 + + case (K @t1 x) |> g of + K (y:t2 -> Maybe t2) -> rhs + +We want to push the coercion inside the constructor application. +So we do this + + g' :: t1~t2 = SelCo (SelTyCon 0) g + + case K @t2 (x |> g' -> Maybe g') of + K (y:t2 -> Maybe t2) -> rhs + +The crucial operation is that we + * take the type of K's argument: a -> Maybe a + * and substitute g' for a +thus giving *coercion*. This is what liftCoSubst does. + +In the presence of kind coercions, this is a bit +of a hairy operation. So, we refer you to the paper introducing kind coercions, +available at www.cis.upenn.edu/~sweirich/papers/fckinds-extended.pdf + +Note [extendLiftingContextEx] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider we have datatype + K :: /\k. /\a::k. P -> T k -- P be some type + g :: T k1 ~ T k2 + + case (K @k1 @t1 x) |> g of + K y -> rhs + +We want to push the coercion inside the constructor application. +We first get the coercion mapped by the universal type variable k: + lc = k |-> SelCo (SelTyCon 0) g :: k1~k2 + +Here, the important point is that the kind of a is coerced, and P might be +dependent on the existential type variable a. +Thus we first get the coercion of a's kind + g2 = liftCoSubst lc k :: k1 ~ k2 + +Then we store a new mapping into the lifting context + lc2 = a |-> (t1 ~ t1 |> g2), lc + +So later when we can correctly deal with the argument type P + liftCoSubst lc2 P :: P [k|->k1][a|->t1] ~ P[k|->k2][a |-> (t1|>g2)] + +This is exactly what extendLiftingContextEx does. +* For each (tyvar:k, ty) pair, we product the mapping + tyvar |-> (ty ~ ty |> (liftCoSubst lc k)) +* For each (covar:s1~s2, ty) pair, we produce the mapping + covar |-> (co ~ co') + co' = Sym (liftCoSubst lc s1) ;; covar ;; liftCoSubst lc s2 :: s1'~s2' + +This follows the lifting context extension definition in the +"FC with Explicit Kind Equality" paper. +-} + +-- ---------------------------------------------------- +-- See Note [Lifting coercions over types: liftCoSubst] +-- ---------------------------------------------------- + +data LiftingContext = LC Subst LiftCoEnv + -- in optCoercion, we need to lift when optimizing InstCo. + -- See Note [Optimising InstCo] in GHC.Core.Coercion.Opt + -- We thus propagate the substitution from GHC.Core.Coercion.Opt here. + +instance Outputable LiftingContext where + ppr (LC _ env) = hang (text "LiftingContext:") 2 (ppr env) + +type LiftCoEnv = VarEnv Coercion + -- Maps *type variables* to *coercions*. + -- That's the whole point of this function! + -- Also maps coercion variables to ProofIrrelCos. + +-- like liftCoSubstWith, but allows for existentially-bound types as well +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 -> 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 tvs cos) ty + +-- | @liftCoSubst role lc ty@ produces a coercion (at role @role@) +-- that coerces between @lc_left(ty)@ and @lc_right(ty)@, where +-- @lc_left@ is a substitution mapping type variables to the left-hand +-- types of the mapped coercions in @lc@, and similar for @lc_right@. +liftCoSubst :: HasDebugCallStack => Role -> LiftingContext -> Type -> Coercion +{-# INLINE liftCoSubst #-} +-- Inlining this function is worth 2% of allocation in T9872d, +liftCoSubst r lc@(LC subst env) ty + | isEmptyVarEnv env = mkReflCo r (substTy subst ty) + | otherwise = ty_co_subst lc r ty + +emptyLiftingContext :: InScopeSet -> LiftingContext +emptyLiftingContext in_scope = LC (mkEmptySubst in_scope) emptyVarEnv + +mkLiftingContext :: [(TyCoVar,Coercion)] -> LiftingContext +mkLiftingContext pairs + = LC (mkEmptySubst $ mkInScopeSet $ tyCoVarsOfCos (map snd pairs)) + (mkVarEnv pairs) + +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... + -> Coercion -- ^ ...to this lifted version + -> LiftingContext + -- mappings to reflexive coercions are just substitutions +extendLiftingContext (LC subst env) tv arg + | Just (ty, _) <- isReflCo_maybe arg + = LC (extendTCvSubst subst tv ty) env + | 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... + -> Coercion -- ^ to this coercion + -> LiftingContext +extendLiftingContextAndInScope (LC subst env) tv co + = extendLiftingContext (LC (extendSubstInScopeSet subst (tyCoVarsOfCo co)) env) tv co + +-- | Extend a lifting context with existential-variable bindings. +-- See Note [extendLiftingContextEx] +extendLiftingContextEx :: LiftingContext -- ^ original lifting context + -> [(TyCoVar,Type)] -- ^ ex. var / value pairs + -> LiftingContext +-- Note that this is more involved than extendLiftingContext. That function +-- takes a coercion to extend with, so it's assumed that the caller has taken +-- into account any of the kind-changing stuff worried about here. +extendLiftingContextEx lc [] = lc +extendLiftingContextEx lc@(LC subst env) ((v,ty):rest) +-- This function adds bindings for *Nominal* coercions. Why? Because it +-- works with existentially bound variables, which are considered to have +-- nominal roles. + | isTyVar v + = let lc' = LC (subst `extendSubstInScopeSet` tyCoVarsOfType ty) + (extendVarEnv env v $ + mkGReflRightCo Nominal + ty + (ty_co_subst lc Nominal (tyVarKind v))) + in extendLiftingContextEx lc' rest + | CoercionTy co <- ty + = -- co :: s1 ~r s2 + -- lift_s1 :: s1 ~r s1' + -- lift_s2 :: s2 ~r s2' + -- kco :: (s1 ~r s2) ~N (s1' ~r s2') + assert (isCoVar 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) + [ mkKindCo lift_s1, mkKindCo lift_s2 + , lift_s1 , lift_s2 ] + lc' = LC (subst `extendSubstInScopeSet` tyCoVarsOfCo co) + (extendVarEnv env v + (mkProofIrrelCo Nominal kco co $ + (mkSymCo lift_s1) `mkTransCo` co `mkTransCo` lift_s2)) + in extendLiftingContextEx lc' rest + | otherwise + = pprPanic "extendLiftingContextEx" (ppr v <+> text "|->" <+> ppr ty) + + +-- | Erase the environments in a lifting context +zapLiftingContext :: LiftingContext -> LiftingContext +zapLiftingContext (LC subst _) = LC (zapSubst subst) emptyVarEnv + +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', res) = upd subst + +-- | The \"lifting\" operation which substitutes coercions for type +-- variables in a type to produce a coercion. +-- +-- For the inverse operation, see 'liftCoMatch' +ty_co_subst :: LiftingContext -> Role -> Type -> Coercion +ty_co_subst !lc role ty + -- !lc: making this function strict in lc allows callers to + -- pass its two components separately, rather than boxing them. + -- Unfortunately, Boxity Analysis concludes that we need lc boxed + -- because it's used that way in liftCoSubstTyVarBndrUsing. + = go role ty + where + go :: Role -> Type -> Coercion + go r ty | Just ty' <- coreView ty + = go r ty' + go Phantom ty = lift_phantom ty + 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 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 + -- (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 + go r (CastTy ty co) = castCoercionKind (go r ty) (substLeftCo lc co) + (substRightCo lc co) + go r (CoercionTy co) = mkProofIrrelCo r kco (substLeftCo lc co) + (substRightCo lc co) + where kco = go Nominal (coercionType co) + + lift_phantom ty = mkPhantomCo (go Nominal (typeKind ty)) + (substTy (lcSubstLeft lc) ty) + (substTy (lcSubstRight lc) ty) + +{- +Note [liftCoSubstTyVar] +~~~~~~~~~~~~~~~~~~~~~~~~~ +This function can fail if a coercion in the environment is of too low a role. + +liftCoSubstTyVar is called from two places: in liftCoSubst (naturally), and +also in matchAxiom in GHC.Core.Coercion.Opt. From liftCoSubst, the so-called lifting +lemma guarantees that the roles work out. If we fail in this +case, we really should panic -- something is deeply wrong. But, in matchAxiom, +failing is fine. matchAxiom is trying to find a set of coercions +that match, but it may fail, and this is healthy behavior. +-} + +-- See Note [liftCoSubstTyVar] +liftCoSubstTyVar :: LiftingContext -> Role -> TyVar -> Maybe Coercion +liftCoSubstTyVar (LC subst env) r v + | Just co_arg <- lookupVarEnv env v + = downgradeRole_maybe r (coercionRole co_arg) co_arg + + | otherwise + = Just $ mkReflCo r (substTyVar subst v) + +{- Note [liftCoSubstVarBndr] + ~~~~~~~~~~~~~~~~~~~~~~~~~ +callback: + 'liftCoSubstVarBndrUsing' needs to be general enough to work in two + situations: + + - in this module, which manipulates 'Coercion's, and + - in GHC.Core.FamInstEnv, where we work with 'Reduction's, which contain + a coercion as well as a type. + + To achieve this, we require that the return type of the 'callback' function + contain a coercion within it. This is witnessed by the first argument + to 'liftCoSubstVarBndrUsing': a getter, which allows us to retrieve + the coercion inside the return type. Thus: + + - in this module, we simply pass 'id' as the getter, + - in GHC.Core.FamInstEnv, we pass 'reductionCoercion' as the getter. + +liftCoSubstTyVarBndrUsing: + Given + forall tv:k. t + We want to get + forall (tv:k1) (kind_co :: k1 ~ k2) body_co + + We lift the kind k to get the kind_co + kind_co = ty_co_subst k :: k1 ~ k2 + + Now in the LiftingContext, we add the new mapping + tv |-> (tv :: k1) ~ ((tv |> kind_co) :: k2) + +liftCoSubstCoVarBndrUsing: + Given + forall cv:(s1 ~ s2). t + We want to get + forall (cv:s1'~s2') (kind_co :: (s1'~s2') ~ (t1 ~ t2)) body_co + + We lift s1 and s2 respectively to get + eta1 :: s1' ~ t1 + eta2 :: s2' ~ t2 + And + kind_co = TyConAppCo Nominal (~#) eta1 eta2 + + Now in the liftingContext, we add the new mapping + cv |-> (cv :: s1' ~ s2') ~ ((sym eta1;cv;eta2) :: t1 ~ t2) +-} + +-- See Note [liftCoSubstVarBndr] +liftCoSubstVarBndr :: LiftingContext -> TyCoVar + -> (LiftingContext, TyCoVar, Coercion) +liftCoSubstVarBndr lc tv + = liftCoSubstVarBndrUsing id callback lc tv + where + callback lc' ty' = ty_co_subst lc' Nominal ty' + +-- the callback must produce a nominal coercion +liftCoSubstVarBndrUsing :: (r -> CoercionN) -- ^ coercion getter + -> (LiftingContext -> Type -> r) -- ^ callback + -> LiftingContext -> TyCoVar + -> (LiftingContext, TyCoVar, r) +liftCoSubstVarBndrUsing view_co fun lc old_var + | isTyVar old_var + = liftCoSubstTyVarBndrUsing view_co fun lc old_var + | otherwise + = liftCoSubstCoVarBndrUsing view_co fun lc old_var + +-- Works for tyvar binder +liftCoSubstTyVarBndrUsing :: (r -> CoercionN) -- ^ coercion getter + -> (LiftingContext -> Type -> r) -- ^ callback + -> LiftingContext -> TyVar + -> (LiftingContext, TyVar, r) +liftCoSubstTyVarBndrUsing view_co fun lc@(LC subst cenv) old_var + = assert (isTyVar old_var) $ + ( LC (subst `extendSubstInScope` new_var) new_cenv + , new_var, stuff ) + where + old_kind = tyVarKind old_var + stuff = fun lc old_kind + eta = view_co stuff + k1 = coercionLKind eta + new_var = uniqAway (substInScopeSet subst) (setVarType old_var k1) + + lifted = mkGReflRightCo Nominal (TyVarTy new_var) eta + -- :: new_var ~ new_var |> eta + new_cenv = extendVarEnv cenv old_var lifted + +-- Works for covar binder +liftCoSubstCoVarBndrUsing :: (r -> CoercionN) -- ^ coercion getter + -> (LiftingContext -> Type -> r) -- ^ callback + -> LiftingContext -> CoVar + -> (LiftingContext, CoVar, r) +liftCoSubstCoVarBndrUsing view_co fun lc@(LC subst cenv) old_var + = assert (isCoVar old_var) $ + ( LC (subst `extendSubstInScope` new_var) new_cenv + , new_var, stuff ) + where + old_kind = coVarKind old_var + stuff = fun lc old_kind + eta = view_co stuff + k1 = coercionLKind eta + new_var = uniqAway (substInScopeSet subst) (setVarType old_var k1) + + -- old_var :: s1 ~r s2 + -- eta :: (s1' ~r s2') ~N (t1 ~r t2) + -- eta1 :: s1' ~r t1 + -- eta2 :: s2' ~r t2 + -- co1 :: s1' ~r s2' + -- co2 :: t1 ~r t2 + -- lifted :: co1 ~N co2 + + role = coVarRole old_var + eta' = downgradeRole role Nominal eta + eta1 = mkSelCo (SelTyCon 2 role) eta' + eta2 = mkSelCo (SelTyCon 3 role) eta' + + co1 = mkCoVarCo new_var + co2 = mkSymCo eta1 `mkTransCo` co1 `mkTransCo` eta2 + lifted = mkProofIrrelCo Nominal eta co1 co2 + + new_cenv = extendVarEnv cenv old_var lifted + +-- | Is a var in the domain of a lifting context? +isMappedByLC :: TyCoVar -> LiftingContext -> Bool +isMappedByLC tv (LC _ env) = tv `elemVarEnv` env + +-- If [a |-> g] is in the substitution and g :: t1 ~ t2, substitute a for t1 +-- If [a |-> (g1, g2)] is in the substitution, substitute a for g1 +substLeftCo :: LiftingContext -> Coercion -> Coercion +substLeftCo lc co + = substCo (lcSubstLeft lc) co + +-- Ditto, but for t2 and g2 +substRightCo :: LiftingContext -> Coercion -> Coercion +substRightCo lc co + = substCo (lcSubstRight lc) co + +-- | Apply "sym" to all coercions in a 'LiftCoEnv' +swapLiftCoEnv :: LiftCoEnv -> LiftCoEnv +swapLiftCoEnv = mapVarEnv mkSymCo + +lcSubstLeft :: LiftingContext -> Subst +lcSubstLeft (LC subst lc_env) = liftEnvSubstLeft subst lc_env + +lcSubstRight :: LiftingContext -> Subst +lcSubstRight (LC subst lc_env) = liftEnvSubstRight subst lc_env + +liftEnvSubstLeft :: Subst -> LiftCoEnv -> Subst +liftEnvSubstLeft = liftEnvSubst pFst + +liftEnvSubstRight :: Subst -> LiftCoEnv -> Subst +liftEnvSubstRight = liftEnvSubst pSnd + +liftEnvSubst :: (forall a. Pair a -> a) -> Subst -> LiftCoEnv -> Subst +liftEnvSubst selector subst lc_env + = composeTCvSubst (Subst in_scope emptyIdSubstEnv tenv cenv) subst + where + pairs = nonDetUFMToList lc_env + -- It's OK to use nonDetUFMToList here because we + -- immediately forget the ordering by creating + -- a VarEnv + (tpairs, cpairs) = partitionWith ty_or_co pairs + -- Make sure the in-scope set is wide enough to cover the range of the + -- substitution (#22235). + in_scope = mkInScopeSet $ + tyCoVarsOfTypes (map snd tpairs) `unionVarSet` + tyCoVarsOfCos (map snd cpairs) + tenv = mkVarEnv_Directly tpairs + cenv = mkVarEnv_Directly cpairs + + ty_or_co :: (Unique, Coercion) -> Either (Unique, Type) (Unique, Coercion) + ty_or_co (u, co) + | Just equality_co <- isCoercionTy_maybe equality_ty + = Right (u, equality_co) + | otherwise + = Left (u, equality_ty) + where + equality_ty = selector (coercionKind co) + +-- | 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 _) = substInScopeSet subst + +{- +%************************************************************************ +%* * + Sequencing on coercions +%* * +%************************************************************************ +-} + +seqMCo :: MCoercion -> () +seqMCo MRefl = () +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 (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 [] = () +seqCos (co:cos) = seqCo co `seq` seqCos cos + +{- +%************************************************************************ +%* * + The kind of a type, and of a coercion +%* * +%************************************************************************ +-} + +{- 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 + +-- | Get a coercion's kind and role. +coercionKindRole :: Coercion -> (Pair Type, Role) +coercionKindRole co = (coercionKind co, coercionRole co) + +coercionType :: Coercion -> Type +coercionType co = case coercionKindRole co of + (Pair ty1 ty2, r) -> mkCoercionType r ty1 ty2 + +------------------ +-- | If it is the case that +-- +-- > c :: (t1 ~ t2) +-- +-- i.e. the kind of @c@ relates @t1@ and @t2@, then @coercionKind c = Pair t1 t2@. + +coercionKind :: HasDebugCallStack => Coercion -> Pair Type +-- See Note [coercionKind performance] +coercionKind co = Pair (coercionLKind co) (coercionRKind 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 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 (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 + + ------------- + 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 + + ------------- + check_bif_res _ (Just (Pair lhs rhs)) = pickLR which (lhs,rhs) + check_bif_res axr Nothing = crash axr + + crash :: CoAxiomRule -> Type + crash axr = pprPanic "coercionKind" (ppr axr) + + ------------- + 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 + 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_right subst (ForAllCo { fco_tcv = tv1, fco_visR = visR + , fco_kind = k_co, fco_body = co }) + -- See Note [Nested ForAllCos] + | isTyVar tv1 + = mkForAllTy (Bndr tv2 visR) (go_forall_right subst' co) + where + k2 = coercionRKind k_co + tv2 = setTyVarKind tv1 (substTy subst k2) + subst' | isGReflCo k_co = extendSubstInScope subst tv1 + -- kind_co always has kind @Type@, thus @isGReflCo@ + | otherwise = extendTvSubst (extendSubstInScope subst tv2) tv1 $ + TyVarTy tv2 `mkCastTy` mkSymCo k_co + + go_forall_right subst (ForAllCo { fco_tcv = cv1, fco_visR = visR + , fco_kind = k_co, fco_body = co }) + | isCoVar cv1 + = mkTyCoForAllTy cv2 visR (go_forall_right subst' co) + where + k2 = coercionRKind k_co + r = coVarRole cv1 + k_co' = downgradeRole r Nominal k_co + eta1 = mkSelCo (SelTyCon 2 r) k_co' + eta2 = mkSelCo (SelTyCon 3 r) k_co' + + -- k_co :: (t1 ~r t2) ~N (s1 ~r s2) + -- k1 = t1 ~r t2 + -- k2 = s1 ~r s2 + -- cv1 :: t1 ~r t2 + -- cv2 :: s1 ~r s2 + -- eta1 :: t1 ~r s1 + -- eta2 :: t2 ~r s2 + -- n_subst = (eta1 ; cv2 ; sym eta2) :: t1 ~r t2 + + cv2 = setVarType cv1 (substTy subst k2) + n_subst = eta1 `mkTransCo` (mkCoVarCo cv2) `mkTransCo` (mkSymCo eta2) + subst' | isReflCo k_co = extendSubstInScope subst cv1 + | otherwise = extendCvSubst (extendSubstInScope subst cv2) + cv1 n_subst + + 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. + +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. + +Note [Nested InstCos] +~~~~~~~~~~~~~~~~~~~~~ +In #5631 we found that 70% of the entire compilation time was +being spent in coercionKind! The reason was that we had + (g @ ty1 @ ty2 .. @ ty100) -- The "@s" are InstCos +where + g :: forall a1 a2 .. a100. phi +If we deal with the InstCos one at a time, we'll do this: + 1. Find the kind of (g @ ty1 .. @ ty99) : forall a100. phi' + 2. Substitute phi'[ ty100/a100 ], a single tyvar->type subst +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 = mkNomEqPred +mkCoercionType Representational = mkReprEqPred +mkCoercionType Phantom = \ty1 ty2 -> + let ki1 = typeKind ty1 + ki2 = typeKind ty2 + in + TyConApp eqPhantPrimTyCon [ki1, ki2, 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 :: 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 + | Just ty2' <- coreView ty2 = go ty1 ty2' + + go (CastTy ty1 co) ty2 + = let co' = go ty1 ty2 + r = coercionRole co' + in mkCoherenceLeftCo r ty1 co co' + + go ty1 (CastTy ty2 co) + = let co' = go ty1 ty2 + r = coercionRole co' + in mkCoherenceRightCo r ty2 co co' + + go ty1@(TyVarTy tv1) _tyvarty + = assert (case _tyvarty of + { TyVarTy tv2 -> tv1 == tv2 + ; _ -> False }) $ + mkNomReflCo ty1 + + 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 }) + = assert (af1 == af2) $ + mkFunCo Nominal af1 (go w1 w2) (go arg1 arg2) (go res1 res2) + + go (TyConApp tc1 args1) (TyConApp tc2 args2) + = 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 + | Just (ty2a, ty2b) <- splitAppTyNoView_maybe ty2 + = mkAppCo (go ty1a ty2a) (go ty1b ty2b) + + go ty1 (AppTy ty2a ty2b) + | Just (ty1a, ty1b) <- splitAppTyNoView_maybe ty1 + = mkAppCo (go ty1a ty2a) (go ty1b ty2b) + + go (ForAllTy (Bndr tv1 flag1) ty1) (ForAllTy (Bndr tv2 flag2) ty2) + | isTyVar tv1 + = assert (isTyVar tv2) $ + 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) + = assert (isCoVar cv1 && isCoVar cv2) $ + mkForAllCo cv1 flag1 flag2 kind_co (go ty1 ty2') + where s1 = varType cv1 + s2 = varType cv2 + kind_co = go s1 s2 + + -- s1 = t1 ~r t2 + -- s2 = t3 ~r t4 + -- kind_co :: (t1 ~r t2) ~N (t3 ~r t4) + -- eta1 :: t1 ~r t3 + -- eta2 :: t2 ~r t4 + + r = coVarRole cv1 + kind_co' = downgradeRole r Nominal kind_co + eta1 = mkSelCo (SelTyCon 2 r) kind_co' + eta2 = mkSelCo (SelTyCon 3 r) kind_co' + + subst = mkEmptySubst $ mkInScopeSet $ + tyCoVarsOfType ty2 `unionVarSet` tyCoVarsOfCo kind_co + ty2' = substTy (extendCvSubst subst cv2 $ mkSymCo eta1 `mkTransCo` + mkCoVarCo cv1 `mkTransCo` + eta2) + ty2 + + go ty1@(LitTy lit1) _lit2 + = assert (case _lit2 of + { LitTy lit2 -> lit1 == lit2 + ; _ -> False }) $ + mkNomReflCo ty1 + + go (CoercionTy co1) (CoercionTy co2) + = mkProofIrrelCo Nominal kind_co co1 co2 + where + kind_co = go (coercionType co1) (coercionType co2) + + go ty1 ty2 + = pprPanic "buildKindCoercion" (vcat [ ppr orig_ty1, ppr orig_ty2 + , ppr ty1, ppr ty2 ]) + + +{- +%************************************************************************ +%* * + Coercion holes +%* * +%************************************************************************ +-} + +has_co_hole_ty :: Type -> Monoid.Any +(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 = \_ _ -> Monoid.Any True + , 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 -mkFunCo1 :: HasDebugCallStack => Role -> FunTyFlag -> CoercionN -> Coercion -> Coercion -> Coercion -mkNakedFunCo1 :: Role -> FunTyFlag -> CoercionN -> Coercion -> Coercion -> Coercion -mkFunCo2 :: HasDebugCallStack => Role -> FunTyFlag -> FunTyFlag -> CoercionN -> 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,24 +33,24 @@ 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 + isGReflCo :: Coercion -> Bool 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 -data LiftingContext -liftCoSubst :: HasDebugCallStack => Role -> LiftingContext -> Type -> Coercion 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 @@ -236,43 +251,49 @@ -- INVARIANT: co_ax_implicit == True implies length co_ax_branches == 1. } +-- | A branch of a coercion axiom, which provides the evidence for +-- unwrapping a newtype or a type-family reduction step using a single equation. data CoAxBranch = CoAxBranch - { cab_loc :: SrcSpan -- Location of the defining equation - -- See Note [CoAxiom locations] - , cab_tvs :: [TyVar] -- Bound type variables; not necessarily fresh - -- See Note [CoAxBranch type variables] - , cab_eta_tvs :: [TyVar] -- Eta-reduced tyvars - -- cab_tvs and cab_lhs may be eta-reduced; see - -- Note [Eta reduction for data families] - , cab_cvs :: [CoVar] -- Bound coercion variables - -- Always empty, for now. - -- See Note [Constraints in patterns] - -- in GHC.Tc.TyCl - , cab_roles :: [Role] -- See Note [CoAxBranch roles] - , cab_lhs :: [Type] -- Type patterns to match against - , cab_rhs :: Type -- Right-hand side of the equality - -- See Note [CoAxioms are homogeneous] - , cab_incomps :: [CoAxBranch] -- The previous incompatible branches - -- See Note [Storing compatibility] + { cab_loc :: SrcSpan + -- ^ Location of the defining equation + -- See Note [CoAxiom locations] + , cab_tvs :: [TyVar] + -- ^ Bound type variables; not necessarily fresh + -- See Note [CoAxBranch type variables] + , cab_eta_tvs :: [TyVar] + -- ^ Eta-reduced tyvars + -- cab_tvs and cab_lhs may be eta-reduced; see + -- Note [Eta reduction for data families] + , cab_cvs :: [CoVar] + -- ^ Bound coercion variables + -- Always empty, for now. + -- See Note [Constraints in patterns] + -- in GHC.Tc.TyCl + , cab_roles :: [Role] + -- ^ See Note [CoAxBranch roles] + , cab_lhs :: [Type] + -- ^ Type patterns to match against + , cab_rhs :: Type + -- ^ Right-hand side of the equality + -- See Note [CoAxioms are homogeneous] + , cab_incomps :: [CoAxBranch] + -- ^ The previous incompatible branches + -- See Note [Storing compatibility] } 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 @@ -287,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 @@ -294,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 @@ -535,6 +560,11 @@ 3 -> return Phantom _ -> panic ("get Role " ++ show tag) +instance NFData Role where + rnf Nominal = () + rnf Representational = () + rnf Phantom = () + {- ************************************************************************ * * @@ -543,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 @@ -4,1273 +4,1510 @@ module GHC.Core.Coercion.Opt ( optCoercion - , checkAxInstCo - , OptCoercionOpts (..) - ) -where - -import GHC.Prelude - -import GHC.Tc.Utils.TcType ( exactTyCoVarsOfType ) - -import GHC.Core.TyCo.Rep -import GHC.Core.TyCo.Subst -import GHC.Core.TyCo.Compare( eqType ) -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.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 ) - -{- -%************************************************************************ -%* * - Optimising coercions -%* * -%************************************************************************ - -This module does coercion optimisation. See the paper - - Evidence normalization in Systtem FV (RTA'13) - https://simon.peytonjones.org/evidence-normalization/ - -The paper is also in the GHC repo, in docs/opt-coercion. - -Note [Optimising coercion optimisation] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Looking up a coercion's role or kind is linear in the size of the -coercion. Thus, doing this repeatedly during the recursive descent -of coercion optimisation is disastrous. We must be careful to avoid -doing this if at all possible. - -Because it is generally easy to know a coercion's components' roles -from the role of the outer coercion, we pass down the known role of -the input in the algorithm below. We also keep functions opt_co2 -and opt_co3 separate from opt_co4, so that the former two do Phantom -checks that opt_co4 can avoid. This is a big win because Phantom coercions -rarely appear within non-phantom coercions -- only in some TyConAppCos -and some AxiomInstCos. We handle these cases specially by calling -opt_co2. - -Note [Optimising InstCo] -~~~~~~~~~~~~~~~~~~~~~~~~ -(1) tv is a type variable -When we have (InstCo (ForAllCo tv h g) g2), we want to optimise. - -Let's look at the typing rules. - -h : k1 ~ k2 -tv:k1 |- g : t1 ~ t2 ------------------------------ -ForAllCo tv h g : (all tv:k1.t1) ~ (all tv:k2.t2[tv |-> tv |> sym h]) - -g1 : (all tv:k1.t1') ~ (all tv:k2.t2') -g2 : s1 ~ s2 --------------------- -InstCo g1 g2 : t1'[tv |-> s1] ~ t2'[tv |-> s2] - -We thus want some coercion proving this: - - (t1[tv |-> s1]) ~ (t2[tv |-> s2 |> sym h]) - -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. - -(2) cv is a coercion variable -Now consider we have (InstCo (ForAllCo cv h g) g2), we want to optimise. - -h : (t1 ~r t2) ~N (t3 ~r t4) -cv : t1 ~r t2 |- g : t1' ~r2 t2' -n1 = nth r 2 (downgradeRole r N h) :: t1 ~r t3 -n2 = nth r 3 (downgradeRole r N h) :: t2 ~r t4 ------------------------------------------------- -ForAllCo cv h g : (all cv:t1 ~r t2. t1') ~r2 - (all cv:t3 ~r t4. t2'[cv |-> n1 ; cv ; sym n2]) - -g1 : (all cv:t1 ~r t2. t1') ~ (all cv: t3 ~r t4. t2') -g2 : h1 ~N h2 -h1 : t1 ~r t2 -h2 : t3 ~r t4 ------------------------------------------------- -InstCo g1 g2 : t1'[cv |-> h1] ~ t2'[cv |-> h2] - -We thus want some coercion proving this: - - t1'[cv |-> h1] ~ t2'[cv |-> n1 ; h2; sym n2] - -So we substitute the coercion variable c for the coercion -(h1 ~N (n1; h2; sym n2)) in g. --} - --- | Coercion optimisation options -newtype OptCoercionOpts = OptCoercionOpts - { optCoercionEnabled :: Bool -- ^ Enable coercion optimisation (reduce its size) - } - -optCoercion :: OptCoercionOpts -> Subst -> Coercion -> NormalCo --- ^ optCoercion applies a substitution to a coercion, --- *and* optimises it to reduce its size -optCoercion opts env co - | optCoercionEnabled opts - = optCoercion' env co -{- - = pprTrace "optCoercion {" (text "Co:" <+> ppr co) $ - let result = optCoercion' env co in - pprTrace "optCoercion }" (vcat [ text "Co:" <+> ppr co - , text "Optco:" <+> ppr result ]) $ - result --} - - | otherwise - = substCo env co - - -optCoercion' :: Subst -> Coercion -> NormalCo -optCoercion' env co - | debugIsOn - = let out_co = opt_co1 lc False co - (Pair in_ty1 in_ty2, in_role) = coercionKindRole co - (Pair out_ty1 out_ty2, out_role) = coercionKindRole out_co - 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 - - | otherwise = opt_co1 lc False co - where - lc = mkSubstLiftingContext env - ppr_one cv = ppr cv <+> dcolon <+> ppr (coVarKind cv) - - -type NormalCo = Coercion - -- Invariants: - -- * The substitution has been fully applied - -- * For trans coercions (co1 `trans` co2) - -- co1 is not a trans, and neither co1 nor co2 is identity - -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 - -> 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 - -> 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 - --- See Note [Optimising coercion optimisation] --- | Optimize a coercion, knowing the coercion's non-Phantom role. -opt_co3 :: LiftingContext -> SymFlag -> 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 - -- 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 - --- 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_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 _ 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 - -opt_co4 env _ 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 - -opt_co4 env sym rep r (GRefl _r ty (MCo co)) - = 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) - where - r' = chooseRole rep r - ty' = substTy (lcSubstLeft env) ty - co' = opt_co4 env False False Nominal co - -opt_co4 env sym rep r (SymCo co) = opt_co4_wrap env (not 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) - = assert (r == _r) $ - case (rep, r) of - (True, Nominal) -> - mkTyConAppCo Representational tc - (zipWith3 (opt_co3 env sym) - (map Just (tyConRoleListRepresentational tc)) - (repeat Nominal) - cos) - (False, Nominal) -> - mkTyConAppCo Nominal tc (map (opt_co4_wrap env sym False Nominal) cos) - (_, Representational) -> - -- must use opt_co2 here, because some roles may be P - -- See Note [Optimising coercion optimisation] - mkTyConAppCo r tc (zipWith (opt_co2 env sym) - (tyConRoleListRepresentational tc) -- the current roles - 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 (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 - -- Use the "mk" functions to check for nested Refls - -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 - cow' = opt_co1 env sym cow - !r' | rep = Representational - | otherwise = r - !(afl', afr') | sym = (afr,afl) - | otherwise = (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 - - | ty1 `eqType` ty2 -- See Note [Optimise CoVarCo to Refl] - = mkReflCo (chooseRole rep r) ty1 - - | otherwise - = assert (isCoVar cv1 ) - wrapRole rep r $ wrapSym sym $ - CoVarCo cv1 - - where - Pair ty1 ty2 = coVarTypes cv1 - - cv1 = case lookupInScope (lcInScopeSet env) cv of - Just cv1 -> cv1 - Nothing -> warnPprTrace True - "opt_co: not in scope" - (ppr cv $$ ppr env) - cv - -- cv1 might have a substituted kind! - -opt_co4 _ _ _ _ (HoleCo h) - = pprPanic "opt_univ fell into a hole" (ppr h) - -opt_co4 env sym rep r (AxiomInstCo con ind 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) $ - 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) - -- 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 (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' - where - co1' = opt_co4_wrap env sym rep r co1 - co2' = opt_co4_wrap 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 - - | otherwise - = wrapRole rep r $ SelCo n co' - where - co' = opt_co1 env sym 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) - | 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) - else pick_lr lr pr_co - | otherwise - = wrapRole rep Nominal $ LRCo lr co' - where - co' = opt_co4_wrap env sym False Nominal co - - pick_lr CLeft (l, _) = l - pick_lr CRight (_, r) = r - --- See Note [Optimising InstCo] -opt_co4 env sym rep r (InstCo co1 arg) - -- 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 - - -- 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 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' - - | 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' - - -- 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' - - 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)) - -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' - -- 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) - = 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) - -{- Note [Optimise CoVarCo to Refl] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -If we have (c :: t~t) we can optimise it to Refl. That increases the -chances of floating the Refl upwards; e.g. Maybe c --> Refl (Maybe t) - -We do so here in optCoercion, not in mkCoVarCo; see Note [mkCoVarCo] -in GHC.Core.Coercion. --} - -------------- --- | 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 env sym co - = opt_univ env sym (PhantomProv (mkKindCo co)) Phantom ty1 ty2 - where - Pair ty1 ty2 = coercionKind co - -{- Note [Differing kinds] - ~~~~~~~~~~~~~~~~~~~~~~ -The two types may not have the same kind (although that would be very unusual). -But even if they have the same kind, and the same type constructor, the number -of arguments in a `CoTyConApp` can differ. Consider - - Any :: forall k. k - - Any * Int :: * - Any (*->*) Maybe Int :: * - -Hence the need to compare argument lengths; see #13658 - -Note [opt_univ needs injectivity] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -If opt_univ sees a coercion between `T a1 a2` and `T b1 b2` it will optimize it -by producing a TyConAppCo for T, and pushing the UnivCo into the arguments. But -this works only if T is injective. Otherwise we can have something like - - type family F x where - F Int = Int - F Bool = Int - -where `UnivCo :: F Int ~ F Bool` is reasonable (it is effectively just an -alternative representation for a couple of uses of AxiomInstCos) but we do not -want to produce `F (UnivCo :: Int ~ Bool)` where the inner coercion is clearly -inconsistent. Hence the opt_univ case for TyConApps checks isInjectiveTyCon. -See #19509. - - -} - -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' - 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 - | Just (tc1, tys1) <- splitTyConApp_maybe oty1 - , Just (tc2, tys2) <- splitTyConApp_maybe oty2 - , tc1 == tc2 - , isInjectiveTyCon tc1 role -- see Note [opt_univ needs injectivity] - , equalLength tys1 tys2 -- see Note [Differing kinds] - -- 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 - 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 - -- NB: prov isn't interesting here either - = let k1 = tyVarKind tv1 - k2 = tyVarKind tv2 - eta = mkUnivCo prov' 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 - in - mkForAllCo tv1' eta' (opt_univ env' sym prov' role ty1 ty2') - - | Just (cv1, ty1) <- splitForAllCoVar_maybe oty1 - , Just (cv2, ty2) <- splitForAllCoVar_maybe oty2 - -- NB: prov isn't interesting here either - = let k1 = varType cv1 - k2 = varType cv2 - r' = coVarRole cv1 - eta = mkUnivCo prov' 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` - (mkCoVarCo cv1) `mkTransCo` - (mkSelCo (SelTyCon 3 r') eta_d) - ty2' = substTyWithCoVars [cv2] [n_co] ty2 - - (env', cv1', eta') = optForAllCoBndr env sym cv1 eta - in - mkForAllCo cv1' eta' (opt_univ env' sym prov' 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 - -------------- -opt_transList :: HasDebugCallStack => InScopeSet -> [NormalCo] -> [NormalCo] -> [NormalCo] -opt_transList is = zipWithEqual "opt_transList" (opt_trans is) - -- The input lists must have identical length. - -opt_trans :: 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 --- 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 --- Neither arg is the identity -opt_trans2 is (TransCo co1a co1b) co2 - -- Don't know whether the sub-coercions are the identity - = opt_trans is co1a (opt_trans is co1b co2) - -opt_trans2 is co1 co2 - | Just co <- opt_trans_rule is co1 co2 - = co - -opt_trans2 is co1 (TransCo co2a co2b) - | Just co1_2a <- opt_trans_rule is co1 co2a - = if isReflCo co1_2a - then co2b - else opt_trans1 is co1_2a co2b - -opt_trans2 _ co1 co2 - = mkTransCo co1 co2 - ------- --- Optimize coercions with a top-level use of transitivity. -opt_trans_rule :: InScopeSet -> NormalNonIdCo -> NormalNonIdCo -> Maybe NormalCo - -opt_trans_rule is in_co1@(GRefl r1 t1 (MCo co1)) in_co2@(GRefl r2 _ (MCo co2)) - = assert (r1 == r2) $ - fireTransRule "GRefl" in_co1 in_co2 $ - mkGReflRightCo 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) - | d1 == d2 - , coercionRole co1 == coercionRole co2 - , co1 `compatible_co` co2 - = fireTransRule "PushNth" in_co1 in_co2 $ - mkSelCo d1 (opt_trans is co1 co2) - -opt_trans_rule is in_co1@(LRCo d1 co1) in_co2@(LRCo d2 co2) - | d1 == d2 - , co1 `compatible_co` co2 - = fireTransRule "PushLR" in_co1 in_co2 $ - mkLRCo d1 (opt_trans is co1 co2) - --- Push transitivity inside instantiation -opt_trans_rule is in_co1@(InstCo co1 ty1) in_co2@(InstCo co2 ty2) - | ty1 `eqCoercion` ty2 - , co1 `compatible_co` co2 - = 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 - = 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 - --- Push transitivity down through matching top-level constructors. -opt_trans_rule is in_co1@(TyConAppCo r1 tc1 cos1) in_co2@(TyConAppCo r2 tc2 cos2) - | tc1 == tc2 - = assert (r1 == r2) $ - fireTransRule "PushTyConApp" in_co1 in_co2 $ - mkTyConAppCo r1 tc1 (opt_transList is cos1 cos2) - -opt_trans_rule is in_co1@(FunCo r1 afl1 afr1 w1 co1a co1b) - in_co2@(FunCo r2 afl2 afr2 w2 co2a co2b) - = assert (r1 == r2) $ -- Just like the TyConAppCo/TyConAppCo case - assert (afr1 == afl2) $ - fireTransRule "PushFun" in_co1 in_co2 $ - mkFunCo2 r1 afl1 afr2 (opt_trans is w1 w2) - (opt_trans is co1a co2a) - (opt_trans is co1b co2b) - -opt_trans_rule is in_co1@(AppCo co1a co1b) in_co2@(AppCo co2a co2b) - -- Must call opt_trans_rule_app; see Note [EtaAppCo] - = opt_trans_rule_app is in_co1 in_co2 co1a [co1b] co2a [co2b] - --- Eta rules -opt_trans_rule is co1@(TyConAppCo r tc cos1) co2 - | Just cos2 <- etaTyConAppCo_maybe tc co2 - = fireTransRule "EtaCompL" co1 co2 $ - mkTyConAppCo r tc (opt_transList is cos1 cos2) - -opt_trans_rule is co1 co2@(TyConAppCo r tc cos2) - | Just cos1 <- etaTyConAppCo_maybe tc co1 - = fireTransRule "EtaCompR" co1 co2 $ - mkTyConAppCo r tc (opt_transList is cos1 cos2) - -opt_trans_rule is co1@(AppCo co1a co1b) co2 - | Just (co2a,co2b) <- etaAppCo_maybe co2 - = opt_trans_rule_app is co1 co2 co1a [co1b] co2a [co2b] - -opt_trans_rule is co1 co2@(AppCo co2a co2b) - | Just (co1a,co1b) <- etaAppCo_maybe co1 - = opt_trans_rule_app is co1 co2 co1a [co1b] co2a [co2b] - --- 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 (tv2, eta2, r2) <- splitForAllCo_ty_maybe co2 - , Just (tv1, eta1, r1) <- etaForAllCo_ty_maybe co1 - = push_trans tv1 eta1 r1 tv2 eta2 r2 - - where - push_trans tv1 eta1 r1 tv2 eta2 r2 - -- Given: - -- co1 = /\ tv1 : eta1. r1 - -- co2 = /\ tv2 : eta2. r2 - -- Wanted: - -- /\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') - where - is' = is `extendInScopeSet` tv1 - r2' = substCoWithUnchecked [tv2] [mkCastTy (TyVarTy tv1) eta1] r2 - --- 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 (cv2, eta2, r2) <- splitForAllCo_co_maybe co2 - , Just (cv1, eta1, r1) <- etaForAllCo_co_maybe co1 - = push_trans cv1 eta1 r1 cv2 eta2 r2 - - where - push_trans cv1 eta1 r1 cv2 eta2 r2 - -- Given: - -- 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') - 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 - --- Push transitivity inside axioms -opt_trans_rule is co1 co2 - - -- See Note [Why call checkAxInstCo during optimisation] - -- TrPushSymAxR - | Just (sym, con, ind, cos1) <- co1_is_axiom_maybe - , True <- sym - , Just cos2 <- matchAxiom sym con ind co2 - , let newAxInst = AxiomInstCo con ind (opt_transList is (map mkSymCo cos2) cos1) - , Nothing <- checkAxInstCo newAxInst - = fireTransRule "TrPushSymAxR" co1 co2 $ SymCo newAxInst - - -- TrPushAxR - | Just (sym, con, ind, cos1) <- co1_is_axiom_maybe - , False <- sym - , Just cos2 <- matchAxiom sym con ind co2 - , let newAxInst = AxiomInstCo con ind (opt_transList is cos1 cos2) - , Nothing <- checkAxInstCo newAxInst - = fireTransRule "TrPushAxR" co1 co2 newAxInst - - -- TrPushSymAxL - | Just (sym, con, ind, cos2) <- co2_is_axiom_maybe - , True <- sym - , Just cos1 <- matchAxiom (not sym) con ind co1 - , let newAxInst = AxiomInstCo con ind (opt_transList is cos2 (map mkSymCo cos1)) - , Nothing <- checkAxInstCo newAxInst - = fireTransRule "TrPushSymAxL" co1 co2 $ SymCo newAxInst - - -- TrPushAxL - | Just (sym, con, ind, cos2) <- co2_is_axiom_maybe - , False <- sym - , Just cos1 <- matchAxiom (not sym) con ind co1 - , let newAxInst = AxiomInstCo con ind (opt_transList is cos1 cos2) - , Nothing <- checkAxInstCo newAxInst - = 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 - r = coercionRole co1 - ty2 = coercionRKind co2 - , ty1 `eqType` ty2 - = fireTransRule "RedTypeDirRefl" co1 co2 $ - mkReflCo r ty2 - -opt_trans_rule _ _ _ = Nothing - --- See Note [EtaAppCo] -opt_trans_rule_app :: InScopeSet - -> Coercion -- original left-hand coercion (printing only) - -> Coercion -- original right-hand coercion (printing only) - -> Coercion -- left-hand coercion "function" - -> [Coercion] -- left-hand coercion "args" - -> Coercion -- right-hand coercion "function" - -> [Coercion] -- right-hand coercion "args" - -> Maybe Coercion -opt_trans_rule_app is orig_co1 orig_co2 co1a co1bs co2a co2bs - | AppCo co1aa co1ab <- co1a - , Just (co2aa, co2ab) <- etaAppCo_maybe co2a - = opt_trans_rule_app is orig_co1 orig_co2 co1aa (co1ab:co1bs) co2aa (co2ab:co2bs) - - | AppCo co2aa co2ab <- co2a - , Just (co1aa, co1ab) <- etaAppCo_maybe co1a - = opt_trans_rule_app is orig_co1 orig_co2 co1aa (co1ab:co1bs) co2aa (co2ab:co2bs) - - | otherwise - = assert (co1bs `equalLength` co2bs) $ - fireTransRule ("EtaApps:" ++ show (length co1bs)) orig_co1 orig_co2 $ - let rt1a = coercionRKind co1a - - lt2a = coercionLKind co2a - rt2a = coercionRole co2a - - rt1bs = map coercionRKind co1bs - lt2bs = map coercionLKind co2bs - rt2bs = map coercionRole co2bs - - kcoa = mkKindCo $ buildCoercion lt2a rt1a - kcobs = map mkKindCo $ zipWith buildCoercion lt2bs rt1bs - - co2a' = mkCoherenceLeftCo rt2a lt2a kcoa co2a - co2bs' = zipWith3 mkGReflLeftCo rt2bs lt2bs kcobs - co2bs'' = zipWith mkTransCo co2bs' co2bs - in - mkAppCos (opt_trans is co1a co2a') - (zipWith (opt_trans is) co1bs co2bs'') - -fireTransRule :: String -> Coercion -> Coercion -> Coercion -> Maybe Coercion -fireTransRule _rule _co1 _co2 res - = Just res - -{- -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 } - -We wish to disallow (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". - -Note [Why call checkAxInstCo during optimisation] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -It is possible that otherwise-good-looking optimisations meet with disaster -in the presence of axioms with multiple equations. Consider - -type family Equal (a :: *) (b :: *) :: Bool where - Equal a a = True - Equal a b = False -type family Id (a :: *) :: * where - Id a = a - -axEq :: { [a::*]. Equal a a ~ True - ; [a::*, b::*]. Equal a b ~ False } -axId :: [a::*]. Id a ~ a - -co1 = Equal (axId[0] Int) (axId[0] Bool) - :: Equal (Id Int) (Id Bool) ~ Equal Int Bool -co2 = axEq[1] - :: Equal Int Bool ~ False - -We wish to optimise (co1 ; co2). We end up in rule TrPushAxL, noting that -co2 is an axiom and that matchAxiom succeeds when looking at co1. But, what -happens when we push the coercions inside? We get - -co3 = axEq[1] (axId[0] Int) (axId[0] Bool) - :: 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 -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. - -Note [EtaAppCo] -~~~~~~~~~~~~~~~ -Suppose we're trying to optimize (co1a co1b ; co2a co2b). Ideally, we'd -like to rewrite this to (co1a ; co2a) (co1b ; co2b). The problem is that -the resultant coercions might not be well kinded. Here is an example (things -labeled with x don't matter in this example): - - k1 :: Type - k2 :: Type - - a :: k1 -> Type - b :: k1 - - h :: k1 ~ k2 - - co1a :: x1 ~ (a |> (h -> ) - co1b :: x2 ~ (b |> h) - - co2a :: a ~ x3 - co2b :: b ~ x4 - -First, convince yourself of the following: - - co1a co1b :: x1 x2 ~ (a |> (h -> )) (b |> h) - co2a co2b :: a b ~ x3 x4 - - (a |> (h -> )) (b |> h) `eqType` a b - -That last fact is due to Note [Non-trivial definitional equality] in GHC.Core.TyCo.Rep, -where we ignore coercions in types as long as two types' kinds are the same. -In our case, we meet this last condition, because - - (a |> (h -> )) (b |> h) :: Type - and - a b :: Type - -So the input coercion (co1a co1b ; co2a co2b) is well-formed. But the -suggested output coercions (co1a ; co2a) and (co1b ; co2b) are not -- the -kinds don't match up. - -The solution here is to twiddle the kinds in the output coercions. First, we -need to find coercions - - ak :: kind(a |> (h -> )) ~ kind(a) - bk :: kind(b |> h) ~ kind(b) - -This can be done with mkKindCo and buildCoercion. The latter assumes two -types are identical modulo casts and builds a coercion between them. - -Then, we build (co1a ; co2a |> sym ak) and (co1b ; co2b |> sym bk) as the -output coercions. These are well-kinded. - -Also, note that all of this is done after accumulated any nested AppCo -parameters. This step is to avoid quadratic behavior in calling coercionKind. - -The problem described here was first found in dependent/should_compile/dynamic-paper. - --} - --- | 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 - - ------------ -wrapSym :: SymFlag -> Coercion -> Coercion -wrapSym sym co | sym = mkSymCo co - | otherwise = co - --- | Conditionally set a role to be representational -wrapRole :: ReprFlag - -> Role -- ^ current role - -> Coercion -> Coercion -wrapRole False _ = id -wrapRole True current = downgradeRole Representational current - --- | If we require a representational role, return that. Otherwise, --- return the "default" role provided. -chooseRole :: ReprFlag - -> Role -- ^ "default" role - -> Role -chooseRole True _ = Representational -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 - -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 - , cab_cvs = [] -- can't infer these, so fail if there are any - , cab_roles = roles - , cab_lhs = lhs - , cab_rhs = rhs } <- coAxiomNthBranch ax ind - , Just subst <- liftCoMatch (mkVarSet qtvs) - (if sym then (mkTyConApp tc lhs) else rhs) - co - , all (`isMappedByLC` subst) qtvs - = zipWithM (liftCoSubstTyVar subst) roles qtvs - - | otherwise - = Nothing - -------------- -compatible_co :: Coercion -> Coercion -> Bool --- Check whether (co1 . co2) will be well-kinded -compatible_co co1 co2 - = x1 `eqType` x2 - where - x1 = coercionRKind co1 - x2 = coercionLKind co2 - -------------- -{- -etaForAllCo -~~~~~~~~~~~~~~~~~ -(1) etaForAllCo_ty_maybe -Suppose we have - - g : all a1:k1.t1 ~ all a2:k2.t2 - -but g is *not* a ForAllCo. We want to eta-expand it. So, we do this: - - g' = all a1:(ForAllKindCo g).(InstCo g (a1 ~ a1 |> ForAllKindCo g)) - -Call the kind coercion h1 and the body coercion h2. We can see that - - h2 : t1 ~ t2[a2 |-> (a1 |> h1)] - -According to the typing rule for ForAllCo, we get that - - g' : all a1:k1.t1 ~ all a1:k2.(t2[a2 |-> (a1 |> h1)][a1 |-> a1 |> sym h1]) - -or - - g' : all a1:k1.t1 ~ all a1:k2.(t2[a2 |-> a1]) - -as desired. - -(2) etaForAllCo_co_maybe -Suppose we have - - g : all c1:(s1~s2). t1 ~ all c2:(s3~s4). t2 - -Similarly, we do this - - g' = all c1:h1. h2 - : all c1:(s1~s2). t1 ~ all c1:(s3~s4). t2[c2 |-> (sym eta1;c1;eta2)] - [c1 |-> eta1;c1;sym eta2] - -Here, - - h1 = mkSelCo Nominal 0 g :: (s1~s2)~(s3~s4) - eta1 = mkSelCo (SelTyCon 2 r) h1 :: (s1 ~ s3) - eta2 = mkSelCo (SelTyCon 3 r) h1 :: (s2 ~ s4) - h2 = mkInstCo g (cv1 ~ (sym eta1;c1;eta2)) --} -etaForAllCo_ty_maybe :: Coercion -> Maybe (TyVar, 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) - - | Pair ty1 ty2 <- coercionKind co - , Just (tv1, _) <- splitForAllTyVar_maybe ty1 - , isForAllTy_ty ty2 - , let kind_co = mkSelCo SelForAll co - = Just ( tv1, kind_co - , mkInstCo co (mkGReflRightCo Nominal (TyVarTy tv1) kind_co)) - - | otherwise - = Nothing - -etaForAllCo_co_maybe :: Coercion -> Maybe (CoVar, 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) - - | Pair ty1 ty2 <- coercionKind co - , Just (cv1, _) <- splitForAllCoVar_maybe ty1 - , isForAllTy_co ty2 - = 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 - , mkInstCo co (mkProofIrrelCo Nominal kind_co l_co r_co)) - - | otherwise - = Nothing - -etaAppCo_maybe :: Coercion -> Maybe (Coercion,Coercion) --- If possible, split a coercion --- g :: t1a t1b ~ t2a t2b --- into a pair of coercions (left g, right g) -etaAppCo_maybe co - | Just (co1,co2) <- splitAppCo_maybe co - = Just (co1,co2) - | (Pair ty1 ty2, Nominal) <- coercionKindRole co - , Just (_,t1) <- splitAppTy_maybe ty1 - , Just (_,t2) <- splitAppTy_maybe ty2 - , let isco1 = isCoercionTy t1 - , let isco2 = isCoercionTy t2 - , isco1 == isco2 - = Just (LRCo CLeft co, LRCo CRight co) - | otherwise - = Nothing - -etaTyConAppCo_maybe :: TyCon -> Coercion -> Maybe [Coercion] --- If possible, split a coercion --- g :: T s1 .. sn ~ T t1 .. tn --- into [ SelCo (SelTyCon 0) g :: s1~t1 --- , ... --- , SelCo (SelTyCon (n-1)) g :: sn~tn ] -etaTyConAppCo_maybe tc (TyConAppCo _ tc2 cos2) - = assert (tc == tc2) $ Just cos2 - -etaTyConAppCo_maybe tc co - | not (tyConMustBeSaturated tc) - , (Pair ty1 ty2, r) <- coercionKindRole co - , Just (tc1, tys1) <- splitTyConApp_maybe ty1 - , Just (tc2, tys2) <- splitTyConApp_maybe ty2 - , tc1 == tc2 - , isInjectiveTyCon tc r -- See Note [SelCo and newtypes] in GHC.Core.TyCo.Rep - , let n = length tys1 - , tys2 `lengthIs` n -- This can fail in an erroneous program - -- E.g. T a ~# T a b - -- #14607 - = assert (tc == tc1) $ - Just (decomposeCo n co (tyConRolesX r tc1)) - -- NB: n might be <> tyConArity tc - -- e.g. data family T a :: * -> * - -- g :: T a b ~ T c d - - | otherwise - = Nothing - -{- -Note [Eta for AppCo] -~~~~~~~~~~~~~~~~~~~~ -Suppose we have - g :: s1 t1 ~ s2 t2 - -Then we can't necessarily make - left g :: s1 ~ s2 - right g :: t1 ~ t2 -because it's possible that - s1 :: * -> * t1 :: * - s2 :: (*->*) -> * t2 :: * -> * -and in that case (left g) does not have the same -kind on either side. - -It's enough to check that - kind t1 = kind t2 -because if g is well-kinded then - kind (s1 t2) = kind (s2 t2) -and these two imply - kind s1 = kind s2 - --} - -optForAllCoBndr :: LiftingContext -> Bool - -> TyCoVar -> Coercion -> (LiftingContext, TyCoVar, Coercion) -optForAllCoBndr env sym - = substForAllCoBndrUsingLC sym (opt_co4_wrap env sym False Nominal) env + , OptCoercionOpts (..) + ) +where + +import GHC.Prelude + +import GHC.Tc.Utils.TcType ( exactTyCoVarsOfType ) + +import GHC.Core.TyCo.Rep +import GHC.Core.TyCo.Subst +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.Data.Pair + +import GHC.Utils.Outputable +import GHC.Utils.Constants (debugIsOn) +import GHC.Utils.Misc +import GHC.Utils.Panic + +import Control.Monad ( zipWithM ) + +{- +%************************************************************************ +%* * + Optimising coercions +%* * +%************************************************************************ + +This module does coercion optimisation. See the paper + + Evidence normalization in Systtem FV (RTA'13) + https://simon.peytonjones.org/evidence-normalization/ + +The paper is also in the GHC repo, in docs/opt-coercion. + +Note [Optimising coercion optimisation] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Looking up a coercion's role or kind is linear in the size of the +coercion. Thus, doing this repeatedly during the recursive descent +of coercion optimisation is disastrous. We must be careful to avoid +doing this if at all possible. + +Because it is generally easy to know a coercion's components' roles +from the role of the outer coercion, we pass down the known role of +the input in the algorithm below. We also keep functions opt_co2 +and opt_co3 separate from opt_co4, so that the former two do Phantom +checks that opt_co4 can avoid. This is a big win because Phantom coercions +rarely appear within non-phantom coercions -- only in some TyConAppCos +and some AxiomInstCos. We handle these cases specially by calling +opt_co2. + +Note [Optimising InstCo] +~~~~~~~~~~~~~~~~~~~~~~~~ +Optimising InstCo is pretty subtle: #15725, #25387. + +(1) tv is a type variable. We want to optimise + + InstCo (ForAllCo tv kco g) g2 --> S(g) + +where S is some substitution. Let's look at the typing rules. + + kco : k1 ~ k2 + tv:k1 |- g : t1 ~ t2 + ----------------------------- + ForAllCo tv kco g : (all tv:k1.t1) ~ (all tv:k2.t2[tv |-> tv |> sym kco]) + + g1 : (all tv:k1.t1') ~ (all tv:k2.t2') + g2 : (s1:k1) ~ (s2:k2) + -------------------- + InstCo g1 g2 : t1'[tv |-> s1] ~ t2'[tv |-> s2] + +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. + +h : (t1 ~r t2) ~N (t3 ~r t4) +cv : t1 ~r t2 |- g : t1' ~r2 t2' +n1 = nth r 2 (downgradeRole r N h) :: t1 ~r t3 +n2 = nth r 3 (downgradeRole r N h) :: t2 ~r t4 +------------------------------------------------ +ForAllCo cv h g : (all cv:t1 ~r t2. t1') ~r2 + (all cv:t3 ~r t4. t2'[cv |-> n1 ; cv ; sym n2]) + +g1 : (all cv:t1 ~r t2. t1') ~ (all cv: t3 ~r t4. t2') +g2 : h1 ~N h2 +h1 : t1 ~r t2 +h2 : t3 ~r t4 +------------------------------------------------ +InstCo g1 g2 : t1'[cv |-> h1] ~ t2'[cv |-> h2] + +We thus want some coercion proving this: + + t1'[cv |-> h1] ~ t2'[cv |-> n1 ; h2; sym n2] + +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 +newtype OptCoercionOpts = OptCoercionOpts + { optCoercionEnabled :: Bool -- ^ Enable coercion optimisation (reduce its size) + } + +optCoercion :: OptCoercionOpts -> Subst -> Coercion -> NormalCo +-- ^ optCoercion applies a substitution to a coercion, +-- *and* optimises it to reduce its size +optCoercion opts env co + | optCoercionEnabled opts + = optCoercion' env co + +{- + = pprTrace "optCoercion {" (text "Co:" <> ppr (coercionSize co)) $ + let result = optCoercion' env co in + 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 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 + 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 NotSwapped co + where + lc = mkSubstLiftingContext env +-- ppr_one cv = ppr cv <+> dcolon <+> ppr (coVarKind cv) + + +type NormalCo = Coercion + -- Invariants: + -- * The substitution has been fully applied + -- * For trans coercions (co1 `trans` co2) + -- co1 is not a trans, and neither co1 nor co2 is identity + +type NormalNonIdCo = NormalCo -- Extra invariant: not the identity + +-- | 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 + -> 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 + -> 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_co4 env sym False r co + +-- See Note [Optimising coercion optimisation] +-- | 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 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 env sym False r co + +-- See Note [Optimising coercion optimisation] +-- | Optimize a non-phantom coercion. +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 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 sym rep r (Refl ty) + = assertPpr (r == Nominal) + (text "Expected role:" <+> ppr r $$ + text "Found role:" <+> ppr Nominal $$ + text "Type:" <+> ppr 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 MRefl) + = assertPpr (r == _r) + (text "Expected role:" <+> ppr r $$ + text "Found role:" <+> ppr _r $$ + text "Type:" <+> ppr 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 kco)) + = assertPpr (r == _r) + (text "Expected role:" <+> ppr r $$ + text "Found role:" <+> ppr _r $$ + text "Type:" <+> ppr 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_co = liftCoSubst r' env ty + kco' = opt_co4 env NotSwapped False Nominal kco + +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) + = assert (r == _r) $ + case (rep, r) of + (True, Nominal) -> + mkTyConAppCo Representational tc + (zipWith3 (opt_co3 env sym) + (map Just (tyConRoleListRepresentational tc)) + (repeat Nominal) + cos) + (False, Nominal) -> + 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] + mkTyConAppCo r tc (zipWith (opt_co2 env sym) + (tyConRoleListRepresentational tc) -- the current roles + cos) + (_, Phantom) -> pprPanic "opt_co4 sees a phantom!" (ppr g) + +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 { 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) + = assert (r == _r) $ + mkFunCo2 r' afl' afr' cow' co1' co2' + where + 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') = swapSym sym (afl, afr) + +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) $ + wrapRole rep r $ wrapSym sym $ + CoVarCo cv1 + + where + Pair ty1 ty2 = coVarTypes cv1 + + cv1 = case lookupInScope (lcInScopeSet env) cv of + Just cv1 -> cv1 + Nothing -> warnPprTrace True + "opt_co: not in scope" + (ppr cv $$ ppr env) + cv + -- cv1 might have a substituted kind! + +opt_co4' _ _ _ _ (HoleCo h) + = pprPanic "opt_univ fell into a hole" (ppr h) + +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 == coAxiomRuleRole con ) + wrapRole rep (coAxiomRuleRole con) $ + wrapSym sym $ + -- some sub-cos might be P: use opt_co2 + -- See Note [Optimising coercion optimisation] + 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 { 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 + | isSwapped sym = opt_trans in_scope co2' co1' + | otherwise = opt_trans in_scope co1' co2' + where + 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 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. + + -- 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) + | Just pr_co <- splitAppCo_maybe co + = assert (r == Nominal ) + 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 (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 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 fun_co arg_co) + -- forall over type... + | 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 + + -- 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 + + -- 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', _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' + + -- 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' + + -- Those cases didn't work either, so rebuild the InstCo + -- Push Sym into /both/ function /and/ arg_coument + | otherwise = InstCo fun_co' arg_co' + + 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) + = assert (r == Nominal) $ + let kco' = promoteCoercion co in + case kco' of + KindCo co' -> promoteCoercion (opt_co1 env sym co') + _ -> 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) + = assert (r == Representational) $ + opt_co4 env sym True Nominal co + +{- Note [Optimise CoVarCo to Refl] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If we have (c :: t~t) we can optimise it to Refl. That increases the +chances of floating the Refl upwards; e.g. Maybe c --> Refl (Maybe t) + +We do so here in optCoercion, not in mkCoVarCo; see Note [mkCoVarCo] +in GHC.Core.Coercion. +-} + +------------- +-- | Optimize a phantom coercion. The input coercion may not necessarily +-- be a phantom, but the output sure will be. +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 + where + Pair ty1 ty2 = coercionKind co + +{- Note [Differing kinds] + ~~~~~~~~~~~~~~~~~~~~~~ +The two types may not have the same kind (although that would be very unusual). +But even if they have the same kind, and the same type constructor, the number +of arguments in a `CoTyConApp` can differ. Consider + + Any :: forall k. k + + Any @Type Int :: Type + Any @(Type->Type) Maybe Int :: Type + +Hence the need to compare argument lengths; see #13658 + +Note [opt_univ needs injectivity] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If opt_univ sees a coercion between `T a1 a2` and `T b1 b2` it will optimize it +by producing a TyConAppCo for T, and pushing the UnivCo into the arguments. But +this works only if T is injective. Otherwise we can have something like + + type family F x where + F Int = Int + F Bool = Int + +where `UnivCo :: F Int ~ F Bool` is reasonable (it is effectively just an +alternative representation for a couple of uses of AxiomInstCos) but we do not +want to produce `F (UnivCo :: Int ~ Bool)` where the inner coercion is clearly +inconsistent. Hence the opt_univ case for TyConApps checks isInjectiveTyCon. +See #19509. + + -} + +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 + ty1' = substTy (lcSubstLeft env) ty1 + ty2' = substTy (lcSubstRight env) ty2 + +opt_univ1 env prov cvs' role oty1 oty2 + | Just (tc1, tys1) <- splitTyConApp_maybe oty1 + , Just (tc2, tys2) <- splitTyConApp_maybe oty2 + , tc1 == tc2 + , isInjectiveTyCon tc1 role -- see Note [opt_univ needs injectivity] + , equalLength tys1 tys2 -- see Note [Differing kinds] + -- 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 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 (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 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 False tv1 eta + in + mkForAllCo tv1' vis1 vis2 eta' (opt_univ1 env' prov cvs' role ty1 ty2') + + | 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 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` + (mkCoVarCo cv1) `mkTransCo` + (mkSelCo (SelTyCon 3 r') eta_d) + ty2' = substTyWithCoVars [cv2] [n_co] ty2 + + (env', cv1', eta') = optForAllCoBndr env False cv1 eta + in + 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 + in + mkUnivCo prov cvs' role ty1 ty2 +-} + +------------- +opt_transList :: HasDebugCallStack => InScopeSet -> [NormalCo] -> [NormalCo] -> [NormalCo] +opt_transList is = zipWithEqual (opt_trans is) + -- The input lists must have identical length. + +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 :: 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 :: 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 + = opt_trans is co1a (opt_trans is co1b co2) + +opt_trans2 is co1 co2 + | Just co <- opt_trans_rule is co1 co2 + = co + +opt_trans2 is co1 (TransCo co2a co2b) + | Just co1_2a <- opt_trans_rule is co1 co2a + = if isReflCo co1_2a + then co2b + else opt_trans1 is co1_2a co2b + +opt_trans2 _ co1 co2 + = mk_trans_co co1 co2 + + +------ +-- Optimize coercions with a top-level use of transitivity. +opt_trans_rule :: HasDebugCallStack => InScopeSet -> NormalNonIdCo -> NormalNonIdCo -> Maybe NormalCo + +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 $ + 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) + | d1 == d2 + , coercionRole co1 == coercionRole co2 + , co1 `compatible_co` co2 + = fireTransRule "PushNth" in_co1 in_co2 $ + mkSelCo d1 (opt_trans is co1 co2) + +opt_trans_rule is in_co1@(LRCo d1 co1) in_co2@(LRCo d2 co2) + | d1 == d2 + , co1 `compatible_co` co2 + = fireTransRule "PushLR" in_co1 in_co2 $ + mkLRCo d1 (opt_trans is co1 co2) + +-- Push transitivity inside instantiation +opt_trans_rule is in_co1@(InstCo co1 ty1) in_co2@(InstCo co2 ty2) + | ty1 `eqCoercion` ty2 + , co1 `compatible_co` co2 + = fireTransRule "TrPushInst" in_co1 in_co2 $ + mkInstCo (opt_trans is co1 co2) ty1 + +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 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) + | tc1 == tc2 + = assert (r1 == r2) $ + fireTransRule "PushTyConApp" in_co1 in_co2 $ + mkTyConAppCo r1 tc1 (opt_transList is cos1 cos2) + +opt_trans_rule is in_co1@(FunCo r1 afl1 afr1 w1 co1a co1b) + in_co2@(FunCo r2 afl2 afr2 w2 co2a co2b) + = assert (r1 == r2) $ -- Just like the TyConAppCo/TyConAppCo case + assert (afr1 == afl2) $ + fireTransRule "PushFun" in_co1 in_co2 $ + mkFunCo2 r1 afl1 afr2 (opt_trans is w1 w2) + (opt_trans is co1a co2a) + (opt_trans is co1b co2b) + +opt_trans_rule is in_co1@(AppCo co1a co1b) in_co2@(AppCo co2a co2b) + -- Must call opt_trans_rule_app; see Note [EtaAppCo] + = opt_trans_rule_app is in_co1 in_co2 co1a [co1b] co2a [co2b] + +-- Eta rules +opt_trans_rule is co1@(TyConAppCo r tc cos1) co2 + | Just cos2 <- etaTyConAppCo_maybe tc co2 + = fireTransRule "EtaCompL" co1 co2 $ + mkTyConAppCo r tc (opt_transList is cos1 cos2) + +opt_trans_rule is co1 co2@(TyConAppCo r tc cos2) + | Just cos1 <- etaTyConAppCo_maybe tc co1 + = fireTransRule "EtaCompR" co1 co2 $ + mkTyConAppCo r tc (opt_transList is cos1 cos2) + +opt_trans_rule is co1@(AppCo co1a co1b) co2 + | Just (co2a,co2b) <- etaAppCo_maybe co2 + = opt_trans_rule_app is co1 co2 co1a [co1b] co2a [co2b] + +opt_trans_rule is co1 co2@(AppCo co2a co2b) + | Just (co1a,co1b) <- etaAppCo_maybe co1 + = opt_trans_rule_app is co1 co2 co1a [co1b] co2a [co2b] + +-- Push transitivity inside forall +-- forall over types. +opt_trans_rule is co1 co2 + | 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, _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 visL visR + -- Given: + -- co1 = /\ tv1 : eta1 . r1 + -- co2 = /\ tv2 : eta2 . r2 + -- Wanted: + -- /\tv1 : (eta1;eta2) . (r1; r2[tv2 |-> tv1 |> eta1]) + = fireTransRule "EtaAllTy_ty" co1 co2 $ + 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 + +-- Push transitivity inside forall +-- forall over coercions. +opt_trans_rule is co1 co2 + | 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, _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 visL visR + -- Given: + -- 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 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) `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, 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, 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, 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, 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 + + +opt_trans_rule _ co1 co2 -- Identity rule + | let ty1 = coercionLKind co1 + r = coercionRole co1 + ty2 = coercionRKind co2 + , ty1 `eqType` ty2 + = fireTransRule "RedTypeDirRefl" co1 co2 $ + mkReflCo r ty2 + +opt_trans_rule _ _ _ = Nothing + +-- See Note [EtaAppCo] +opt_trans_rule_app :: InScopeSet + -> Coercion -- original left-hand coercion (printing only) + -> Coercion -- original right-hand coercion (printing only) + -> Coercion -- left-hand coercion "function" + -> [Coercion] -- left-hand coercion "args" + -> Coercion -- right-hand coercion "function" + -> [Coercion] -- right-hand coercion "args" + -> Maybe Coercion +opt_trans_rule_app is orig_co1 orig_co2 co1a co1bs co2a co2bs + | AppCo co1aa co1ab <- co1a + , Just (co2aa, co2ab) <- etaAppCo_maybe co2a + = opt_trans_rule_app is orig_co1 orig_co2 co1aa (co1ab:co1bs) co2aa (co2ab:co2bs) + + | AppCo co2aa co2ab <- co2a + , Just (co1aa, co1ab) <- etaAppCo_maybe co1a + = opt_trans_rule_app is orig_co1 orig_co2 co1aa (co1ab:co1bs) co2aa (co2ab:co2bs) + + | otherwise + = assert (co1bs `equalLength` co2bs) $ + fireTransRule ("EtaApps:" ++ show (length co1bs)) orig_co1 orig_co2 $ + let rt1a = coercionRKind co1a + + lt2a = coercionLKind co2a + rt2a = coercionRole co2a + + rt1bs = map coercionRKind co1bs + lt2bs = map coercionLKind co2bs + rt2bs = map coercionRole co2bs + + kcoa = mkKindCo $ buildCoercion lt2a rt1a + kcobs = map mkKindCo $ zipWith buildCoercion lt2bs rt1bs + + co2a' = mkCoherenceLeftCo rt2a lt2a kcoa co2a + co2bs' = zipWith3 mkGReflLeftCo rt2bs lt2bs kcobs + co2bs'' = zipWith mk_trans_co co2bs' co2bs + in + mkAppCos (opt_trans is co1a co2a') + (zipWith (opt_trans is) co1bs co2bs'') + +fireTransRule :: String -> Coercion -> Coercion -> Coercion -> Maybe Coercion +fireTransRule _rule _co1 _co2 res + = Just res + +{- +Note [Push transitivity inside axioms] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +opt_trans_rule tries to push transitivity inside axioms to deal with cases like +the following: + + newtype N a = MkN a + + axN :: N a ~R# a + + covar :: a ~R# b + co1 = axN :: N a ~R# a + co2 = axN :: N b ~R# b + + co :: a ~R# b + co = sym co1 ; N covar ; co2 + +When we are optimising co, we want to notice that the two axiom instantiations +cancel out. This is implemented by rules such as TrPushSymAxR, which transforms + sym (axN ) ; N covar +into + sym (axN covar) +so that TrPushSymAx can subsequently transform + sym (axN covar) ; axN +into + covar +which is much more compact. In some perf test cases this kind of pattern can be +generated repeatedly during simplification, so it is very important we squash it +to stop coercions growing exponentially. For more details see the paper: + + Evidence normalisation in System FC + Dimitrios Vytiniotis and Simon Peyton Jones + RTA'13, 2013 + https://www.microsoft.com/en-us/research/publication/evidence-normalization-system-fc-2/ + + +Note [Push transitivity inside newtype axioms only] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The optimization described in Note [Push transitivity inside axioms] is possible +for both newtype and type family axioms. However, for type family axioms it is +relatively common to have transitive sequences of axioms instantiations, for +example: + + data Nat = Zero | Suc Nat + + type family Index (n :: Nat) (xs :: [Type]) :: Type where + Index Zero (x : xs) = x + Index (Suc n) (x : xs) = Index n xs + + axIndex :: { forall x::Type. forall xs::[Type]. Index Zero (x : xs) ~ x + ; forall n::Nat. forall x::Type. forall xs::[Type]. Index (Suc n) (x : xs) ~ Index n xs } + + co :: Index (Suc (Suc Zero)) [a, b, c] ~ c + co = axIndex[1] <[b, c]> + ; axIndex[1] <[c]> + ; axIndex[0] <[]> + +Not only are there no cancellation opportunities here, but calling matchAxiom +repeatedly down the transitive chain is very expensive. Hence we do not attempt +to push transitivity inside type family axioms. See #8095, !9210 and related tickets. + +This is implemented by opt_trans_rule checking that the axiom is for a newtype +constructor (i.e. not a type family). Adding these guards substantially +improved performance (reduced bytes allocated by more than 10%) for the tests +CoOpt_Singletons, LargeRecord, T12227, T12545, T13386, T15703, T5030, T8095. + +A side benefit is that we do not risk accidentally creating an ill-typed +coercion; see Note [Why call checkAxInstCo during optimisation]. + +There may exist programs that previously relied on pushing transitivity inside +type family axioms to avoid creating huge coercions, which will regress in +compile time performance as a result of this change. We do not currently know +of any examples, but if any come to light we may need to reconsider this +behaviour. + + +Note [Why call checkAxInstCo during optimisation] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +NB: The following is no longer relevant, because we no longer push transitivity +into type family axioms (Note [Push transitivity inside newtype axioms only]). +It is retained for reference in case we change this behaviour in the future. + +It is possible that otherwise-good-looking optimisations meet with disaster +in the presence of axioms with multiple equations. Consider + +type family Equal (a :: *) (b :: *) :: Bool where + Equal a a = True + Equal a b = False +type family Id (a :: *) :: * where + Id a = a + +axEq :: { [a::*]. Equal a a ~ True + ; [a::*, b::*]. Equal a b ~ False } +axId :: [a::*]. Id a ~ a + +co1 = Equal (axId[0] Int) (axId[0] Bool) + :: Equal (Id Int) (Id Bool) ~ Equal Int Bool +co2 = axEq[1] + :: Equal Int Bool ~ False + +We wish to optimise (co1 ; co2). We end up in rule TrPushAxL, noting that +co2 is an axiom and that matchAxiom succeeds when looking at co1. But, what +happens when we push the coercions inside? We get + +co3 = axEq[1] (axId[0] Int) (axId[0] Bool) + :: 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 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. + +Note [EtaAppCo] +~~~~~~~~~~~~~~~ +Suppose we're trying to optimize (co1a co1b ; co2a co2b). Ideally, we'd +like to rewrite this to (co1a ; co2a) (co1b ; co2b). The problem is that +the resultant coercions might not be well kinded. Here is an example (things +labeled with x don't matter in this example): + + k1 :: Type + k2 :: Type + + a :: k1 -> Type + b :: k1 + + h :: k1 ~ k2 + + co1a :: x1 ~ (a |> (h -> ) + co1b :: x2 ~ (b |> h) + + co2a :: a ~ x3 + co2b :: b ~ x4 + +First, convince yourself of the following: + + co1a co1b :: x1 x2 ~ (a |> (h -> )) (b |> h) + co2a co2b :: a b ~ x3 x4 + + (a |> (h -> )) (b |> h) `eqType` a b + +That last fact is due to Note [Non-trivial definitional equality] in GHC.Core.TyCo.Rep, +where we ignore coercions in types as long as two types' kinds are the same. +In our case, we meet this last condition, because + + (a |> (h -> )) (b |> h) :: Type + and + a b :: Type + +So the input coercion (co1a co1b ; co2a co2b) is well-formed. But the +suggested output coercions (co1a ; co2a) and (co1b ; co2b) are not -- the +kinds don't match up. + +The solution here is to twiddle the kinds in the output coercions. First, we +need to find coercions + + ak :: kind(a |> (h -> )) ~ kind(a) + bk :: kind(b |> h) ~ kind(b) + +This can be done with mkKindCo and buildCoercion. The latter assumes two +types are identical modulo casts and builds a coercion between them. + +Then, we build (co1a ; co2a |> sym ak) and (co1b ; co2b |> sym bk) as the +output coercions. These are well-kinded. + +Also, note that all of this is done after accumulated any nested AppCo +parameters. This step is to avoid quadratic behavior in calling coercionKind. + +The problem described here was first found in dependent/should_compile/dynamic-paper. + +-} + +----------- +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 + -> Coercion -> Coercion +wrapRole False _ = id +wrapRole True current = downgradeRole Representational current + +-- | If we require a representational role, return that. Otherwise, +-- return the "default" role provided. +chooseRole :: ReprFlag + -> Role -- ^ "default" role + -> Role +chooseRole True _ = Representational +chooseRole _ r = r + +----------- +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 + +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 } <- branch + , Just subst <- liftCoMatch (mkVarSet qtvs) + (pickSwap sym rhs (mkTyConApp tc lhs)) + co + , all (`isMappedByLC` subst) qtvs + = zipWithM (liftCoSubstTyVar subst) roles qtvs + + | otherwise + = Nothing + +------------- +compatible_co :: Coercion -> Coercion -> Bool +-- Check whether (co1 . co2) will be well-kinded +compatible_co co1 co2 + = x1 `eqType` x2 + where + x1 = coercionRKind co1 + x2 = coercionLKind co2 + +------------- +{- +etaForAllCo +~~~~~~~~~~~~~~~~~ +(1) etaForAllCo_ty_maybe +Suppose we have + + g : all a1:k1.t1 ~ all a2:k2.t2 + +but g is *not* a ForAllCo. We want to eta-expand it. So, we do this: + + g' = all a1:(ForAllKindCo g).(InstCo g (a1 ~ a1 |> ForAllKindCo g)) + +Call the kind coercion h1 and the body coercion h2. We can see that + + h2 : t1 ~ t2[a2 |-> (a1 |> h1)] + +According to the typing rule for ForAllCo, we get that + + g' : all a1:k1.t1 ~ all a1:k2.(t2[a2 |-> (a1 |> h1)][a1 |-> a1 |> sym h1]) + +or + + g' : all a1:k1.t1 ~ all a1:k2.(t2[a2 |-> a1]) + +as desired. + +(2) etaForAllCo_co_maybe +Suppose we have + + g : all c1:(s1~s2). t1 ~ all c2:(s3~s4). t2 + +Similarly, we do this + + g' = all c1:h1. h2 + : all c1:(s1~s2). t1 ~ all c1:(s3~s4). t2[c2 |-> (sym eta1;c1;eta2)] + [c1 |-> eta1;c1;sym eta2] + +Here, + + h1 = mkSelCo Nominal 0 g :: (s1~s2)~(s3~s4) + eta1 = mkSelCo (SelTyCon 2 r) h1 :: (s1 ~ s3) + eta2 = mkSelCo (SelTyCon 3 r) h1 :: (s2 ~ s4) + h2 = mkInstCo g (cv1 ~ (sym eta1;c1;eta2)) +-} +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, visL, visR, kind_co, r) <- splitForAllCo_ty_maybe co + = Just (tv, visL, visR, kind_co, r) + + | (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, vis1, vis2, kind_co + , mkInstCo co (mk_grefl_right_co Nominal (TyVarTy tv1) kind_co)) + + | otherwise + = Nothing + +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, visL, visR, kind_co, r) <- splitForAllCo_co_maybe co + = Just (cv, visL, visR, kind_co, r) + + | (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') + `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 + = Nothing + +etaAppCo_maybe :: Coercion -> Maybe (Coercion,Coercion) +-- If possible, split a coercion +-- g :: t1a t1b ~ t2a t2b +-- into a pair of coercions (left g, right g) +etaAppCo_maybe co + | Just (co1,co2) <- splitAppCo_maybe co + = Just (co1,co2) + | (Pair ty1 ty2, Nominal) <- coercionKindRole co + , Just (_,t1) <- splitAppTy_maybe ty1 + , Just (_,t2) <- splitAppTy_maybe ty2 + , let isco1 = isCoercionTy t1 + , let isco2 = isCoercionTy t2 + , isco1 == isco2 + = Just (LRCo CLeft co, LRCo CRight co) + | otherwise + = Nothing + +etaTyConAppCo_maybe :: TyCon -> Coercion -> Maybe [Coercion] +-- If possible, split a coercion +-- g :: T s1 .. sn ~ T t1 .. tn +-- into [ SelCo (SelTyCon 0) g :: s1~t1 +-- , ... +-- , SelCo (SelTyCon (n-1)) g :: sn~tn ] +etaTyConAppCo_maybe tc (TyConAppCo _ tc2 cos2) + = assert (tc == tc2) $ Just cos2 + +etaTyConAppCo_maybe tc co + | not (tyConMustBeSaturated tc) + , (Pair ty1 ty2, r) <- coercionKindRole co + , Just (tc1, tys1) <- splitTyConApp_maybe ty1 + , Just (tc2, tys2) <- splitTyConApp_maybe ty2 + , tc1 == tc2 + , isInjectiveTyCon tc r -- See Note [SelCo and newtypes] in GHC.Core.TyCo.Rep + , let n = length tys1 + , tys2 `lengthIs` n -- This can fail in an erroneous program + -- E.g. T a ~# T a b + -- #14607 + = assert (tc == tc1) $ + Just (decomposeCo n co (tyConRolesX r tc1)) + -- NB: n might be <> tyConArity tc + -- e.g. data family T a :: * -> * + -- g :: T a b ~ T c d + + | otherwise + = Nothing + +{- +Note [Eta for AppCo] +~~~~~~~~~~~~~~~~~~~~ +Suppose we have + g :: s1 t1 ~ s2 t2 + +Then we can't necessarily make + left g :: s1 ~ s2 + right g :: t1 ~ t2 +because it's possible that + s1 :: * -> * t1 :: * + s2 :: (*->*) -> * t2 :: * -> * +and in that case (left g) does not have the same +kind on either side. + +It's enough to check that + kind t1 = kind t2 +because if g is well-kinded then + kind (s1 t2) = kind (s2 t2) +and these two imply + kind s1 = kind s2 + +-} + +{- 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 @@ -9,9 +9,12 @@ module GHC.Core.ConLike ( ConLike(..) + , conLikeConLikeName , isVanillaConLike , conLikeArity + , conLikeVisArity , conLikeFieldLabels + , conLikeConInfo , conLikeInstOrigArgTys , conLikeUserTyVarBinders , conLikeExTyCoVars @@ -21,7 +24,6 @@ , conLikeFullSig , conLikeResTy , conLikeFieldType - , conLikesWithFields , conLikeIsInfix , conLikeHasBuilder ) where @@ -29,16 +31,20 @@ import GHC.Prelude import GHC.Core.DataCon +import GHC.Core.Multiplicity import GHC.Core.PatSyn -import GHC.Utils.Outputable +import GHC.Core.TyCo.Rep (Type, ThetaType) +import GHC.Core.TyCon (tyConDataCons) +import GHC.Core.Type(mkTyConApp) import GHC.Types.Unique -import GHC.Utils.Misc import GHC.Types.Name +import GHC.Types.Name.Reader import GHC.Types.Basic -import GHC.Core.TyCo.Rep (Type, ThetaType) + +import GHC.Types.GREInfo import GHC.Types.Var -import GHC.Core.Type(mkTyConApp) -import GHC.Core.Multiplicity +import GHC.Utils.Misc +import GHC.Utils.Outputable import Data.Maybe( isJust ) import qualified Data.Data as Data @@ -61,6 +67,10 @@ isVanillaConLike (RealDataCon con) = isVanillaDataCon con isVanillaConLike (PatSynCon ps ) = isVanillaPatSyn ps +conLikeConLikeName :: ConLike -> ConLikeName +conLikeConLikeName (RealDataCon dc) = DataConName (dataConName dc) +conLikeConLikeName (PatSynCon ps) = PatSynName (patSynName ps) + {- ************************************************************************ * * @@ -103,16 +113,33 @@ 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 conLikeFieldLabels (PatSynCon pat_syn) = patSynFieldLabels pat_syn +-- | The 'ConInfo' (arity and field labels) associated to a 'ConLike'. +conLikeConInfo :: ConLike -> ConInfo +conLikeConInfo 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] @@ -126,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`. @@ -207,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 @@ -22,7 +22,7 @@ eqSpecPair, eqSpecPreds, -- ** Field labels - FieldLabel(..), FieldLabelString, + FieldLabel(..), flLabel, FieldLabelString, -- ** Type construction mkDataCon, fIRST_TAG, @@ -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] @@ -141,9 +145,21 @@ case e of { T a' b -> let a = I# a' in ... } To keep ourselves sane, we name the different versions of the data constructor -differently, as follows. +differently, as follows in Note [Data Constructor Naming]. +The `dcRepType` field of a `DataCon` contains the type of the representation of +the constructor /worker/, also called the Core representation. +The Core representation may differ from the type of the constructor /wrapper/ +(built by `mkDataConRep`). Besides unpacking (as seen in the example above), +dictionaries and coercions become explict arguments in the Core representation +of a constructor. + +Note that this representation is still *different* from runtime +representation. (Which is what STG uses after unarise). +See Note [Constructor applications in STG] in GHC.Stg.Syntax. + + Note [Data Constructor Naming] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Each data constructor C has two, and possibly up to four, Names associated with it: @@ -209,7 +225,8 @@ * See Note [Data Constructor Naming] for how the worker and wrapper are named -* Neither_ the worker _nor_ the wrapper take the dcStupidTheta dicts as arguments +* The workers don't take the dcStupidTheta dicts as arguments, while the + wrappers currently do * The wrapper (if it exists) takes dcOrigArgTys as its arguments. The worker takes dataConRepArgTys as its arguments @@ -365,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* @@ -437,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_. @@ -502,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; @@ -528,7 +560,7 @@ -- forall a x y. (a~(x,y), x~y, Ord x) => -- x -> y -> T a -- (this is *not* of the constructor wrapper Id: - -- see Note [Data con representation] below) + -- see Note [Data constructor representation]) -- Notice that the existential type parameters come *second*. -- Reason: in a case expression we may find: -- case (e :: T t) of @@ -548,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: @@ -586,12 +602,22 @@ Note [DataCon arities] ~~~~~~~~~~~~~~~~~~~~~~ -A `DataCon`'s source arity and core representation arity may differ: -`dcSourceArity` does not take constraints into account, but `dcRepArity` does. +A `DataCon`'s source and core representation may differ, meaning the source +arity (`dcSourceArity`) and the core representation arity (`dcRepArity`) may +differ too. -The additional arguments taken into account by `dcRepArity` include quantified -dictionaries and coercion arguments, lifted and unlifted (despite the unlifted -coercion arguments having a zero-width runtime representation). +Note that the source arity isn't exactly the number of arguments the data con +/wrapper/ has, since `dcSourceArity` doesn't count constraints -- which may +appear in the wrapper through `DatatypeContexts`, or if the constructor stores a +dictionary. In this sense, the source arity counts the number of non-constraint +arguments that appear at the source level. + On the other hand, the Core representation arity is the number of arguments +of the data constructor in its Core representation, which is also the number +of arguments of the data con /worker/. + +The arity might differ since `dcRepArity` takes into account arguments such as +quantified dictionaries and coercion arguments, lifted and unlifted (despite +the unlifted coercion arguments having a zero-width runtime representation). For example: MkT :: Ord a => a -> T a dcSourceArity = 1 @@ -601,31 +627,57 @@ dcSourceArity = 0 dcRepArity = 1 +The arity might also differ due to unpacking, for example, consider the +following datatype and its wrapper and worker's type: + data V = MkV !() !Int + $WMkV :: () -> Int -> V + MkV :: Int# -> V +As you see, because of unpacking we have both dropped the unit argument and +unboxed the Int. In this case, the source arity (which is the arity of the +wrapper) is 2, while the Core representation arity (the arity of the worker) is 1. + Note [DataCon user type variable binders] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 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 three 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 --- @@ -714,55 +766,6 @@ equation in the dcEqSpec will be in dcUnivTyVars but *not* in dcUserTyVarBinders. ---- Reason (R3): Kind equalities may have been solved --- - -Consider now this case: - - type family F a where - F Type = False - F _ = True - type T :: forall k. (F k ~ True) => k -> k -> Type - data T a b where - MkT :: T Maybe List - -The constraint F k ~ True tells us that T does not want to be indexed by, say, -Int. Now let's consider the Core types involved: - - axiom for F: axF[0] :: F Type ~ False - axF[1] :: forall a. F a ~ True (a must be apart from Type) - tycon: T :: forall k. (F k ~ True) -> k -> k -> Type - wrapper: MkT :: T @(Type -> Type) @(Eq# (axF[1] (Type -> Type)) Maybe List - worker: MkT :: forall k (c :: F k ~ True) (a :: k) (b :: k). - (k ~# (Type -> Type), a ~# Maybe, b ~# List) => - T @k @c a b - -The key observation here is that the worker quantifies over c, while the wrapper -does not. The worker *must* quantify over c, because c is a universal variable, -and the result of the worker must be the type constructor applied to a sequence -of plain type variables. But the wrapper certainly does not need to quantify over -any evidence that F (Type -> Type) ~ True, as no variables are needed there. - -(Aside: the c here is a regular type variable, *not* a coercion variable. This -is because F k ~ True is a *lifted* equality, not the unlifted ~#. This is why -we see Eq# in the type of the wrapper: Eq# boxes the unlifted ~# to become a -lifted ~. See also Note [The equality types story] in GHC.Builtin.Types.Prim about -Eq# and Note [Constraints in kinds] in GHC.Core.TyCo.Rep about having this constraint -in the first place.) - -In this case, we'll have these fields of the DataCon: - - dcUserTyVarBinders = [] -- the wrapper quantifies over nothing - dcUnivTyVars = [k, c, a, b] - dcExTyCoVars = [] -- no existentials here, but a different constructor might have - dcEqSpec = [k ~# (Type -> Type), a ~# Maybe, b ~# List] - -Note that c is in the dcUserTyVars, but mentioned neither in the dcUserTyVarBinders nor -in the dcEqSpec. We thus have Reason (R3): a variable might be missing from the -dcUserTyVarBinders if its type's kind is Constraint. - -(At one point, we thought that the dcEqSpec would have to be non-empty. But that -wouldn't account for silly cases like type T :: (True ~ True) => Type.) - --- End of Reasons --- INVARIANT(dataConTyVars): the set of tyvars in dcUserTyVarBinders @@ -836,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 @@ -851,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 @@ -905,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 @@ -973,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] @@ -983,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, @@ -1018,52 +994,6 @@ The boolean flag is used only for this warning. See #11270 for motivation. -Note [Data con representation] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The dcRepType field contains the type of the representation of a constructor -This may differ from the type of the constructor *Id* (built -by MkId.mkDataConId) for two reasons: - a) the constructor Id may be overloaded, but the dictionary isn't stored - e.g. data Eq a => T a = MkT a a - - b) the constructor may store an unboxed version of a strict field. - -So whenever this module talks about the representation of a data constructor -what it means is the DataCon with all Unpacking having been applied. -We can think of this as the Core representation. - -Here's an example illustrating the Core representation: - data Ord a => T a = MkT Int! a Void# -Here - T :: Ord a => Int -> a -> Void# -> T a -but the rep type is - Trep :: Int# -> a -> Void# -> T a -Actually, the unboxed part isn't implemented yet! - -Note that this representation is still *different* from runtime -representation. (Which is what STG uses after unarise). - -This is how T would end up being used in STG post-unarise: - - let x = T 1# y - in ... - case x of - T int a -> ... - -The Void# argument is dropped and the boxed int is replaced by an unboxed -one. In essence we only generate binders for runtime relevant values. - -We also flatten out unboxed tuples in this process. See the unarise -pass for details on how this is done. But as an example consider -`data S = MkS Bool (# Bool | Char #)` which when matched on would -result in an alternative with three binders like this - - MkS bool tag tpl_field -> - -See Note [Translating unboxed sums to unboxed tuples] and Note [Unarisation] -for the details of this transformation. - - ************************************************************************ * * \subsection{Instances} @@ -1151,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 @@ -1165,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 @@ -1190,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 @@ -1215,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 @@ -1232,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, @@ -1272,18 +1226,16 @@ -- 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 -- clash in name or unique with the universal/existential ones. -- Tiresome! And unnecessary because these tyvars are never looked at - prom_theta_bndrs = [ mkInvisAnonTyConBinder (mkTyVar n t) - {- Invisible -} | (n,t) <- fresh_names `zip` theta ] prom_arg_bndrs = [ mkAnonTyConBinder (mkTyVar n t) {- Visible -} | (n,t) <- dropList theta fresh_names `zip` map scaledThing orig_arg_tys ] - prom_bndrs = prom_tv_bndrs ++ prom_theta_bndrs ++ prom_arg_bndrs + prom_bndrs = prom_tv_bndrs ++ prom_arg_bndrs prom_res_kind = orig_res_ty promoted = mkPromotedDataCon con name prom_info prom_bndrs prom_res_kind roles rep_info @@ -1301,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) @@ -1357,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. @@ -1382,7 +1343,7 @@ = [ EqSpec tv ty | cv <- ex_tcvs , isCoVar cv - , let (_, _, ty1, ty, _) = coVarKindsTypesRole cv + , let (ty1, ty, _) = coVarTypesRole cv tv = getTyVar ty1 ] @@ -1452,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 @@ -1479,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 @@ -1609,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 @@ -1621,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 @@ -1737,13 +1711,25 @@ -- evidence, after any flattening has been done and without substituting for -- any type variables dataConRepArgTys :: DataCon -> [Scaled Type] -dataConRepArgTys (MkData { dcRep = rep - , dcEqSpec = eq_spec +dataConRepArgTys (MkData { dcRep = rep + , dcEqSpec = eq_spec , dcOtherTheta = theta - , dcOrigArgTys = orig_arg_tys }) + , dcOrigArgTys = orig_arg_tys + , dcRepTyCon = tc }) = case rep of - NoDataConRep -> assert (null eq_spec) $ map unrestricted theta ++ orig_arg_tys DCR { dcr_arg_tys = arg_tys } -> arg_tys + NoDataConRep + | isTypeDataTyCon tc -> assert (null theta) $ + orig_arg_tys + -- `type data` declarations can be GADTs (and hence have an eq_spec) + -- but no wrapper. They cannot have a theta. + -- See Note [Type data declarations] in GHC.Rename.Module + -- You might wonder why we ever call dataConRepArgTys for `type data`; + -- I think it's because of the call in mkDataCon, which in turn feeds + -- into dcRepArity, which in turn is used in mkDataConWorkId. + -- c.f. #23022 + | otherwise -> assert (null eq_spec) $ + map unrestricted theta ++ orig_arg_tys -- | The string @package:module.name@ identifying a constructor, which is attached -- to its info table and used by the GHCi debugger and the heap profiler @@ -1806,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 @@ -1917,36 +1908,63 @@ , dcExTyCoVars = ex_tvs , dcEqSpec = eq_spec }) -- use of sets here: (R1) from the Note - = mkUnVarSet depleted_worker_vars == mkUnVarSet depleted_wrapper_vars && + = mkUnVarSet depleted_worker_vars == mkUnVarSet wrapper_vars && all (not . is_eq_spec_var) wrapper_vars where - is_constraint_var v = typeTypeOrConstraint (tyVarKind v) == ConstraintLike - -- implements (R3) from the Note - worker_vars = univ_tvs ++ ex_tvs eq_spec_tvs = mkUnVarSet (map eqSpecTyVar eq_spec) is_eq_spec_var = (`elemUnVarSet` eq_spec_tvs) -- (R2) from the Note - depleted_worker_vars = filterOut (is_eq_spec_var <||> is_constraint_var) - worker_vars + depleted_worker_vars = filterOut is_eq_spec_var worker_vars wrapper_vars = dataConUserTyVars dc - depleted_wrapper_vars = filterOut is_constraint_var wrapper_vars -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 @@ -11,7 +11,7 @@ FamInst(..), FamFlavor(..), famInstAxiom, famInstTyCon, famInstRHS, famInstsRepTyCons, famInstRepTyCon_maybe, dataFamInstRepTyCon, pprFamInst, pprFamInsts, orphNamesOfFamInst, - mkImportedFamInst, + mkImportedFamInst, mkLocalFamInst, FamInstEnvs, FamInstEnv, emptyFamInstEnv, emptyFamInstEnvs, unionFamInstEnv, extendFamInstEnv, extendFamInstEnvList, @@ -38,9 +38,11 @@ import GHC.Prelude +import GHC.Core( IsOrphan, chooseOrphanAnchor ) 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 @@ -48,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 ) + {- ************************************************************************ * * @@ -126,6 +131,8 @@ -- in GHC.Core.Coercion.Axiom , fi_rhs :: Type -- the RHS, with its freshened vars + + , fi_orphan :: IsOrphan } data FamFlavor @@ -241,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 @@ -254,6 +261,36 @@ pprFamInsts :: [FamInst] -> SDoc pprFamInsts finsts = vcat (map pprFamInst finsts) +{- ********************************************************************* +* * + Making FamInsts +* * +********************************************************************* -} + +mkLocalFamInst :: FamFlavor -> CoAxiom Unbranched + -> [TyVar] -> [CoVar] -> [Type] -> Type + -> FamInst +mkLocalFamInst flavor axiom tvs cvs lhs rhs + = FamInst { fi_fam = fam_tc_name + , fi_flavor = flavor + , fi_tcs = roughMatchTcs lhs + , fi_tvs = tvs + , fi_cvs = cvs + , fi_tys = lhs + , fi_rhs = rhs + , fi_axiom = axiom + , fi_orphan = chooseOrphanAnchor orph_names } + where + mod = assert (isExternalName (coAxiomName axiom)) $ + nameModule (coAxiomName axiom) + is_local name = nameIsLocalOrFrom mod name + + orph_names = filterNameSet is_local $ + orphNamesOfAxiomLHS axiom `extendNameSet` fam_tc_name + + fam_tc_name = tyConName (coAxiomTyCon axiom) + + {- Note [Lazy axiom match] ~~~~~~~~~~~~~~~~~~~~~~~ @@ -277,8 +314,9 @@ mkImportedFamInst :: Name -- Name of the family -> [RoughMatchTc] -- Rough match info -> CoAxiom Unbranched -- Axiom introduced + -> IsOrphan -> FamInst -- Resulting family instance -mkImportedFamInst fam mb_tcs axiom +mkImportedFamInst fam mb_tcs axiom orphan = FamInst { fi_fam = fam, fi_tcs = mb_tcs, @@ -287,7 +325,8 @@ fi_tys = tys, fi_rhs = rhs, fi_axiom = axiom, - fi_flavor = flavor } + fi_flavor = flavor, + fi_orphan = orphan } where -- See Note [Lazy axiom match] ~(CoAxBranch { cab_lhs = tys @@ -335,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] @@ -449,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] ~~~~~~~~~~~~~~~~~~~~ @@ -474,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: @@ -541,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 @@ -572,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] @@ -1155,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 @@ -1191,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 @@ -1214,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 @@ -1306,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 @@ -7,18 +7,19 @@ The bits common to GHC.Tc.TyCl.Instance and GHC.Tc.Deriv. -} -{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveDataTypeable, DeriveGeneric #-} module GHC.Core.InstEnv ( DFunId, InstMatch, ClsInstLookupResult, - PotentialUnifiers(..), getPotentialUnifiers, nullUnifiers, + CanonicalEvidence(..), PotentialUnifiers(..), getCoherentUnifiers, nullUnifiers, OverlapFlag(..), OverlapMode(..), setOverlapModeMaybe, - ClsInst(..), DFunInstType, pprInstance, pprInstanceHdr, pprInstances, - instanceHead, instanceSig, mkLocalInstance, mkImportedInstance, + ClsInst(..), DFunInstType, pprInstance, pprInstanceHdr, pprDFunId, pprInstances, + instanceWarning, instanceHead, instanceSig, mkLocalClsInst, mkImportedClsInst, instanceDFunId, updateClsInstDFuns, updateClsInstDFun, fuzzyClsInstCmp, orphNamesOfClsInst, InstEnvs(..), VisibleOrphanModules, InstEnv, + LookupInstanceErrReason (..), mkInstEnv, emptyInstEnv, unionInstEnv, extendInstEnv, filterInstEnv, deleteFromInstEnv, deleteDFunFromInstEnv, anyInstEnv, @@ -40,8 +41,11 @@ import GHC.Core.RoughMap 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 @@ -50,14 +54,14 @@ import GHC.Types.Name.Set import GHC.Types.Basic import GHC.Types.Id +import GHC.Generics (Generic) import Data.Data ( Data ) import Data.List.NonEmpty ( NonEmpty (..), nonEmpty ) import qualified Data.List.NonEmpty as NE import Data.Maybe ( isJust ) -import GHC.Utils.Outputable +import GHC.Utils.Outputable hiding ((<>)) import GHC.Utils.Panic -import GHC.Utils.Panic.Plain import Data.Semigroup {- @@ -105,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 @@ -119,10 +127,11 @@ cmp (RM_KnownTc _, RM_WildCard) = GT cmp (RM_KnownTc x, RM_KnownTc y) = stableNameCmp x y -isOverlappable, isOverlapping, isIncoherent :: ClsInst -> Bool +isOverlappable, isOverlapping, isIncoherent, isNonCanonical :: ClsInst -> Bool isOverlappable i = hasOverlappableFlag (overlapMode (is_flag i)) isOverlapping i = hasOverlappingFlag (overlapMode (is_flag i)) isIncoherent i = hasIncoherentFlag (overlapMode (is_flag i)) +isNonCanonical i = hasNonCanonicalFlag (overlapMode (is_flag i)) {- Note [ClsInst laziness and the rough-match fields] @@ -165,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] ~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -214,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 @@ -225,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 }) @@ -255,19 +281,20 @@ -- Decomposes the DFunId instanceSig ispec = tcSplitDFunTy (idType (is_dfun ispec)) -mkLocalInstance :: DFunId -> OverlapFlag - -> [TyVar] -> Class -> [Type] - -> ClsInst +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. -mkLocalInstance 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 @@ -298,24 +325,26 @@ choose_one nss = chooseOrphanAnchor (unionNameSets nss) -mkImportedInstance :: 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? - -> ClsInst +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 -mkImportedInstance 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) @@ -570,57 +599,93 @@ 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" - if it has an INCOHERENT pragma, or - if it appears in a module compiled with -XIncoherentInstances. + * 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" - if it has an OVERLAPPABLE or OVERLAPS pragma, or - if it appears in a module compiled with -XOverlappingInstances, or + * 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" - if it has an OVERLAPPING or OVERLAPS pragma, or - if it appears in a module compiled with -XOverlappingInstances, or + * 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. - compiled with -XOverlappingInstances. Now suppose that, in some client module, we are searching for an instance of the target constraint (C ty1 .. tyn). The search works like this. -* 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*. +(IL0) If there are any local Givens that match (potentially unifying + any metavariables, even untouchable ones) the target constraint, + 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. -* Eliminate any candidate `IX` for which both of the following hold: +(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. - - There is another candidate `IY` that is strictly more specific; that - is, `IY` is a substitution instance of `IX` but not vice versa. +(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). - - Either `IX` is *overlappable*, or `IY` is *overlapping*. (This - "either/or" design, rather than a "both/and" design, allow a - client to deliberately override an instance from a library, - without requiring a change to the library.) +(IL3) Eliminate any candidate `IX` for which there is another candidate `IY` such + that both of the following hold: + - `IY` is strictly more specific than `IX`. That is, `IY` is a + substitution instance of `IX` but not vice versa. + - Either `IX` is *overlappable*, or `IY` is *overlapping*. (This + "either/or" design, rather than a "both/and" design, allow a + client to deliberately override an instance from a library, + without requiring a change to the library.) -- If exactly one non-incoherent candidate remains, select it. If all - remaining candidates are incoherent, select an arbitrary one. - Otherwise the search fails (i.e. when more than one surviving - candidate is not incoherent). + 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.) -- If the selected candidate (from the previous step) is incoherent, the - search succeeds, returning that candidate. + This is implemented by `pruneOverlappedMatches`, producing final_matches in + lookupInstEnv. See Note [Instance overlap and guards] and + Note [Incoherent instances]. -- If not, 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, the search succeeds, returning the selected candidate; if - not, 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 @@ -747,6 +812,185 @@ But still x and y might subsequently be unified so they *do* match. Simple story: unify, don't match. + +Note [Coherence and specialisation: overview] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +GHC's specialiser relies on the Coherence Assumption: that if + 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. 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) + + instance C a => C (Maybe a) where {...} -- (I3) + instance {-# INCOHERENT #-} C (Maybe Int) where {...} -- (I4) + instance C Int where {...} -- (I5) + +* When solving (C tys) from the top-level instances, we generally insist that + there is a unique, most-specific match. (Incoherent instances change the + picture a bit: see Note [Rules for instance lookup].) Example: + [W] C [Int] -- Pick (I2) + [W] C [Char] -- Pick (I1); does not match (I2) + + Caveat: if different usage sites see different instances (which the + 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]? 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 + the simplifier inlines a call (risky @Int) we'll get a dictionary of type + (C [Int]) built by (I1), which might be utterly different to the dictionary + of type (C [Int]) built by (I2). That breaks the Coherence Assumption. + + So GHC declines to pick either, and rejects `risky`. You have to write a + different signature + notRisky :: C [b] => b -> Int + notRisky x = op [x] + so that the dictionary is resolved at the call site. + +* The INCOHERENT pragma tells GHC to choose an instance anyway: see + Note [Rules for instance lookup] step (IL6). Suppose we have + veryRisky :: C b => b -> Int + veryRisky x = op (Just x) + So we have [W] C (Maybe b). Because (I4) is INCOHERENT, GHC is allowed to + pick (I3). Of course, this risks breaking the Coherence Assumption, as + described above. + +* What about the incoherence from step (IL4)? For example + class D a b where { opD :: a -> b -> String } + instance {-# INCOHERENT #-} D Int b where {...} -- (I7) + instance {-# INCOHERENT #-} D a Int where {...} -- (I8) + + g (x::Int) = opD x x -- [W] D Int Int + + Here both (I7) and (I8) match, GHC picks an arbitrary one. + +So INCOHERENT may break the Coherence Assumption. But sometimes that +is fine, because the programmer promises that it doesn't matter which +one is chosen. A good example is in the `optics` library: + + data IxEq i is js where { IxEq :: IxEq i is is } + + class AppendIndices xs ys ks | xs ys -> ks where + appendIndices :: IxEq i (Curry xs (Curry ys i)) (Curry ks i) + + instance {-# INCOHERENT #-} xs ~ zs => AppendIndices xs '[] zs where + appendIndices = IxEq + + instance ys ~ zs => AppendIndices '[] ys zs where + appendIndices = IxEq + +Here `xs` and `ys` are type-level lists, and for type inference purposes we want to +solve the `AppendIndices` constraint when /either/ of them are the empty list. The +dictionaries are the same in both cases (indeed the dictionary type is a singleton!), +so we really don't care which is used. See #23287 for discussion. + + +In short, sometimes we want to specialise on these incoherently-selected dictionaries, +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 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. + + 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" 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 + arguments. + +To see the transitive closure issue, consider + deeplyRisky :: C b => b -> Int + deeplyRisky x = op (Just (Just x)) + +From (op (Just (Just x))) we get + [W] d1 : C (Maybe (Maybe b)) +which we solve (coherently!) via (I3), giving + [W] d2 : C (Maybe b) +Now we can only solve this incoherently. So we end up with + + deeplyRisky @b (d1 :: C b) + = op @(Maybe (Maybe b)) d1 + where + d1 :: C (Maybe (Maybe b)) = $dfI3 d2 -- Coherent decision + d2 :: C (Maybe b) = $sfI3 d1 -- Incoherent decision + +So `d2` is incoherent, and hence (transitively) so is `d1`. + +Here are the moving parts: + +* GHC.Core.InstEnv.lookupInstEnv tells if any incoherent unifiers were discarded + 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. + +* 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 @@ -826,51 +1070,131 @@ -- yield 'Left errorMessage'. lookupUniqueInstEnv :: InstEnvs -> Class -> [Type] - -> Either SDoc (ClsInst, [Type]) + -> Either LookupInstanceErrReason (ClsInst, [Type]) lookupUniqueInstEnv instEnv cls tys = case lookupInstEnv False instEnv cls tys of ([(inst, inst_tys)], _, _) | noFlexiVar -> Right (inst, inst_tys') - | otherwise -> Left $ text "flexible type variable:" <+> - (ppr $ mkTyConApp (classTyCon cls) tys) + | otherwise -> Left $ LookupInstErrFlexiVar where inst_tys' = [ty | Just ty <- inst_tys] noFlexiVar = all isJust inst_tys - _other -> Left $ text "instance not found" <+> - (ppr $ mkTyConApp (classTyCon cls) tys) + _other -> Left $ LookupInstErrNotFound -data PotentialUnifiers = NoUnifiers - | OneOrMoreUnifiers [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. +-- | Why a particular typeclass application couldn't be looked up. +data LookupInstanceErrReason = + -- | Tyvars aren't an exact match. + LookupInstErrNotExact + | + -- | One of the tyvars is flexible. + LookupInstErrFlexiVar + | + -- | No matching instance was found. + LookupInstErrNotFound + deriving (Generic) +-- | `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 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 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. + +If this hurdle is passed, i.e. we have a unique solution up to +`INCOHERENT` instances, the specialiser needs to know if that unique +solution is canonical or not (see Note [Coherence and specialisation: +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 = text "NoUnifiers" - ppr xs = ppr (getPotentialUnifiers xs) + ppr (NoUnifiers c) = text "NoUnifiers" <+> ppr c + ppr xs = ppr (getCoherentUnifiers xs) instance Semigroup PotentialUnifiers where - NoUnifiers <> u = u - u <> NoUnifiers = u - u1 <> u2 = OneOrMoreUnifiers (getPotentialUnifiers u1 ++ getPotentialUnifiers u2) - -instance Monoid PotentialUnifiers where - mempty = NoUnifiers + NoUnifiers c1 <> NoUnifiers c2 = NoUnifiers (c1 `andCanEv` c2) + NoUnifiers _ <> u = u + OneOrMoreUnifiers (unifier :| unifiers) <> u + = OneOrMoreUnifiers (unifier :| (unifiers <> getCoherentUnifiers u)) -getPotentialUnifiers :: PotentialUnifiers -> [ClsInst] -getPotentialUnifiers NoUnifiers = [] -getPotentialUnifiers (OneOrMoreUnifiers cls) = cls +getCoherentUnifiers :: PotentialUnifiers -> [ClsInst] +getCoherentUnifiers NoUnifiers{} = [] +getCoherentUnifiers (OneOrMoreUnifiers cls) = NE.toList cls +-- | Are there no *coherent* unifiers? nullUnifiers :: PotentialUnifiers -> Bool -nullUnifiers NoUnifiers = True +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] @@ -882,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 @@ -896,22 +1220,23 @@ | Just subst <- tcMatchTys tpl_tys tys = ((item, map (lookupTyVar subst) tpl_tvs) : acc) + | otherwise = acc + 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 - 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] - -- 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) $$ @@ -919,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 @@ -950,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 - all_matches = home_matches ++ pkg_matches - all_unifs = home_unifs `mappend` pkg_unifs + -- (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 @@ -966,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 - _ -> 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] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1145,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 Nove [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 @@ -1279,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 @@ -1298,7 +1657,12 @@ The implementation is in insert_overlapping, where we remove matching incoherent instances as long as there are others. - +If the choice of instance *does* matter, all bets are still not off: +users can consult the detailed specification of the instance selection +algorithm in the GHC Users' Manual. However, this means we can end up +with different instances at the same types at different parts of the +program, and this difference has to be preserved. Note [Coherence and +specialisation: overview] details how we achieve that. ************************************************************************ * * @@ -1307,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] @@ -1330,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.Session +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 centra 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 @@ -31,3531 +31,3918 @@ import GHC.Prelude -import GHC.Driver.Session - -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.Coercion.Opt ( checkAxInstCo ) -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%. - - -************************************************************************ -* * - 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.MCDump noSrcSpan - $ 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 - -- If the Core linter encounters an error, output to stderr instead of - -- stdout (#13342) - = logMsg logger Err.MCInfo noSrcSpan - $ 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 - - -- dups_ext 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 (removeDups ord_ext (map Var.varName binders)) - ord_ext n1 n2 | Just m1 <- nameModule_maybe n1 - , Just m2 <- nameModule_maybe n2 - = compare (m1, nameOccName n1) (m2, nameOccName n2) - | otherwise = LT - -{- -************************************************************************ -* * -\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 - - ; 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 () - --- | 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 ensureSubUsage lhs mult (err_msg mult) - return $ deleteUE body_ue lam_var - Nothing -> return body_ue -- A type variable - where - lhs = lookupUE body_ue lam_var - err_msg mult = text "Linearity failure in lambda:" <+> ppr lam_var - $$ ppr lhs <+> text "⊈" <+> ppr mult - -{- 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 _ _ _ alt_ty (Alt DEFAULT args rhs) = - do { lintL (null args) (mkDefaultArgsMsg args) - ; lintAltExpr rhs alt_ty } - -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) - ; lintAltExpr rhs alt_ty } - 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 - { -- First instantiate the universally quantified - -- type variables of the data constructor - -- We've already check - lintL (tycon == dataConTyCon con) (mkBadConMsg tycon con) - ; 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)) } - -{- -************************************************************************ -* * - 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 }) errs -> - unLintM m (env { le_ids = extendVarEnv id_set id (id, linted_ty) - , le_joins = add_joins join_set }) errs - 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 - ; 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 = hang (text "Occurrence is GlobalId, but binding is LocalId") - 2 (pprBndr LetBind id_occ) - 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 -> unitUE id OneTy - 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.Driver.DynFlags + +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,12 +1,11 @@ -{-# 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, - mkWildValBinder, mkWildEvBinder, + mkCoreApp, mkCoreApps, mkCoreConApps, mkCoreConWrapApps, + mkCoreLams, mkCoreTyLams, + mkWildCase, mkIfThenElse, + mkWildValBinder, mkSingleAltCase, sortQuantVars, castBottomExpr, @@ -54,7 +53,7 @@ import GHC.Platform import GHC.Types.Id -import GHC.Types.Var ( EvVar, setTyVarUnique, visArgConstraintLike ) +import GHC.Types.Var ( setTyVarUnique, visArgConstraintLike ) import GHC.Types.TyThing import GHC.Types.Id.Info import GHC.Types.Cpr @@ -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 @@ -173,9 +189,6 @@ * * ********************************************************************* -} -mkWildEvBinder :: PredType -> EvVar -mkWildEvBinder pred = mkWildValBinder ManyTy pred - -- | Make a /wildcard binder/. This is typically used when you need a binder -- that you expect to use only at a *binding* site. Do not use it at -- occurrence sites because it has a single, fixed unique, and it's very @@ -227,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) {- ************************************************************************ @@ -472,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 @@ -502,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`. @@ -559,7 +572,8 @@ where n_xs = length xs split [] = [] - split xs = take mAX_TUPLE_SIZE xs : split (drop mAX_TUPLE_SIZE xs) + split xs = let (as, bs) = splitAt mAX_TUPLE_SIZE xs + in as : split bs {- @@ -611,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 @@ -651,12 +670,12 @@ -- To avoid shadowing, we use uniques to invent new variables. -- -- If necessary we pattern match on a "big" tuple. -mkBigTupleCase :: UniqSupply -- ^ For inventing names of intermediate variables - -> [Id] -- ^ The tuple identifiers to pattern match on; +mkBigTupleCase :: MonadUnique m -- For inventing names of intermediate variables + => [Id] -- ^ The tuple identifiers to pattern match on; -- Bring these into scope in the body -> CoreExpr -- ^ Body of the case -> CoreExpr -- ^ Scrutinee - -> CoreExpr + -> m CoreExpr -- ToDo: eliminate cases where none of the variables are needed. -- -- mkBigTupleCase uniqs [a,b,c,d] body v e @@ -664,11 +683,11 @@ -- case p of p { (a,b) -> -- case q of q { (c,d) -> -- body }}} -mkBigTupleCase us vars body scrut - = mk_tuple_case wrapped_us (chunkify wrapped_vars) wrapped_body +mkBigTupleCase vars body scrut + = do us <- getUniqueSupplyM + let (wrapped_us, wrapped_vars, wrapped_body) = foldr unwrap (us,[],body) vars + return $ mk_tuple_case wrapped_us (chunkify wrapped_vars) wrapped_body where - (wrapped_us, wrapped_vars, wrapped_body) = foldr unwrap (us,[],body) vars - scrut_ty = exprType scrut unwrap var (us,vars,body) @@ -910,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 @@ -1082,8 +1101,9 @@ mkImpossibleExpr res_ty str = mkRuntimeErrorApp err_id res_ty str where -- See Note [Type vs Constraint for error ids] - err_id | isConstraintLikeKind (typeKind res_ty) = iMPOSSIBLE_CONSTRAINT_ERROR_ID - | otherwise = iMPOSSIBLE_ERROR_ID + err_id = case typeTypeOrConstraint res_ty of + TypeLike -> iMPOSSIBLE_ERROR_ID + ConstraintLike -> iMPOSSIBLE_CONSTRAINT_ERROR_ID {- Note [Type vs Constraint for error ids] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1207,8 +1227,9 @@ mkAbsentErrorApp res_ty err_msg = mkApps (Var err_id) [ Type res_ty, err_string ] where - err_id | isConstraintLikeKind (typeKind res_ty) = aBSENT_CONSTRAINT_ERROR_ID - | otherwise = aBSENT_ERROR_ID + err_id = case typeTypeOrConstraint res_ty of + TypeLike -> aBSENT_ERROR_ID + ConstraintLike -> aBSENT_CONSTRAINT_ERROR_ID err_string = Lit (mkLitString err_msg) absentErrorName, absentConstraintErrorName :: Name @@ -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 } @@ -397,7 +403,7 @@ CharTyLit n -> m { tlm_char = Map.alter f n (tlm_char m) } foldTyLit :: (a -> b -> b) -> TyLitMap a -> b -> b -foldTyLit l m = flip (foldUFM l) (tlm_string m) +foldTyLit l m = flip (nonDetFoldUFM l) (tlm_string m) . flip (Map.foldr l) (tlm_number m) . flip (Map.foldr l) (tlm_char m) @@ -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 ) {- @@ -134,6 +137,9 @@ -- Join points are supposed to have manifestly-visible -- lambdas at the top: no ticks, no casts, nothing -- Moreover, type lambdas count in JoinArity +-- NB: For non-recursive bindings, the join arity of the binding may actually be +-- less that the number of manifestly-visible lambdas. +-- See Note [Join arity prediction based on joinRhsArity] in GHC.Core.Opt.OccurAnal joinRhsArity (Lam _ e) = 1 + joinRhsArity e joinRhsArity _ = 0 @@ -195,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 @@ -510,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 @@ -713,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 @@ -915,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 @@ -947,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 = [] @@ -963,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] ~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1081,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 @@ -1100,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 @@ -1232,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 @@ -1316,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) @@ -1357,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 @@ -1456,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 @@ -1526,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] @@ -1873,15 +1948,14 @@ \(y::Int). let j' :: Int -> Bool j' x = e y in b[j'/j] y -where I have written to stress that j's type has +where I have written b[j'/j] to stress that j's type has changed. Note that (of course!) we have to push the application inside the RHS of the join as well as into the body. AND if j 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.) @@ -2036,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 @@ -2053,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. @@ -2108,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) @@ -2178,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 @@ -2224,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 @@ -2271,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 {- ************************************************************************ @@ -2414,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. @@ -2681,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 @@ -2704,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) --------------- @@ -2717,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 @@ -2741,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) @@ -2755,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" @@ -2930,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 @@ -2952,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 @@ -3047,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. - -} {- ********************************************************************* @@ -3105,7 +3212,7 @@ -- Adds as many binders as asked for; assumes expr is not a lambda etaBodyForJoinPoint :: Int -> CoreExpr -> ([CoreBndr], CoreExpr) etaBodyForJoinPoint need_args body - = go need_args (exprType body) (init_subst body) [] body + = go need_args body_ty (mkEmptySubst in_scope) [] body where go 0 _ _ rev_bs e = (reverse rev_bs, e) @@ -3124,9 +3231,16 @@ = pprPanic "etaBodyForJoinPoint" $ int need_args $$ ppr body $$ ppr (exprType body) - init_subst e = mkEmptySubst (mkInScopeSet (exprFreeVars e)) - - + body_ty = exprType body + in_scope = mkInScopeSet (exprFreeVars body `unionVarSet` tyCoVarsOfType body_ty) + -- in_scope is a bit tricky. + -- - We are wrapping `body` in some value lambdas, so must not shadow + -- any free vars of `body` + -- - We are wrapping `body` in some type lambdas, so must not shadow any + -- tyvars in body_ty. Example: body is just a variable + -- (g :: forall (a::k). T k a -> Int) + -- We must not shadown that `k` when adding the /\a. So treat the free vars + -- of body_ty as in-scope. Showed up in #23026. -------------- freshEtaId :: Int -> Subst -> Scaled Type -> (Subst, Id) @@ -3141,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 @@ -53,8 +49,8 @@ reverse mapping. -Note [Shadowing] -~~~~~~~~~~~~~~~~ +Note [Shadowing in CSE] +~~~~~~~~~~~~~~~~~~~~~~~ We have to be careful about shadowing. For example, consider f = \x -> let y = x+x in @@ -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 @@ -900,7 +906,7 @@ extendCSSubst cse x rhs = cse { cs_subst = extendSubst (cs_subst cse) x rhs } -- | Add clones to the substitution to deal with shadowing. See --- Note [Shadowing] for more details. You should call this whenever +-- Note [Shadowing in CSE] for more details. You should call this whenever -- you go under a binder. addBinder :: CSEnv -> Var -> (CSEnv, Var) addBinder cse v = (cse { cs_subst = sub' }, v') @@ -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.hs b/GHC/Core/Opt/CallerCC.hs --- a/GHC/Core/Opt/CallerCC.hs +++ b/GHC/Core/Opt/CallerCC.hs @@ -15,18 +15,15 @@ , parseCallerCcFilter ) where -import Data.Word (Word8) import Data.Maybe import Control.Applicative import GHC.Utils.Monad.State.Strict -import Data.Either import Control.Monad -import qualified Text.ParserCombinators.ReadP as P import GHC.Prelude import GHC.Utils.Outputable as Outputable -import GHC.Driver.Session +import GHC.Driver.DynFlags import GHC.Types.CostCentre import GHC.Types.CostCentre.State import GHC.Types.Name hiding (varName) @@ -38,11 +35,8 @@ import GHC.Data.FastString import GHC.Core import GHC.Core.Opt.Monad -import GHC.Utils.Panic -import qualified GHC.Utils.Binary as B -import Data.Char +import GHC.Core.Opt.CallerCC.Types -import Language.Haskell.Syntax.Module.Name addCallerCostCentres :: ModGuts -> CoreM ModGuts addCallerCostCentres guts = do @@ -138,91 +132,4 @@ Nothing -> True checkFunc = occNameMatches (ccfFuncName ccf) (getOccName i) - -data NamePattern - = PChar Char NamePattern - | PWildcard NamePattern - | PEnd - -instance Outputable NamePattern where - ppr (PChar c rest) = char c <> ppr rest - ppr (PWildcard rest) = char '*' <> ppr rest - ppr PEnd = Outputable.empty - -instance B.Binary NamePattern where - get bh = do - tag <- B.get bh - case tag :: Word8 of - 0 -> PChar <$> B.get bh <*> B.get bh - 1 -> PWildcard <$> B.get bh - 2 -> pure PEnd - _ -> panic "Binary(NamePattern): Invalid tag" - put_ bh (PChar x y) = B.put_ bh (0 :: Word8) >> B.put_ bh x >> B.put_ bh y - put_ bh (PWildcard x) = B.put_ bh (1 :: Word8) >> B.put_ bh x - put_ bh PEnd = B.put_ bh (2 :: Word8) - -occNameMatches :: NamePattern -> OccName -> Bool -occNameMatches pat = go pat . occNameString - where - go :: NamePattern -> String -> Bool - go PEnd "" = True - go (PChar c rest) (d:s) - = d == c && go rest s - go (PWildcard rest) s - = go rest s || go (PWildcard rest) (tail s) - go _ _ = False - -type Parser = P.ReadP - -parseNamePattern :: Parser NamePattern -parseNamePattern = pattern - where - pattern = star P.<++ wildcard P.<++ char P.<++ end - star = PChar '*' <$ P.string "\\*" <*> pattern - wildcard = do - void $ P.char '*' - PWildcard <$> pattern - char = PChar <$> P.get <*> pattern - end = PEnd <$ P.eof - -data CallerCcFilter - = CallerCcFilter { ccfModuleName :: Maybe ModuleName - , ccfFuncName :: NamePattern - } - -instance Outputable CallerCcFilter where - ppr ccf = - maybe (char '*') ppr (ccfModuleName ccf) - <> char '.' - <> ppr (ccfFuncName ccf) - -instance B.Binary CallerCcFilter where - get bh = CallerCcFilter <$> B.get bh <*> B.get bh - put_ bh (CallerCcFilter x y) = B.put_ bh x >> B.put_ bh y - -parseCallerCcFilter :: String -> Either String CallerCcFilter -parseCallerCcFilter inp = - case P.readP_to_S parseCallerCcFilter' inp of - ((result, ""):_) -> Right result - _ -> Left $ "parse error on " ++ inp - -parseCallerCcFilter' :: Parser CallerCcFilter -parseCallerCcFilter' = - CallerCcFilter - <$> moduleFilter - <* P.char '.' - <*> parseNamePattern - where - moduleFilter :: Parser (Maybe ModuleName) - moduleFilter = - (Just . mkModuleName <$> moduleName) - <|> - (Nothing <$ P.char '*') - - moduleName :: Parser String - moduleName = do - c <- P.satisfy isUpper - cs <- P.munch1 (\c -> isUpper c || isLower c || isDigit c || c == '_') - rest <- optional $ P.char '.' >> fmap ('.':) moduleName - return $ c : (cs ++ fromMaybe "" rest) diff --git a/GHC/Core/Opt/CallerCC.hs-boot b/GHC/Core/Opt/CallerCC.hs-boot deleted file mode 100644 --- a/GHC/Core/Opt/CallerCC.hs-boot +++ /dev/null @@ -1,8 +0,0 @@ -module GHC.Core.Opt.CallerCC where - -import GHC.Prelude - --- Necessary due to import in GHC.Driver.Session. -data CallerCcFilter - -parseCallerCcFilter :: String -> Either String CallerCcFilter diff --git a/GHC/Core/Opt/CallerCC/Types.hs b/GHC/Core/Opt/CallerCC/Types.hs new file mode 100644 --- /dev/null +++ b/GHC/Core/Opt/CallerCC/Types.hs @@ -0,0 +1,122 @@ +module GHC.Core.Opt.CallerCC.Types ( NamePattern(..) + , CallerCcFilter(..) + , occNameMatches + , parseCallerCcFilter + , parseNamePattern + ) where + +import Data.Word (Word8) +import Data.Maybe + +import Control.Applicative +import Data.Either +import Control.Monad +import qualified Text.ParserCombinators.ReadP as P + +import GHC.Prelude +import GHC.Utils.Outputable as Outputable +import GHC.Types.Name hiding (varName) +import GHC.Utils.Panic +import qualified GHC.Utils.Binary as B +import Data.Char +import Control.DeepSeq + +import Language.Haskell.Syntax.Module.Name + + +data NamePattern + = PChar Char NamePattern + | PWildcard NamePattern + | PEnd + +instance Outputable NamePattern where + ppr (PChar c rest) = char c <> ppr rest + 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 + case tag :: Word8 of + 0 -> PChar <$> B.get bh <*> B.get bh + 1 -> PWildcard <$> B.get bh + 2 -> pure PEnd + _ -> panic "Binary(NamePattern): Invalid tag" + put_ bh (PChar x y) = B.put_ bh (0 :: Word8) >> B.put_ bh x >> B.put_ bh y + put_ bh (PWildcard x) = B.put_ bh (1 :: Word8) >> B.put_ bh x + put_ bh PEnd = B.put_ bh (2 :: Word8) + +occNameMatches :: NamePattern -> OccName -> Bool +occNameMatches pat = go pat . occNameString + where + go :: NamePattern -> String -> Bool + go PEnd "" = True + go (PChar c rest) (d:s) + = d == c && go rest s + go (PWildcard rest) s + = go rest s || go (PWildcard rest) (tail s) + go _ _ = False + + + +type Parser = P.ReadP + +parseNamePattern :: Parser NamePattern +parseNamePattern = namePattern + where + namePattern = star P.<++ wildcard P.<++ char P.<++ end + star = PChar '*' <$ P.string "\\*" <*> namePattern + wildcard = do + void $ P.char '*' + 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 = + maybe (char '*') ppr (ccfModuleName ccf) + <> char '.' + <> ppr (ccfFuncName ccf) + +instance B.Binary CallerCcFilter where + get bh = CallerCcFilter <$> B.get bh <*> B.get bh + put_ bh (CallerCcFilter x y) = B.put_ bh x >> B.put_ bh y + +parseCallerCcFilter :: String -> Either String CallerCcFilter +parseCallerCcFilter inp = + case P.readP_to_S parseCallerCcFilter' inp of + ((result, ""):_) -> Right result + _ -> Left $ "parse error on " ++ inp + +parseCallerCcFilter' :: Parser CallerCcFilter +parseCallerCcFilter' = + CallerCcFilter + <$> moduleFilter + <* P.char '.' + <*> parseNamePattern + where + moduleFilter :: Parser (Maybe ModuleName) + moduleFilter = + (Just . mkModuleName <$> moduleName) + <|> + (Nothing <$ P.char '*') + + moduleName :: Parser String + moduleName = do + c <- P.satisfy isUpper + cs <- P.munch1 (\c -> isUpper c || isLower c || isDigit c || c == '_') + rest <- optional $ P.char '.' >> fmap ('.':) moduleName + return $ c : (cs ++ fromMaybe "" rest) 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,19 +20,21 @@ {-# 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 ( primOpRules , builtinRules , caseRules + , caseRules2 ) where import GHC.Prelude import GHC.Platform +import GHC.Float import GHC.Types.Id.Make ( unboxedUnitExpr ) import GHC.Types.Id @@ -53,9 +55,8 @@ import GHC.Core.Type import GHC.Core.TyCo.Compare( eqType ) import GHC.Core.TyCon - ( tyConDataCons_maybe, isAlgTyCon, isEnumerationTyCon - , isNewTyCon, tyConDataCons - , tyConFamilySize ) + ( TyCon, tyConDataCons_maybe, tyConDataCons, tyConSingleDataCon, tyConFamilySize + , isEnumerationTyCon, isValidDTT2TyCon, isNewTyCon ) import GHC.Core.Map.Expr ( eqCoreExpr ) import GHC.Builtin.PrimOps ( PrimOp(..), tagToEnumKey ) @@ -64,13 +65,14 @@ import GHC.Builtin.Types.Prim import GHC.Builtin.Names +import GHC.Cmm.MachOp ( FMASign(..) ) +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 @@ -100,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 (+)) @@ -120,7 +123,9 @@ Int8QuotOp -> mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (int8Op2 quot) , leftZero , rightIdentity oneI8 - , equalArgs $> Lit oneI8 ] + , equalArgs $> Lit oneI8 + , quotFoldingRules int8Ops + ] Int8RemOp -> mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (int8Op2 rem) , leftZero , oneLit 1 $> Lit zeroI8 @@ -149,7 +154,9 @@ , mulFoldingRules Word8MulOp word8Ops ] Word8QuotOp -> mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (word8Op2 quot) - , rightIdentity oneW8 ] + , rightIdentity oneW8 + , quotFoldingRules word8Ops + ] Word8RemOp -> mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (word8Op2 rem) , leftZero , oneLit 1 $> Lit zeroW8 @@ -194,7 +201,9 @@ Int16QuotOp -> mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (int16Op2 quot) , leftZero , rightIdentity oneI16 - , equalArgs $> Lit oneI16 ] + , equalArgs $> Lit oneI16 + , quotFoldingRules int16Ops + ] Int16RemOp -> mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (int16Op2 rem) , leftZero , oneLit 1 $> Lit zeroI16 @@ -223,7 +232,9 @@ , mulFoldingRules Word16MulOp word16Ops ] Word16QuotOp-> mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (word16Op2 quot) - , rightIdentity oneW16 ] + , rightIdentity oneW16 + , quotFoldingRules word16Ops + ] Word16RemOp -> mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (word16Op2 rem) , leftZero , oneLit 1 $> Lit zeroW16 @@ -268,7 +279,9 @@ Int32QuotOp -> mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (int32Op2 quot) , leftZero , rightIdentity oneI32 - , equalArgs $> Lit oneI32 ] + , equalArgs $> Lit oneI32 + , quotFoldingRules int32Ops + ] Int32RemOp -> mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (int32Op2 rem) , leftZero , oneLit 1 $> Lit zeroI32 @@ -297,7 +310,9 @@ , mulFoldingRules Word32MulOp word32Ops ] Word32QuotOp-> mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (word32Op2 quot) - , rightIdentity oneW32 ] + , rightIdentity oneW32 + , quotFoldingRules word32Ops + ] Word32RemOp -> mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (word32Op2 rem) , leftZero , oneLit 1 $> Lit zeroW32 @@ -341,7 +356,9 @@ Int64QuotOp -> mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (int64Op2 quot) , leftZero , rightIdentity oneI64 - , equalArgs $> Lit oneI64 ] + , equalArgs $> Lit oneI64 + , quotFoldingRules int64Ops + ] Int64RemOp -> mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (int64Op2 rem) , leftZero , oneLit 1 $> Lit zeroI64 @@ -370,7 +387,9 @@ , mulFoldingRules Word64MulOp word64Ops ] Word64QuotOp-> mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (word64Op2 quot) - , rightIdentity oneW64 ] + , rightIdentity oneW64 + , quotFoldingRules word64Ops + ] Word64RemOp -> mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (word64Op2 rem) , leftZero , oneLit 1 $> Lit zeroW64 @@ -451,7 +470,9 @@ IntQuotOp -> mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (intOp2 quot) , leftZero , rightIdentityPlatform onei - , equalArgs >> retLit onei ] + , equalArgs >> retLit onei + , quotFoldingRules intOps + ] IntRemOp -> mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (intOp2 rem) , leftZero , oneLit 1 >> retLit zeroi @@ -503,7 +524,9 @@ , mulFoldingRules WordMulOp wordOps ] WordQuotOp -> mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (wordOp2 quot) - , rightIdentityPlatform onew ] + , rightIdentityPlatform onew + , quotFoldingRules wordOps + ] WordRemOp -> mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (wordOp2 rem) , leftZero , oneLit 1 >> retLit zerow @@ -634,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 @@ -656,6 +711,11 @@ FloatMulOp -> mkPrimOpRule nm 2 [ binaryLit (floatOp2 (*)) , identity onef , strengthReduction twof FloatAddOp ] + FloatFMAdd -> mkPrimOpRule nm 3 (fmaRules FMAdd W32) + FloatFMSub -> mkPrimOpRule nm 3 (fmaRules FMSub W32) + FloatFNMAdd -> mkPrimOpRule nm 3 (fmaRules FNMAdd W32) + FloatFNMSub -> mkPrimOpRule nm 3 (fmaRules FNMSub W32) + -- zeroElem zerof doesn't hold because of NaN FloatDivOp -> mkPrimOpRule nm 2 [ guardFloatDiv >> binaryLit (floatOp2 (/)) , rightIdentity onef ] @@ -671,6 +731,10 @@ DoubleMulOp -> mkPrimOpRule nm 2 [ binaryLit (doubleOp2 (*)) , identity oned , strengthReduction twod DoubleAddOp ] + DoubleFMAdd -> mkPrimOpRule nm 3 (fmaRules FMAdd W64) + DoubleFMSub -> mkPrimOpRule nm 3 (fmaRules FMSub W64) + DoubleFNMAdd -> mkPrimOpRule nm 3 (fmaRules FNMAdd W64) + DoubleFNMSub -> mkPrimOpRule nm 3 (fmaRules FNMSub W64) -- zeroElem zerod doesn't hold because of NaN DoubleDivOp -> mkPrimOpRule nm 2 [ guardDoubleDiv >> binaryLit (doubleOp2 (/)) , rightIdentity oned ] @@ -790,7 +854,6 @@ AddrAddOp -> mkPrimOpRule nm 2 [ rightIdentityPlatform zeroi ] - SeqOp -> mkPrimOpRule nm 4 [ seqRule ] SparkOp -> mkPrimOpRule nm 4 [ sparkRule ] _ -> Nothing @@ -1066,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 @@ -1118,6 +1181,150 @@ = Nothing -------------------------- + +-- | Constant folding rules for fused multiply-add operations. +fmaRules :: FMASign -> Width -> [RuleM CoreExpr] +fmaRules signs width = + [ fmaLit signs width + , fmaZero_z signs width + , fmaOne signs width ] + +-- | Compute @a * b + c@ when @a@, @b@, @c@ are all literals. +fmaLit :: FMASign -> Width -> RuleM CoreExpr +fmaLit signs width = do + env <- getRuleOpts + [Lit l1, Lit l2, Lit l3] <- getArgs + liftMaybe $ + op env + (convFloating env l1) + (convFloating env l2) + (convFloating env l3) + + where + op env l1 l2 l3 = + case width of + W32 + | LitFloat x <- l1 + , LitFloat y <- l2 + , LitFloat z <- l3 + -> Just $ mkFloatVal env $ + case signs of + FMAdd -> x * y + z + FMSub -> x * y - z + FNMAdd -> negate ( x * y ) + z + FNMSub -> negate ( x * y ) - z + W64 + | LitDouble x <- l1 + , LitDouble y <- l2 + , LitDouble z <- l3 + -> Just $ mkDoubleVal env $ + case signs of + FMAdd -> x * y + z + FMSub -> x * y - z + FNMAdd -> negate ( x * y ) + z + FNMSub -> negate ( x * y ) - z + _ -> Nothing + +-- | @x * y + 0 = x * y@. +fmaZero_z :: FMASign -> Width -> RuleM CoreExpr +fmaZero_z signs width = do + [x, y, Lit z] <- getArgs + let + -- TODO: we should additionally check the sign of z. + -- FMAdd, FNMAdd: should be -0.0. + -- FMSub, FNMSub: should be +0.0. + ok = + case width of + W32 + | LitFloat 0 <- z + -> True + W64 + | LitDouble 0 <- z + -> True + _ -> False + neg = case width of + W32 -> FloatNegOp + W64 -> DoubleNegOp + _ -> panic "fmaZero_xy: not Float# or Double#" + mul = case width of + W32 -> FloatMulOp + W64 -> DoubleMulOp + _ -> panic "fmaZero_z: not Float# or Double#" + if ok + then return $ case signs of + FMAdd -> Var (primOpId mul) `App` x `App` y + FMSub -> Var (primOpId mul) `App` x `App` y + FNMAdd -> Var (primOpId neg) `App` (Var (primOpId mul) `App` x `App` y) + FNMSub -> Var (primOpId neg) `App` (Var (primOpId mul) `App` x `App` y) + else mzero + +-- | @±1 * y + z ==> z ± y@ and @x * ±1 + z ==> z ± x@. +fmaOne :: FMASign -> Width -> RuleM CoreExpr +fmaOne signs width = do + [x, y, z] <- getArgs + let + posNegOne_maybe :: Rational -> Maybe Bool + posNegOne_maybe i + | i == 1 + = Just False + | i == -1 + = Just True + | otherwise + = Nothing + ok = + case width of + W32 + | Lit (LitFloat i) <- x + , Just sgn <- posNegOne_maybe i + -> Just (sgn, y) + | Lit (LitFloat i) <- y + , Just sgn <- posNegOne_maybe i + -> Just (sgn, x) + W64 + | Lit (LitDouble i) <- x + , Just sgn <- posNegOne_maybe i + -> Just (sgn, y) + | Lit (LitDouble i) <- y + , Just sgn <- posNegOne_maybe i + -> Just (sgn, x) + _ -> Nothing + neg = case width of + W32 -> FloatNegOp + W64 -> DoubleNegOp + _ -> panic "fmaOne: not Float# or Double#" + add = case width of + W32 -> FloatAddOp + W64 -> DoubleAddOp + _ -> panic "fmaOne: not Float# or Double#" + sub = case width of + W32 -> FloatSubOp + W64 -> DoubleSubOp + _ -> panic "fmaOne: not Float# or Double#" + case ok of + Nothing -> mzero + Just (sgn, t) -> return $ + if -- t + z + | ( signs == FMAdd && sgn == False ) + || ( signs == FNMAdd && sgn == True ) + -> Var (primOpId add) `App` t `App` z + -- - t + z + | signs == FMAdd + || signs == FNMAdd + -> Var (primOpId sub) `App` z `App` t + -- t - z + | ( signs == FMSub && sgn == False ) + || ( signs == FNMSub && sgn == True ) + -> Var (primOpId sub) `App` t `App` z + -- - t - z + | signs == FMSub + || signs == FNMSub + -> Var (primOpId neg) `App` (Var (primOpId add) `App` t `App` z) + | otherwise + -> pprPanic "fmaOne: non-exhaustive pattern match" $ + vcat [ text "signs:" <+> text (show signs) + , text "sign:" <+> ppr sgn ] + +-------------------------- {- Note [The litEq rule: converting equality to case] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ This stuff turns @@ -1404,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: @@ -1789,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 @@ -1800,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) $ @@ -1810,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 @@ -1826,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 @@ -1878,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]) } @@ -1886,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? {- ************************************************************************ @@ -2478,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 @@ -2490,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: @@ -2652,6 +2804,14 @@ (orFoldingRules' platform arg1 arg2 num_ops <|> orFoldingRules' platform arg2 arg1 num_ops) +quotFoldingRules :: NumOps -> RuleM CoreExpr +quotFoldingRules num_ops = do + env <- getRuleOpts + guard (roNumConstantFolding env) + [arg1,arg2] <- getArgs + platform <- getPlatform + liftMaybe (quotFoldingRules' platform arg1 arg2 num_ops) + addFoldingRules' :: Platform -> CoreExpr -> CoreExpr -> NumOps -> Maybe CoreExpr addFoldingRules' platform arg1 arg2 num_ops = case (arg1, arg2) of @@ -2914,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 @@ -2937,11 +3102,39 @@ -- (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 or x y = BinOpApp x (fromJust (numOr num_ops)) y +quotFoldingRules' :: Platform -> CoreExpr -> CoreExpr -> NumOps -> Maybe CoreExpr +quotFoldingRules' platform arg1 arg2 num_ops = case (arg1, arg2) of + + -- (x / l1) / l2 + -- l1 and l2 /= 0 + -- l1*l2 doesn't overflow + -- ==> x / (l1 * l2) + (is_div num_ops -> Just (x, L l1), L l2) + | l1 /= 0 + , l2 /= 0 + -- check that the result of the multiplication is in range + , Just l <- mkNumLiteralMaybe platform num_ops (l1 * l2) + -> Just (div x (Lit l)) + -- NB: we could directly return 0 or (-1) in case of overflow, + -- but we would need to know + -- (1) if we're dealing with a quot or a div operation + -- (2) if it's an underflow or an overflow. + -- Left as future work for now. + + _ -> Nothing + where + div x y = BinOpApp x (fromJust (numDiv num_ops)) y + is_binop :: PrimOp -> CoreExpr -> Maybe (Arg CoreBndr, Arg CoreBndr) is_binop op e = case e of BinOpApp x op' y | op == op' -> Just (x,y) @@ -2952,16 +3145,36 @@ App (OpVal op') x | op == op' -> Just x _ -> Nothing -is_add, is_sub, is_mul, is_and, is_or :: 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 is_and num_ops e = numAnd num_ops >>= \op -> is_binop op e is_or num_ops e = numOr num_ops >>= \op -> is_binop op e +is_div num_ops e = numDiv num_ops >>= \op -> is_binop op e 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 @@ -3006,6 +3219,7 @@ { numAdd :: !PrimOp -- ^ Add two numbers , numSub :: !PrimOp -- ^ Sub two numbers , numMul :: !PrimOp -- ^ Multiply two numbers + , numDiv :: !(Maybe PrimOp) -- ^ Divide two numbers , numAnd :: !(Maybe PrimOp) -- ^ And two numbers , numOr :: !(Maybe PrimOp) -- ^ Or two numbers , numNeg :: !(Maybe PrimOp) -- ^ Negate a number @@ -3016,15 +3230,20 @@ mkNumLiteral :: Platform -> NumOps -> Integer -> Literal mkNumLiteral platform ops i = mkLitNumberWrap platform (numLitType ops) i +-- | Create a numeric literal if it is in range +mkNumLiteralMaybe :: Platform -> NumOps -> Integer -> Maybe Literal +mkNumLiteralMaybe platform ops i = mkLitNumberMaybe platform (numLitType ops) i + int8Ops :: NumOps int8Ops = NumOps { numAdd = Int8AddOp , numSub = Int8SubOp , numMul = Int8MulOp - , numLitType = LitNumInt8 + , numDiv = Just Int8QuotOp , numAnd = Nothing , numOr = Nothing , numNeg = Just Int8NegOp + , numLitType = LitNumInt8 } word8Ops :: NumOps @@ -3032,6 +3251,7 @@ { numAdd = Word8AddOp , numSub = Word8SubOp , numMul = Word8MulOp + , numDiv = Just Word8QuotOp , numAnd = Just Word8AndOp , numOr = Just Word8OrOp , numNeg = Nothing @@ -3043,10 +3263,11 @@ { numAdd = Int16AddOp , numSub = Int16SubOp , numMul = Int16MulOp - , numLitType = LitNumInt16 + , numDiv = Just Int16QuotOp , numAnd = Nothing , numOr = Nothing , numNeg = Just Int16NegOp + , numLitType = LitNumInt16 } word16Ops :: NumOps @@ -3054,6 +3275,7 @@ { numAdd = Word16AddOp , numSub = Word16SubOp , numMul = Word16MulOp + , numDiv = Just Word16QuotOp , numAnd = Just Word16AndOp , numOr = Just Word16OrOp , numNeg = Nothing @@ -3065,10 +3287,11 @@ { numAdd = Int32AddOp , numSub = Int32SubOp , numMul = Int32MulOp - , numLitType = LitNumInt32 + , numDiv = Just Int32QuotOp , numAnd = Nothing , numOr = Nothing , numNeg = Just Int32NegOp + , numLitType = LitNumInt32 } word32Ops :: NumOps @@ -3076,6 +3299,7 @@ { numAdd = Word32AddOp , numSub = Word32SubOp , numMul = Word32MulOp + , numDiv = Just Word32QuotOp , numAnd = Just Word32AndOp , numOr = Just Word32OrOp , numNeg = Nothing @@ -3087,10 +3311,11 @@ { numAdd = Int64AddOp , numSub = Int64SubOp , numMul = Int64MulOp - , numLitType = LitNumInt64 + , numDiv = Just Int64QuotOp , numAnd = Nothing , numOr = Nothing , numNeg = Just Int64NegOp + , numLitType = LitNumInt64 } word64Ops :: NumOps @@ -3098,6 +3323,7 @@ { numAdd = Word64AddOp , numSub = Word64SubOp , numMul = Word64MulOp + , numDiv = Just Word64QuotOp , numAnd = Just Word64AndOp , numOr = Just Word64OrOp , numNeg = Nothing @@ -3109,6 +3335,7 @@ { numAdd = IntAddOp , numSub = IntSubOp , numMul = IntMulOp + , numDiv = Just IntQuotOp , numAnd = Just IntAndOp , numOr = Just IntOrOp , numNeg = Just IntNegOp @@ -3120,6 +3347,7 @@ { numAdd = WordAddOp , numSub = WordSubOp , numMul = WordMulOp + , numDiv = Just WordQuotOp , numAnd = Just WordAndOp , numOr = Just WordOrOp , numNeg = Nothing @@ -3180,16 +3408,81 @@ , \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 - = 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 occurrence info are present, hence the use of In* types. +caseRules2 + :: InExpr -- ^ Scutinee + -> InId -- ^ Case-binder + -> [InAlt] -- ^ Alternatives in standard (increasing) order + -> Maybe (InExpr, InId, [InAlt]) +caseRules2 scrut bndr alts + + -- case quotRem# x y of + -- (# q, _ #) -> body + -- ====> + -- case quot# x y of + -- q -> body + -- + -- case quotRem# x y of + -- (# _, r #) -> body + -- ====> + -- case rem# x y of + -- r -> body + | BinOpApp x op y <- scrut + , Just (quot,rem) <- is_any_quot_rem op + , [Alt (DataAlt _) [q,r] body] <- alts + , isDeadBinder bndr + , dead_q <- isDeadBinder q + , dead_r <- isDeadBinder r + , dead_q || dead_r + = if + | dead_q -> Just $ (BinOpApp x rem y, r, [Alt DEFAULT [] body]) + | dead_r -> Just $ (BinOpApp x quot y, q, [Alt DEFAULT [] body]) + | otherwise -> Nothing + + | otherwise + = Nothing + + +-- | If the given primop is a quotRem, return the corresponding (quot,rem). +is_any_quot_rem :: PrimOp -> Maybe (PrimOp, PrimOp) +is_any_quot_rem = \case + IntQuotRemOp -> Just (IntQuotOp , IntRemOp) + Int8QuotRemOp -> Just (Int8QuotOp, Int8RemOp) + Int16QuotRemOp -> Just (Int16QuotOp, Int16RemOp) + Int32QuotRemOp -> Just (Int32QuotOp, Int32RemOp) + -- Int64QuotRemOp doesn't exist (yet) + + WordQuotRemOp -> Just (WordQuotOp, WordRemOp) + Word8QuotRemOp -> Just (Word8QuotOp, Word8RemOp) + Word16QuotRemOp -> Just (Word16QuotOp, Word16RemOp) + Word32QuotRemOp -> Just (Word32QuotOp, Word32RemOp) + -- Word64QuotRemOp doesn't exist (yet) + + _ -> Nothing + + tx_lit_con :: Platform -> (Integer -> Integer) -> AltCon -> Maybe AltCon tx_lit_con _ _ DEFAULT = Just DEFAULT tx_lit_con platform adjust (LitAlt l) = Just $ LitAlt (mapLitValue platform adjust l) @@ -3238,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 (!!) @@ -3248,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 @@ -3266,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 @@ -3290,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 @@ -3306,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 @@ -16,39 +16,41 @@ import GHC.Prelude -import GHC.Core.Opt.WorkWrap.Utils import GHC.Types.Demand -- All of it + import GHC.Core -import GHC.Core.Multiplicity ( scaledThing ) -import GHC.Utils.Outputable -import GHC.Types.Var.Env -import GHC.Types.Var.Set -import GHC.Types.Basic -import Data.List ( mapAccumL ) import GHC.Core.DataCon -import GHC.Types.ForeignCall ( isSafeForeignCall ) -import GHC.Types.Id import GHC.Core.Utils import GHC.Core.TyCon import GHC.Core.Type -import GHC.Core.Predicate( isClassPred ) import GHC.Core.FVs ( rulesRhsFreeIds, bndrRuleAndUnfoldingIds ) import GHC.Core.Coercion ( Coercion ) import GHC.Core.TyCo.FVs ( coVarsOfCos ) import GHC.Core.TyCo.Compare ( eqType ) +import GHC.Core.Multiplicity ( scaledThing ) import GHC.Core.FamInstEnv import GHC.Core.Opt.Arity ( typeArity ) -import GHC.Utils.Misc -import GHC.Utils.Panic -import GHC.Utils.Panic.Plain -import GHC.Data.Maybe +import GHC.Core.Opt.WorkWrap.Utils + +import GHC.Builtin.Names import GHC.Builtin.PrimOps import GHC.Builtin.Types.Prim ( realWorldStatePrimTy ) + import GHC.Types.Unique.Set import GHC.Types.Unique.MemoFun import GHC.Types.RepType +import GHC.Types.ForeignCall ( isSafeForeignCall ) +import GHC.Types.Id +import GHC.Types.Var.Env +import GHC.Types.Var.Set +import GHC.Types.Basic +import GHC.Utils.Misc +import GHC.Utils.Panic +import GHC.Utils.Outputable +import Data.List ( mapAccumL ) + {- ************************************************************************ * * @@ -85,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 @@ -403,7 +405,7 @@ anticipateANF :: CoreExpr -> Card -> Card anticipateANF e n | exprIsTrivial e = n -- trivial expr won't have a binding - | Just Unlifted <- typeLevity_maybe (exprType e) + | definitelyUnliftedType (exprType e) , not (isAbs n && exprOkForSpeculation e) = case_bind n | otherwise = let_bind n where @@ -423,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 @@ -552,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 @@ -600,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@ @@ -797,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 @@ -812,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. @@ -822,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 @@ -995,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 @@ -1026,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: @@ -1068,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 rhs' (de_div rhs_env) - `orElse` (rhs_dmds, rhs') + (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 @@ -1124,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 @@ -1154,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 @@ -1230,70 +1243,117 @@ 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. + them. Also it elegantly subsumes the trivial RHS and PAP case. E.g. for + f = g + we want to use a threshold arity based on g, not 0! 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: @@ -1324,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: @@ -1398,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. @@ -1498,7 +1582,7 @@ So we want to give `indexError` a signature like `<1!P(!S,!S)><1!S>b` where the !S (meaning Poly Unboxed C1N) says that the polymorphic arguments -are unboxed (recursively). The wrapper for `indexError` won't /acutally/ +are unboxed (recursively). The wrapper for `indexError` won't /actually/ unbox them (because their polymorphic type doesn't allow that) but when demand-analysing /callers/, we'll behave as if that call needs the args unboxed. @@ -1781,39 +1865,6 @@ that we get the strict demand signature we wanted even if we can't float the case on `x` up through the case on `burble`. -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. - Note [Worker argument budget] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ In 'finaliseArgBoxities' we don't want to generate workers with zillions of @@ -1924,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. -} @@ -1947,62 +1998,77 @@ positiveTopBudget :: Budgets -> Bool positiveTopBudget (MkB n _) = n >= 0 -finaliseArgBoxities :: AnalEnv -> Id -> Arity -> CoreExpr -> Divergence - -> Maybe ([Demand], CoreExpr) -finaliseArgBoxities env fn arity rhs div - | arity > count isId bndrs -- Can't find enough binders - = Nothing -- This happens if we have f = g - -- Then there are no binders; we don't worker/wrapper; and we - -- simply want to give f the same demand signature as g +finaliseArgBoxities :: AnalEnv -> Id -> Arity + -> [Demand] -> Divergence + -> CoreExpr -> ([Demand], CoreExpr) +-- 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 - | otherwise -- NB: arity is the threshold_arity, which might be less than - -- manifest arity for join points + -- 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_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 + -- 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. + | ww_arity > count isId bndrs + = (arg_dmds, rhs) + + -- The normal case + | otherwise = -- pprTrace "finaliseArgBoxities" ( - -- vcat [text "function:" <+> ppr fn + -- vcat [text "function:" <+> ppr fn + -- , text "max" <+> ppr max_wkr_args -- , text "dmds before:" <+> ppr (map idDemandInfo (filter isId bndrs)) -- , text "dmds after: " <+> ppr arg_dmds' ]) $ - Just (arg_dmds', add_demands arg_dmds' rhs) - -- add_demands: we must attach the final boxities to the lambda-binders + (arg_dmds', set_lam_dmds arg_dmds' rhs) + -- set_lam_dmds: we must attach the final boxities to the lambda-binders -- 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 arity $ - [ (bndr_ty, NotMarkedStrict, get_dmd bndr bndr_ty) - | bndr <- bndrs - , isRuntimeVar bndr, let bndr_ty = idType bndr ] - - get_dmd :: Id -> Type -> Demand - get_dmd bndr bndr_ty - | isClassPred bndr_ty = trimBoxity dmd - -- 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 + arg_triples = take ww_arity $ + [ (idType bndr, NotMarkedStrict, get_dmd bndr) + | bndr <- bndrs, isRuntimeVar bndr ] - | is_bot_fn = unboxDeeplyDmd dmd - -- See Note [Boxity for bottoming functions], case (B) + 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) - | is_opaque = trimBoxity dmd - -- See Note [OPAQUE pragma] - -- See Note [The OPAQUE pragma and avoiding the reboxing of arguments] + -- 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] - | otherwise = dmd + get_dmd :: Id -> Demand + get_dmd bndr + | is_bot_fn = unboxDeeplyDmd dmd -- See Note [Boxity for bottoming functions], + | otherwise = dmd -- case (B) where - dmd = idDemandInfo bndr - is_opaque = isOpaquePragma (idInlinePragma fn) + dmd = idDemandInfo bndr -- is_bot_fn: see Note [Boxity for bottoming functions] is_bot_fn = div == botDiv @@ -2059,13 +2125,18 @@ | positiveTopBudget bg_inner' = (bg_inner', dmd') | otherwise = (bg_inner, trimBoxity dmd) - add_demands :: [Demand] -> CoreExpr -> CoreExpr + set_lam_dmds :: [Demand] -> CoreExpr -> CoreExpr -- Attach the demands to the outer lambdas of this expression - add_demands [] e = e - add_demands (dmd:dmds) (Lam v e) - | isTyVar v = Lam v (add_demands (dmd:dmds) e) - | otherwise = Lam (v `setIdDemandInfo` dmd) (add_demands dmds e) - add_demands dmds e = pprPanic "add_demands" (ppr dmds $$ ppr e) + set_lam_dmds (dmd:dmds) (Lam v e) + | isTyVar v = Lam v (set_lam_dmds (dmd:dmds) e) + | otherwise = Lam (v `setIdDemandInfo` dmd) (set_lam_dmds dmds e) + set_lam_dmds dmds (Cast e co) = Cast (set_lam_dmds dmds e) co + -- This case happens for an OPAQUE function, which may look like + -- f = (\x y. blah) |> co + -- We give it strictness but no boxity (#22502) + set_lam_dmds _ e = e + -- In the OPAQUE case, the list of demands at this point might be + -- non-empty, e.g., when looking at a PAP. Hence don't panic (#22997). finaliseLetBoxity :: AnalEnv @@ -2293,7 +2364,7 @@ -- L demand doesn't get both'd with the Bot coming up from the inner -- call to f. So we just get an L demand for x for g. -setBndrsDemandInfo :: HasCallStack => [Var] -> [Demand] -> [Var] +setBndrsDemandInfo :: HasDebugCallStack => [Var] -> [Demand] -> [Var] setBndrsDemandInfo (b:bs) ds | isTyVar b = b : setBndrsDemandInfo bs ds setBndrsDemandInfo (b:bs) (d:ds) = 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 @@ -28,8 +28,8 @@ import GHC.Core.FVs import GHC.Core.Type -import GHC.Types.Basic ( RecFlag(..), isRec, Levity(Unlifted) ) -import GHC.Types.Id ( idType, isJoinId, isJoinId_maybe ) +import GHC.Types.Basic ( RecFlag(..), isRec ) +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. @@ -306,7 +329,7 @@ (y:ys) -> ...(let x = y+1 in x)... [] -> blah because the y is captured. This doesn't happen much, because shadowing is -rare, but it did happen in #22662. +rare (see Note [Shadowing in Core]), but it did happen in #22662. One solution would be to clone as we go. But a simpler one is this: @@ -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 @@ -618,7 +664,7 @@ | isJoinId bndr = isRec is_rec -- Joins are one-shot iff non-recursive - | Just Unlifted <- typeLevity_maybe (idType bndr) + | definitelyUnliftedType (idType bndr) = True -- Preserve let-can-float invariant, see Note [noFloatInto considerations] | 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/LiberateCase.hs b/GHC/Core/Opt/LiberateCase.hs --- a/GHC/Core/Opt/LiberateCase.hs +++ b/GHC/Core/Opt/LiberateCase.hs @@ -14,6 +14,7 @@ import GHC.Core import GHC.Core.Unfold +import GHC.Core.Opt.Simplify.Inline import GHC.Builtin.Types ( unitDataConId ) import GHC.Types.Id import GHC.Types.Var.Env 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 @@ -40,7 +40,7 @@ import GHC.Prelude hiding ( read ) -import GHC.Driver.Session +import GHC.Driver.DynFlags import GHC.Driver.Env import GHC.Core.Rules ( RuleBase, RuleEnv, mkRuleEnv ) @@ -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,3432 +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 (..), 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 [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 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 we must do the adjustRhsUsage thing -on j's RHS. That's why we pass mb_join_arity to calcUnfolding. - -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. - -* Wrinkle for Rec case. In the recursive case we don't know the - join-point arity in advance, when calling occAnalUnfolding and - occAnalRules. (See makeNode.) We don't want to pass Nothing, - because then a recursive joinrec might lose its join-poin-hood - when SpecConstr adds a RULE. So we just make do with the - *current* join-poin-hood, stored in the Id. - - In the non-recursive case things are simple: see occAnalNonRecBind - -* 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 [Unfoldings and join points] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We assume that anything in an unfolding occurs multiple times, since -unfoldings are often copied (that's the whole point!). But we still -need to track tail calls for the purpose of finding join points. - - ------------------------------------------------------------- -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 'markAllInsideLam' *unless* the binding is for a thunk, a one-shot - lambda, or a non-recursive join point; and - b) call 'markAllNonTail' *unless* the binding is for a join point, and - the RHS has the right 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 - -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 'occAnalLamOrRhs' must -return the unadjusted 'UsageDetails', to be adjusted by 'adjustRhsUsage' once -join-point-hood has been decided. - -Thus the overall sequence taking place in 'occAnalNonRecBind' and -'occAnalRecBind' is as follows: - - 1. Call 'occAnalLamOrRhs' to find usage information for the RHS. - 2. Call 'tagNonRecBinder' or 'tagRecBinders', which decides whether to make - the binding a join point. - 3. Call 'adjustRhsUsage' accordingly. (Done as part of 'tagRecBinders' when - recursive.) - -(In the recursive case, this logic is spread between 'makeNode' and -'occAnalRec'.) --} - - -data WithUsageDetails a = WithUsageDetails !UsageDetails !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) -- It's not mentioned - = WithUsageDetails body_usage [] - - | otherwise -- It's mentioned in the body - = WithUsageDetails (body_usage' `andUDs` rhs_usage) [NonRec final_bndr rhs'] - where - (body_usage', tagged_bndr) = tagNonRecBinder lvl body_usage bndr - final_bndr = tagged_bndr `setIdUnfolding` unf' - `setIdSpecialisation` mkRuleInfo rules' - rhs_usage = rhs_uds `andUDs` unf_uds `andUDs` rule_uds - - -- Get the join info from the *new* decision - -- See Note [Join points and unfoldings/rules] - 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 } - (WithUsageDetails rhs_uds rhs') = occAnalRhs rhs_env NonRecursive mb_join_arity rhs - - --------- Unfolding --------- - -- See Note [Unfoldings and join points] - unf | isId bndr = idUnfolding bndr - | otherwise = NoUnfolding - (WithUsageDetails unf_uds unf') = occAnalUnfolding rhs_env NonRecursive mb_join_arity unf - - --------- Rules --------- - -- See Note [Rules are extra RHSs] and Note [Rule dependency info] - rules_w_uds = occAnalRules rhs_env mb_join_arity 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. - - rule_uds = foldr add_rule_uds imp_rule_uds rules_w_uds - add_rule_uds (_, l, r) uds = l `andUDs` 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 Details] - 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 - - ------------------------------ -occAnalRec :: OccEnv -> TopLevelFlag - -> SCC Details - -> WithUsageDetails [CoreBind] - -> WithUsageDetails [CoreBind] - - -- The NonRec case is just like a Let (NonRec ...) above -occAnalRec !_ lvl (AcyclicSCC (ND { nd_bndr = bndr, nd_rhs = rhs - , nd_uds = rhs_uds })) - (WithUsageDetails body_uds binds) - | not (bndr `usedIn` body_uds) - = WithUsageDetails body_uds binds -- See Note [Dead code] - - | otherwise -- It's mentioned in the body - = WithUsageDetails (body_uds' `andUDs` rhs_uds') - (NonRec tagged_bndr rhs : binds) - where - (body_uds', tagged_bndr) = tagNonRecBinder lvl body_uds bndr - rhs_uds' = adjustRhsUsage mb_join_arity rhs rhs_uds - mb_join_arity = willBeJoinId_maybe tagged_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) (WithUsageDetails body_uds binds) - | not (any (`usedIn` body_uds) bndrs) -- NB: look at body_uds, not total_uds - = WithUsageDetails body_uds binds -- See Note [Dead code] - - | otherwise -- At this point we always build a single Rec - = -- pprTrace "occAnalRec" (ppr loop_breaker_nodes) - WithUsageDetails final_uds (Rec pairs : binds) - - where - bndrs = map nd_bndr details_s - 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 :: [LetrecNode] - (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] - -> [LetrecNode] - -> [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 -> [LetrecNode] -> [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 - (nd_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) -> LetrecNode -> Binding -nodeBinding set_id_occ (node_payload -> ND { nd_bndr = bndr, nd_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 - -> [LetrecNode] -- Nodes with this score - -> [LetrecNode] -- Nodes with higher scores - -> [LetrecNode] -- Unprocessed nodes - -> ([LetrecNode], [LetrecNode]) - -- 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 = nd_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 -* * -************************************************************************ --} - -type LetrecNode = Node Unique Details -- Node comes from Digraph - -- The Unique key is gotten from the Id -data Details - = ND { nd_bndr :: Id -- Binder - - , nd_rhs :: CoreExpr -- RHS, already occ-analysed - - , nd_uds :: UsageDetails -- Usage from RHS, and RULES, and stable unfoldings - -- ignoring phase (ie assuming all are active) - -- See Note [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] - - , nd_score :: NodeScore - } - -instance Outputable Details where - ppr nd = text "ND" <> braces - (sep [ text "bndr =" <+> ppr (nd_bndr nd) - , text "uds =" <+> ppr (nd_uds nd) - , text "inl =" <+> ppr (nd_inl nd) - , text "simple =" <+> ppr (nd_simple nd) - , text "active_rule_fvs =" <+> ppr (nd_active_rule_fvs nd) - , text "score =" <+> ppr (nd_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 = rhs' - , nd_uds = scope_uds - , 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 - , nd_score = pprPanic "makeNodeDetails" (ppr bndr) } - - bndr' = bndr `setIdUnfolding` unf' - `setIdSpecialisation` mkRuleInfo rules' - - inl_uds = rhs_uds `andUDs` unf_uds - scope_uds = inl_uds `andUDs` rule_uds - -- Note [Rules are extra RHSs] - -- Note [Rule dependency info] - scope_fvs = udFreeVars bndr_set 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 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] - - mb_join_arity = isJoinId_maybe bndr - -- Get join point info from the *current* decision - -- We don't know what the new decision will be! - -- Using the old decision at least allows us to - -- preserve existing join point, even RULEs are added - -- See Note [Join points and unfoldings/rules] - - --------- Right hand side --------- - -- Constructing the edges for the main Rec computation - -- See Note [Forming Rec groups] - -- Do not use occAnalRhs because we don't yet know the final - -- answer for mb_join_arity; instead, do the occAnalLam call from - -- occAnalRhs, and postpone adjustRhsUsage until occAnalRec - rhs_env = rhsCtxt env - (WithUsageDetails rhs_uds rhs') = occAnalLam rhs_env rhs - - --------- Unfolding --------- - -- See Note [Unfoldings and join points] - unf = realIdUnfolding bndr -- realIdUnfolding: Ignore loop-breaker-ness - -- here because that is what we are setting! - (WithUsageDetails unf_uds unf') = occAnalUnfolding rhs_env Recursive mb_join_arity unf - - --------- 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 -------- - rules_w_uds :: [(CoreRule, UsageDetails, UsageDetails)] - rules_w_uds = occAnalRules rhs_env mb_join_arity bndr - rules' = map fstOf3 rules_w_uds - - 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 - -> [Details] - -> WithUsageDetails [LetrecNode] -- adjusted --- 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 - (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 = new_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 - new_nd = nd { nd_bndr = new_bndr, nd_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 - -> Details - -> NodeScore -nodeScore !env new_bndr lb_deps - (ND { nd_bndr = old_bndr, nd_rhs = 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 occAnalLam. - -* 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 - -occAnalLam :: OccEnv -> CoreExpr -> (WithUsageDetails 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 --- This function does /not/ do --- markAllInsideLam or --- markAllNonTail --- The caller does that, either in occAnal (Lam {}), or in adjustRhsUsage --- See Note [Adjusting right-hand sides] - -occAnalLam env (Lam bndr expr) - | isTyVar bndr - = let env1 = addOneInScope env bndr - WithUsageDetails usage expr' = occAnalLam env1 expr - in WithUsageDetails 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 - (WithUsageDetails usage expr') = occAnalLam env2 expr - (usage', bndr2) = tagLamBinder usage bndr1 - in WithUsageDetails usage' (Lam bndr2 expr') - --- For casts, keep going in the same lambda-group --- See Note [Occurrence analysis for lambda binders] -occAnalLam env (Cast expr co) - = let (WithUsageDetails usage expr') = occAnalLam 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 adjustRhsUsage; but not so! For a - -- join point, adjustRhsUsage 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 WithUsageDetails usage3 (Cast expr' co) - -occAnalLam env expr = 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 occAnalLam, not occAnal, because the top leve -of a right hand side is handled by occAnalLam. --} - - -{- ********************************************************************* -* * - Right hand sides -* * -********************************************************************* -} - -occAnalRhs :: OccEnv -> RecFlag -> Maybe JoinArity - -> CoreExpr -- RHS - -> WithUsageDetails CoreExpr -occAnalRhs !env is_rec mb_join_arity rhs - = let (WithUsageDetails usage rhs1) = occAnalLam env rhs - -- We call occAnalLam here, not occAnalExpr, so that it doesn't - -- do the markAllInsideLam and markNonTailCall stuff before - -- we've had a chance to help with join points; that comes next - rhs2 = markJoinOneShots is_rec mb_join_arity rhs1 - rhs_usage = adjustRhsUsage mb_join_arity rhs2 usage - in WithUsageDetails rhs_usage rhs2 - - - -markJoinOneShots :: RecFlag -> Maybe 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 -markJoinOneShots NonRecursive (Just 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.) -markJoinOneShots _ _ rhs - = rhs - -occAnalUnfolding :: OccEnv - -> RecFlag - -> Maybe JoinArity -- See Note [Join points and unfoldings/rules] - -> Unfolding - -> WithUsageDetails Unfolding --- Occurrence-analyse a stable unfolding; --- discard a non-stable one altogether. -occAnalUnfolding !env is_rec mb_join_arity unf - = case unf of - unf@(CoreUnfolding { uf_tmpl = rhs, uf_src = src }) - | isStableSource src -> - let - (WithUsageDetails usage rhs') = occAnalRhs env is_rec mb_join_arity rhs - - unf' | noBinderSwaps env = unf -- Note [Unfoldings and rules] - | otherwise = unf { uf_tmpl = rhs' } - in WithUsageDetails (markAllMany usage) unf' - -- markAllMany: see Note [Occurrences in stable unfoldings] - | otherwise -> WithUsageDetails 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 }) - -> WithUsageDetails final_usage (unf { df_args = args' }) - where - env' = env `addInScope` bndrs - (WithUsageDetails usage args') = occAnalList env' args - final_usage = markAllManyNonTail (delDetailsList usage bndrs) - `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 -> WithUsageDetails emptyDetails unf - -occAnalRules :: OccEnv - -> Maybe JoinArity -- See Note [Join points and unfoldings/rules] - -> Id -- Get rules from here - -> [(CoreRule, -- Each (non-built-in) rule - UsageDetails, -- Usage details for LHS - UsageDetails)] -- Usage details for RHS -occAnalRules !env mb_join_arity 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', 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' = markAllNonTailIf (not exact_join) $ - markAllMany $ - rhs_uds `delDetailsList` bndrs - - exact_join = exactJoin mb_join_arity args - -- See Note [Join points and unfoldings/rules] - - occ_anal_rule other_rule = (other_rule, emptyDetails, 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". - -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 {}) - = let (WithUsageDetails usage expr') = occAnalLam env expr - final_usage = markAllInsideLamIf (not (isOneShotFun expr')) $ - markAllNonTail usage - in WithUsageDetails final_usage expr' - -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 - , let (WithUsageDetails usage arg') = occAnalRhs env NonRecursive (Just 1) 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)) - -------------------- --- 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] -adjustRhsUsage :: Maybe JoinArity - -> CoreExpr -- Rhs, AFTER occ anal - -> UsageDetails -- From body of lambda - -> UsageDetails -adjustRhsUsage mb_join_arity rhs usage - = -- c.f. occAnal (Lam {}) - markAllInsideLamIf (not one_shot) $ - markAllNonTailIf (not exact_join) $ - usage - where - one_shot = isOneShotFun rhs - exact_join = exactJoin mb_join_arity bndrs - (bndrs,_) = collectBinders rhs - -exactJoin :: Maybe JoinArity -> [a] -> Bool -exactJoin Nothing _ = False -exactJoin (Just join_arity) args = args `lengthIs` join_arity - -- Remember join_arity includes type binders - -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 - -> (UsageDetails, -- 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 - usage' `seq` (usage', binder') - -tagRecBinders :: TopLevelFlag -- At top level? - -> UsageDetails -- Of body of let ONLY - -> [Details] - -> (UsageDetails, -- 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 - rhs_udss = map nd_uds details_s - - -- 1. Determine join-point-hood of whole group, as determined by - -- the *unadjusted* usage details - unadj_uds = foldr andUDs body_uds rhs_udss - - -- This is only used in `mb_join_arity`, to adjust each `Details` in `details_s`, thus, - -- when `bndrs` is non-empty. So, we only write `maybe False` as `decideJoinPointHood` - -- takes a `NonEmpty CoreBndr`; the default value `False` won't affect program behavior. - will_be_joins = maybe False (decideJoinPointHood lvl unadj_uds) (nonEmpty bndrs) - - -- 2. Adjust usage details of each RHS, taking into account the - -- join-point-hood decision - rhs_udss' = [ adjustRhsUsage (mb_join_arity bndr) rhs rhs_uds - | ND { nd_bndr = bndr, nd_uds = rhs_uds - , nd_rhs = rhs } <- details_s ] - - mb_join_arity :: Id -> Maybe JoinArity - 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! - - -- 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 - (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. --- 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 @@ -10,7 +10,7 @@ import GHC.Prelude -import GHC.Driver.Session +import GHC.Driver.DynFlags import GHC.Driver.Plugins ( withPlugins, installCoreToDos ) import GHC.Driver.Env import GHC.Driver.Config.Core.Lint ( endPass ) @@ -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, @@ -309,7 +313,7 @@ [ CoreLiberateCase, simplify "post-liberate-case" ], -- Run the simplifier after LiberateCase to vastly -- reduce the possibility of shadowing - -- Reason: see Note [Shadowing] in GHC.Core.Opt.SpecConstr + -- Reason: see Note [Shadowing in SpecConstr] in GHC.Core.Opt.SpecConstr runWhen spec_constr $ CoreDoPasses [ CoreDoSpecConstr, simplify "post-spec-constr"], @@ -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,13 +1896,11 @@ 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 { us <- getUniqueSupplyM - ; let (subst', vs') = cloneBndrs subst us 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]. - env' = env { le_lvl_env = addLvls new_lvl lvl_env vs' + -- 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,13 +1915,12 @@ cloneLetVars is_rec env@(LE { le_subst = subst, le_lvl_env = lvl_env, le_env = id_env }) dest_lvl vs - = do { us <- getUniqueSupplyM - ; let vs1 = map zap vs - -- See Note [Zapping the demand info] - (subst', vs2) = case is_rec of - NonRecursive -> cloneBndrs subst us vs1 - Recursive -> cloneRecIdBndrs subst us vs1 - prs = vs `zip` vs2 + = do { let vs1 = map zap vs + ; (subst', vs2) <- case is_rec of + NonRecursive -> cloneBndrsM subst vs1 + Recursive -> cloneRecIdBndrsM subst vs1 + + ; let prs = vs `zip` vs2 env' = env { le_lvl_env = addLvls dest_lvl lvl_env vs2 , le_subst = subst' , le_env = foldl' add_id id_env prs } @@ -1787,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 @@ -1798,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 new file mode 100644 --- /dev/null +++ b/GHC/Core/Opt/Simplify/Inline.hs @@ -0,0 +1,751 @@ +{- +(c) The University of Glasgow 2006 +(c) The AQUA Project, Glasgow University, 1994-1998 + +This module contains inlining logic used by the simplifier. +-} + + + +module GHC.Core.Opt.Simplify.Inline ( + -- * Cheap and cheerful inlining checks. + couldBeSmallEnoughToInline, + smallEnoughToInline, activeUnfolding, + + -- * The smart inlining decisions are made by callSiteInline + callSiteInline, CallCtxt(..), + ) where + +import GHC.Prelude + +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.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 +import GHC.Types.Name + +import Data.List (isPrefixOf) + +{- +************************************************************************ +* * +\subsection[considerUnfolding]{Given all the info, do (not) do the unfolding} +* * +************************************************************************ + +We use 'couldBeSmallEnoughToInline' to avoid exporting inlinings that +we ``couldn't possibly use'' on the other side. Can be overridden w/ +flaggery. Just the same as smallEnoughToInline, except that it has no +actual arguments. +-} + +couldBeSmallEnoughToInline :: UnfoldingOpts -> Int -> CoreExpr -> Bool +couldBeSmallEnoughToInline opts threshold rhs + = case sizeExpr opts threshold [] body of + TooBig -> False + _ -> True + where + (_, body) = collectBinders rhs + +---------------- +smallEnoughToInline :: UnfoldingOpts -> Unfolding -> Bool +smallEnoughToInline opts (CoreUnfolding {uf_guidance = guidance}) + = case guidance of + UnfIfGoodArgs {ug_size = size} -> size <= unfoldingUseThreshold opts + UnfWhen {} -> True + UnfNever -> False +smallEnoughToInline _ _ + = False + +{- +************************************************************************ +* * +\subsection{callSiteInline} +* * +************************************************************************ + +This is the key function. It decides whether to inline a variable at a call site + +callSiteInline is used at call sites, so it is a bit more generous. +It's a very important function that embodies lots of heuristics. +A non-WHNF can be inlined if it doesn't occur inside a lambda, +and occurs exactly once or + occurs once in each branch of a case and is small + +If the thing is in WHNF, there's no danger of duplicating work, +so we can inline if it occurs once, or is small + +NOTE: we don't want to inline top-level functions that always diverge. +It just makes the code bigger. Tt turns out that the convenient way to prevent +them inlining is to give them a NOINLINE pragma, which we do in +StrictAnal.addStrictnessInfoToTopId +-} + +callSiteInline :: SimplEnv + -> Logger + -> Id -- The Id + -> 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 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* + -- be a loop breaker (maybe the knot is not yet untied) + CoreUnfolding { uf_tmpl = unf_template + , uf_cache = unf_cache + , uf_guidance = guidance } + | active_unf -> tryUnfolding env logger id lone_variable + arg_infos cont_info unf_template + unf_cache guidance + | 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 + -- We take care to ensure that doc is used in only one branch, ensuring that + -- the simplifier can push its allocation into the branch. See Note [INLINE + -- conditional tracing utilities]. + | enable = logTraceMsg logger str doc result + | otherwise = result + where + enable + | logHasDumpFlag logger Opt_D_dump_verbose_inlinings + = True + | Just prefix <- unfoldingReportPrefix opts + = prefix `isPrefixOf` occNameString (getOccName inline_id) + | otherwise + = False +{-# INLINE traceInline #-} -- see Note [INLINE conditional tracing utilities] + +{- Note [Avoid inlining into deeply nested cases] + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Also called "exponential inlining". + +Consider a function f like this: (#18730) + + f arg1 arg2 = + case ... + ... -> g arg1 + ... -> g arg2 + +This function is small. So should be safe to inline. +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 ... + + f2 arg1 arg2 ... = ... + case _foo of + alt1 -> ... f3 arg1 ... + alt2 -> ... f3 arg2 ... + + f3 arg1 arg2 ... = ... + + ... repeats up to n times. And then f1 is + applied to some arguments: + + 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: + + 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: + + foo = ... + case _foo of + alt1 -> ... 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 +ticks/RAM. This pattern happened #18730. + +To combat this we introduce one more heuristic when weighing inlining decision. +We keep track of a "case-depth". Which increases each time we look inside a case +expression with more than one alternative. + +We then apply a penalty to inlinings based on the case-depth at which they would +be inlined. Bounding the number of inlinings in such a scenario. + +The heuristic can be tuned in two ways: + +* 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. + 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 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. + +The end result is that we are settling for a scaling of 30, with a threshold of 2. +This gives us minimal compiler perf regressions. No nofib runtime regressions and +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. + +-} + +tryUnfolding :: SimplEnv -> Logger -> Id -> Bool -> [ArgSummary] -> CallCtxt + -> CoreExpr -> UnfoldingCache -> UnfoldingGuidance + -> Maybe CoreExpr +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 + + UnfWhen { ug_arity = uf_arity, ug_unsat_ok = unsat_ok, ug_boring_ok = boring_ok } + | enough_args && (boring_ok || some_benefit || unfoldingVeryAggressive opts) + -- See Note [INLINE for small functions] (3) + -> traceInline logger opts id str (mk_doc some_benefit empty True) (Just unf_template) + | otherwise + -> traceInline logger opts id str (mk_doc some_benefit empty False) Nothing + where + 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 } + | isJoinId id, small_enough -> inline_join_point + | unfoldingVeryAggressive opts -> yes + | is_wf, some_benefit, small_enough -> yes + | otherwise -> no + where + 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 [ 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 "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 + -- Ids that are never going to inline anyway. + -- See Note [UnfoldingCache] in GHC.Core + UnfoldingCache{ uf_is_work_free = is_wf, uf_expandable = is_exp } = unf_cache + + mk_doc some_benefit extra_doc yes_or_no + = vcat [ text "arg infos" <+> ppr arg_infos + , text "interesting continuation" <+> ppr cont_info + , text "some_benefit" <+> ppr some_benefit + , 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"] + + ctx = log_default_dump_context (logFlags logger) + str = "Considering inlining: " ++ showSDocOneLine ctx (ppr id) + n_val_args = length arg_infos + + -- some_benefit is used when the RHS is small enough + -- and the call has enough (or too many) value + -- 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 -> Bool -- The Arity is the number of args + -- expected by the unfolding + calc_some_benefit uf_arity is_inline + | not saturated = interesting_args -- Under-saturated + -- Note [Unsaturated applications] + | otherwise = interesting_args -- Saturated or over-saturated + || interesting_call + where + saturated = n_val_args >= uf_arity + over_saturated = n_val_args > uf_arity + interesting_args = any nonTriv arg_infos + -- NB: (any nonTriv arg_infos) looks at the + -- over-saturated args too which is "wrong"; + -- but if over-saturated we inline anyway. + + interesting_call + | over_saturated + = True + | otherwise + = case cont_info of + CaseCtxt -> not (lone_variable && is_exp) -- Note [Lone variables] + 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 | 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, +we are a little bit keener to inline (in tryUnfolding). For example + f y = (y,y,y) + g y = let x = f y in ...(case x of (a,b,c) -> ...) ... +We'd inline 'f' if the call was in a case context, and it kind-of-is, +only we can't see it. Also + x = f v +could be expensive whereas + x = case v of (a,b) -> a +is patently cheap and may allow more eta expansion. + +So, in `interesting_call` in `tryUnfolding`, we treat the RHS of a +/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] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When a call is not saturated, we *still* inline if one of the +arguments has interesting structure. That's sometimes very important. +A good example is the Ord instance for Bool in Base: + + Rec { + $fOrdBool =GHC.Classes.D:Ord + @ Bool + ... + $cmin_ajX + + $cmin_ajX [Occ=LoopBreaker] :: Bool -> Bool -> Bool + $cmin_ajX = GHC.Classes.$dmmin @ Bool $fOrdBool + } + +But the defn of GHC.Classes.$dmmin is: + + $dmmin :: forall a. GHC.Classes.Ord a => a -> a -> a + {- Arity: 3, HasNoCafRefs, Strictness: SLL, + Unfolding: (\ @ a $dOrd :: GHC.Classes.Ord a x :: a y :: a -> + case @ a GHC.Classes.<= @ a $dOrd x y of wild { + GHC.Types.False -> y GHC.Types.True -> x }) -} + +We *really* want to inline $dmmin, even though it has arity 3, in +order to unravel the recursion. + + +Note [Things to watch] +~~~~~~~~~~~~~~~~~~~~~~ +* { y = I# 3; x = y `cast` co; ...case (x `cast` co) of ... } + Assume x is exported, so not inlined unconditionally. + Then we want x to inline unconditionally; no reason for it + not to, and doing so avoids an indirection. + +* { x = I# 3; ....f x.... } + Make sure that x does not inline unconditionally! + Lest we get extra allocation. + +Note [Nested functions] +~~~~~~~~~~~~~~~~~~~~~~~ +At one time we treated a call of a non-top-level function as +"interesting" (regardless of how boring the context) in the hope +that inlining it would eliminate the binding, and its allocation. +Specifically, in the default case of interesting_call we had + _other -> not is_top && uf_arity > 0 + +But actually postInlineUnconditionally does some of this and overall +it makes virtually no difference to nofib. So I simplified away this +special case + +Note [Cast then apply] +~~~~~~~~~~~~~~~~~~~~~~ +Consider + myIndex = __inline_me ( (/\a. ) |> co ) + co :: (forall a. a -> a) ~ (forall a. T a) + ... /\a.\x. case ((myIndex a) |> sym co) x of { ... } ... + +We need to inline myIndex to unravel this; but the actual call (myIndex a) has +no value arguments. The ValAppCtxt gives it enough incentive to inline. + +Note [Inlining in ArgCtxt] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +The condition (arity > 0) here is very important, because otherwise +we end up inlining top-level stuff into useless places; eg + x = I# 3# + f = \y. g x +This can make a very big difference: it adds 16% to nofib 'integer' allocs, +and 20% to 'power'. + +At one stage I replaced this condition by 'True' (leading to the above +slow-down). The motivation was test eyeball/inline1.hs; but that seems +to work ok now. + +NOTE: arguably, we should inline in ArgCtxt only if the result of the +call is at least CONLIKE. At least for the cases where we use ArgCtxt +for the RHS of a 'let', we only profit from the inlining if we get a +CONLIKE thing (modulo lets). + +Note [Lone variables] +~~~~~~~~~~~~~~~~~~~~~ +See also Note [Interaction of exprIsWorkFree and lone variables] +which appears below + +The "lone-variable" case is important. I spent ages messing about +with unsatisfactory variants, but this is nice. The idea is that if a +variable appears all alone + + as an arg of lazy fn, or rhs BoringCtxt + as scrutinee of a case CaseCtxt + as arg of a fn ArgCtxt +AND + it is bound to a cheap expression + +then we should not inline it (unless there is some other reason, +e.g. it is the sole occurrence). That is what is happening at +the use of 'lone_variable' in 'interesting_call'. + +Why? At least in the case-scrutinee situation, turning + let x = (a,b) in case x of y -> ... +into + let x = (a,b) in case (a,b) of y -> ... +and thence to + let x = (a,b) in let y = (a,b) in ... +is bad if the binding for x will remain. + +Another example: I discovered that strings +were getting inlined straight back into applications of 'error' +because the latter is strict. + s = "foo" + f = \x -> ...(error s)... + +Fundamentally such contexts should not encourage inlining because, provided +the RHS is "expandable" (see Note [exprIsExpandable] in GHC.Core.Utils) the +context can ``see'' the unfolding of the variable (e.g. case or a +RULE) so there's no gain. + +However, watch out: + + * Consider this: + foo = \n. [n]) {-# INLINE foo #-} + bar = foo 20 {-# INLINE bar #-} + baz = \n. case bar of { (m:_) -> m + n } + Here we really want to inline 'bar' so that we can inline 'foo' + and the whole thing unravels as it should obviously do. This is + important: in the NDP project, 'bar' generates a closure data + structure rather than a list. + + So the non-inlining of lone_variables should only apply if the + unfolding is regarded as expandable; because that is when + exprIsConApp_maybe looks through the unfolding. Hence the "&& + is_exp" in the CaseCtxt branch of interesting_call + + * Even a type application or coercion isn't a lone variable. + Consider + case $fMonadST @ RealWorld of { :DMonad a b c -> c } + We had better inline that sucker! The case won't see through it. + + For now, I'm treating treating a variable applied to types + in a *lazy* context "lone". The motivating example was + f = /\a. \x. BIG + g = /\a. \y. h (f a) + There's no advantage in inlining f here, and perhaps + a significant disadvantage. Hence some_val_args in the Stop case + +Note [Interaction of exprIsWorkFree and lone variables] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The lone-variable test says "don't inline if a case expression +scrutinises a lone variable whose unfolding is cheap". It's very +important that, under these circumstances, exprIsConApp_maybe +can spot a constructor application. So, for example, we don't +consider + let x = e in (x,x) +to be cheap, and that's good because exprIsConApp_maybe doesn't +think that expression is a constructor application. + +In the 'not (lone_variable && is_wf)' test, I used to test is_value +rather than is_wf, which was utterly wrong, because the above +expression responds True to exprIsHNF, which is what sets is_value. + +This kind of thing can occur if you have + + {-# INLINE foo #-} + foo = let x = e in (x,x) + +which Roman did. + + +-} + +computeDiscount :: [Int] -> Int -> [ArgSummary] -> CallCtxt + -> Int +computeDiscount arg_discounts res_discount arg_infos cont_info + + = 10 -- Discount of 10 because the result replaces the call + -- so we count 10 for the function itself + + + 10 * length actual_arg_discounts + -- Discount of 10 for each arg supplied, + -- because the result replaces the call + + + total_arg_discount + res_discount' + where + actual_arg_discounts = zipWith mk_arg_discount arg_discounts arg_infos + total_arg_discount = sum actual_arg_discounts + + mk_arg_discount _ TrivArg = 0 + mk_arg_discount _ NonTrivArg = 10 + mk_arg_discount discount ValueArg = discount + + res_discount' + | LT <- arg_discounts `compareLength` arg_infos + = res_discount -- Over-saturated + | otherwise + = case cont_info of + BoringCtxt -> 0 + CaseCtxt -> res_discount -- Presumably a constructor + ValAppCtxt -> res_discount -- Presumably a function + _ -> 40 `min` res_discount + -- ToDo: this 40 `min` res_discount doesn't seem right + -- for DiscArgCtxt it shouldn't matter because the function will + -- get the arg discount for any non-triv arg + -- for RuleArgCtxt we do want to be keener to inline; but not only + -- constructor results + -- for RhsCtxt I suppose that exposing a data con is good in general + -- And 40 seems very arbitrary + -- + -- res_discount can be very large when a function returns + -- constructors; but we only want to invoke that large discount + -- when there's a case continuation. + -- Otherwise we, rather arbitrarily, threshold it. Yuk. + -- But we want to avoid inlining large functions that return + -- constructors into contexts that are simply "interesting" 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,4465 +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.Type hiding ( substTy, substTyVar, extendTvSubst, extendCvSubst ) -import GHC.Core.TyCo.Compare( eqType ) -import GHC.Core.Opt.Simplify.Env -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 ) -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. - - -Note [Shadowing] -~~~~~~~~~~~~~~~~ -The simplifier used to guarantee that the output had no shadowing, but -it does not do so any more. (Actually, it never did!) The reason is -documented with simplifyArgs. - - -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 env is_rec cont old_bndr new_bndr rhs env - - BC_Let top_lvl is_rec -> simplTrace "SimplBind:normal" (ppr old_bndr) $ - simplLazyBind env top_lvl is_rec old_bndr new_bndr 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 :: SimplEnv - -> TopLevelFlag -> RecFlag - -> InId -> OutId -- Binder, both pre-and post simpl - -- Not a JoinId - -- The OutId has IdInfo (notably RULES), - -- except arity, unfolding - -- Ids only, no TyVars - -> InExpr -> SimplEnv -- The RHS and its environment - -> SimplM (SimplFloats, SimplEnv) --- Precondition: the OutId is already in the InScopeSet of the incoming 'env' --- Precondition: not a JoinId --- Precondition: rhs obeys the let-can-float invariant -simplLazyBind env top_lvl is_rec bndr bndr1 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 env' = env `setInScopeFromF` rhs_floats - ; rhs' <- rebuildLam env' tvs' body3 rhs_cont - ; (bind_float, env2) <- completeBind env' (BC_Let top_lvl is_rec) bndr bndr1 rhs' - ; return (rhs_floats `addFloats` bind_float, env2) } - --------------------------- -simplJoinBind :: SimplEnv - -> RecFlag - -> SimplCont - -> InId -> OutId -- Binder, both pre-and post simpl - -- The OutId has IdInfo, except arity, - -- unfolding - -> InExpr -> SimplEnv -- The right hand side and its env - -> SimplM (SimplFloats, SimplEnv) -simplJoinBind env is_rec cont old_bndr new_bndr rhs rhs_se - = do { let rhs_env = rhs_se `setInScopeFromE` env - ; rhs' <- simplJoinRhs rhs_env old_bndr rhs cont - ; completeBind env (BC_Join is_rec cont) old_bndr new_bndr rhs' } - --------------------------- -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, 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 env1 (BC_Let NotTopLevel NonRecursive) - bndr new_bndr rhs1 - - ; 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 - , isConcrete (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 "{-# 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 shadowig 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 :: SimplEnv - -> BindContext - -> InId -- Old binder - -> OutId -- New binder; can be a JoinId - -> OutExpr -- New RHS - -> 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 env bind_cxt old_bndr new_bndr new_rhs - | 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 - ; new_unfolding <- simplLetUnfolding 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. - - -************************************************************************ -* * -\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 (map (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) = id - getDoneId (DoneEx e _) = getIdFromTrivialExpr 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 -- 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. - - ; (bind_float, env2) <- completeBind (env2 `setInScopeFromF` rhs_floats) - (BC_Let NotTopLevel NonRecursive) - bndr bndr2 rhs1 - -- 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 env2 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 - -> (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 env2 NotTopLevel NonRecursive - bndr bndr2 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 env2 NonRecursive cont bndr bndr2 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] - - -- 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] -~~~~~~~~~~~~~~~~ -This part of the simplifier may break the no-shadowing invariant -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! - -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 } - 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, @@ -43,17 +43,18 @@ ) where import GHC.Prelude hiding (head, init, last, tail) +import qualified GHC.Prelude as Partial (head) import GHC.Core import GHC.Types.Literal ( isLitRubbish ) import GHC.Core.Opt.Simplify.Env +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 @@ -79,11 +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 qualified Data.List as Partial ( head ) +import GHC.Types.Name.Env +import Data.Graph {- ********************************************************************* * * @@ -161,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] @@ -190,10 +194,11 @@ | StrictBind -- (StrictBind x b K)[e] = let x = e in K[b] -- or, equivalently, = K[ (\x.b) e ] { sc_dup :: DupFlag -- See Note [DupFlag invariants] - , sc_bndr :: InId , sc_from :: FromWhat + , sc_bndr :: InId , sc_body :: InExpr - , sc_env :: StaticEnv -- See Note [StaticEnv invariant] + , sc_env :: StaticEnv -- Static env for both sc_bndr (stable unfolding thereof) + -- and sc_body. Also see Note [StaticEnv invariant] , sc_cont :: SimplCont } | StrictArg -- (StrictArg (f e1 ..en) K)[e] = K[ f e1 .. en e ] @@ -213,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 @@ -271,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] @@ -316,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 @@ -334,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 @@ -348,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 @@ -411,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 @@ -422,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 - {- ************************************************************************ * * @@ -468,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 ------------------- @@ -482,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 ------------------- @@ -491,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 @@ -508,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 @@ -528,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 }) @@ -547,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 ------------------- @@ -574,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 @@ -593,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 :: @@ -612,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 @@ -687,7 +679,7 @@ | Just (_, _, arg_ty, fun_ty') <- splitFunTy_maybe fun_ty -- Add strict-type info , dmd : rest_dmds <- dmds , let dmd' - | Just Unlifted <- typeLevity_maybe arg_ty + | definitelyUnliftedType arg_ty = strictifyDmd dmd | otherwise -- Something that's not definitely unlifted. @@ -792,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 @@ -865,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 @@ -880,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. @@ -920,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 @@ -991,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 @@ -1222,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* @@ -1451,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. @@ -1470,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.) {- ************************************************************************ @@ -1513,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" @@ -1529,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 @@ -1570,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] @@ -1607,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 @@ -1858,11 +1931,12 @@ -> SimplM (ArityType, OutExpr) -- See Note [Eta-expanding at let bindings] tryEtaExpandRhs env bind_cxt bndr rhs - | do_eta_expand -- If the current manifest arity isn't enough - -- (never true for join points) - , seEtaExpand env -- and eta-expansion is on - , wantEtaExpansion rhs - = -- Do eta-expansion. + | seEtaExpand env -- If Eta-expansion is on + , wantEtaExpansion rhs -- and we'd like to eta-expand e + , do_eta_expand -- and e's manifest arity is lower than + -- what it could be + -- (never true for join points) + = -- Do eta-expansion. assertPpr( not (isJoinBC bind_cxt) ) (ppr bndr) $ -- assert: this never happens for join points; see GHC.Core.Opt.Arity -- Note [Do not eta-expand join points] @@ -2093,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 @@ -2100,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 @@ -2119,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' @@ -2127,20 +2234,23 @@ , 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 | isTyVar var -- CoVars have been substituted away = extendVarSet free_tvs var + | isCoVar var -- CoVars can be free in the RHS, but they are never let-bound; + = free_tvs -- Do not call lookupIdSubst_maybe, though (#23426) + -- because it has a non-CoVar precondition | Just poly_app <- GHC.Core.Subst.lookupIdSubst_maybe subst var = -- 'var' is like 'x' in (AB4) exprSomeFreeVars isTyVar poly_app `unionVarSet` free_tvs @@ -2178,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 @@ -2274,7 +2384,7 @@ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Note that we pass case_bndr::InId to prepareAlts; an /InId/, not an /OutId/. This is vital, because `refineDefaultAlt` uses `tys` to build -a new /InAlt/. If you pass an OutId, we'll end up appling the +a new /InAlt/. If you pass an OutId, we'll end up applying the substitution twice: disaster (#23012). However this does mean that filling in the default alt might be @@ -2309,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. +-} + {- ************************************************************************ * * @@ -2319,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 @@ -2432,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 @@ -2448,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" @@ -2462,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" } @@ -2471,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 @@ -2518,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 @@ -2603,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 @@ -2714,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] @@ -2723,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 #-} -#if __GLASGOW_HASKELL__ < 905 -{-# LANGUAGE PatternSynonyms #-} -#endif +{-# LANGUAGE LambdaCase #-} {- ToDo [Oct 2013] ~~~~~~~~~~~~~~~ @@ -14,33 +11,31 @@ \section[SpecConstr]{Specialise over constructors} -} - - -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} - module GHC.Core.Opt.SpecConstr( specConstrProgram, - SpecConstrAnnotation(..) + SpecConstrAnnotation(..), + SpecFailWarning(..) ) where import GHC.Prelude -import GHC.Driver.Session ( DynFlags(..), GeneralFlag( Opt_SpecConstrKeen ) +import GHC.Driver.DynFlags ( DynFlags(..), GeneralFlag( Opt_SpecConstrKeen ) , gopt, hasPprDebug ) import GHC.Core import GHC.Core.Subst import GHC.Core.Utils import GHC.Core.Unfold +import GHC.Core.Opt.Simplify.Inline 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 @@ -50,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(..) ) @@ -65,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 @@ -81,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 @@ -255,7 +250,7 @@ * Find the free variables of the abstracted pattern * Pass these variables, less any that are in scope at - the fn defn. But see Note [Shadowing] below. + the fn defn. But see Note [Shadowing in SpecConstr] below. NOTICE that we only abstract over variables that are not in scope, @@ -263,8 +258,8 @@ in f_spec's RHS. -Note [Shadowing] -~~~~~~~~~~~~~~~~ +Note [Shadowing in SpecConstr] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ In this pass we gather up usage information that may mention variables that are bound between the usage site and the definition site; or (more seriously) may be bound to something different at the definition site. @@ -519,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 @@ -637,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: @@ -769,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) } {- ************************************************************************ @@ -787,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) @@ -869,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 @@ -908,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 } @@ -920,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, @@ -980,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 @@ -1056,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 @@ -1074,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 @@ -1087,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 @@ -1168,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. @@ -1253,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 @@ -1274,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 @@ -1322,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 @@ -1347,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]) @@ -1378,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 @@ -1390,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] @@ -1460,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 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 @@ -1519,23 +1572,28 @@ ; 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. +-- Variables are dropped if they have a non-variable substitution, like in +-- 'GHC.Opt.Specialise.specTickish'. +scTickish :: ScEnv -> CoreTickish -> CoreTickish +scTickish SCE {sc_subst = subst} = substTickish subst {- Note [Do not specialise evals] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1577,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' @@ -1598,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. @@ -1612,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 @@ -1630,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) @@ -1708,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 @@ -1718,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, @@ -1737,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] @@ -1761,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 @@ -1782,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] @@ -1800,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] @@ -1811,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 @@ -1826,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] @@ -1850,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, []) --------------------- @@ -1867,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 @@ -1919,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 @@ -1928,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) @@ -1940,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 @@ -1967,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 @@ -1990,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 @@ -1999,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 @@ -2237,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 @@ -2247,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. @@ -2290,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 @@ -2360,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 @@ -2398,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) $ @@ -2449,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 @@ -2499,34 +2597,27 @@ -- Quantify over variables that are not in scope -- at the call site -- See Note [Free type variables of the qvar types] - -- See Note [Shadowing] at the top + -- 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 @@ -2594,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 @@ -2681,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 @@ -2714,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 @@ -2729,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 @@ -2737,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 @@ -2760,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] @@ -2773,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 @@ -10,15 +10,15 @@ import GHC.Prelude -import GHC.Driver.Session +import GHC.Driver.DynFlags import GHC.Driver.Config import GHC.Driver.Config.Diagnostic 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 @@ -68,6 +66,9 @@ import Data.List( partition ) import Data.List.NonEmpty ( NonEmpty (..) ) +import GHC.Core.Subst (substTickish) +import GHC.Core.TyCon (tyConClass_maybe) +import GHC.Core.DataCon (dataConTyCon) {- ************************************************************************ @@ -1202,14 +1203,21 @@ ---------------- Applications might generate a call instance -------------------- specExpr env expr@(App {}) = do { let (fun_in, args_in) = collectArgs expr + ; (fun_out, uds_fun) <- specExpr env fun_in ; (args_out, uds_args) <- mapAndCombineSM (specExpr env) args_in - ; let env_args = env `bringFloatedDictsIntoScope` ud_binds uds_args - -- Some dicts may have floated out of args_in; - -- they should be in scope for fireRewriteRules (#21689) - (fun_in', args_out') = fireRewriteRules env_args fun_in args_out - ; (fun_out', uds_fun) <- specExpr env fun_in' + ; let uds_app = uds_fun `thenUDs` uds_args + env_args = zapSubst env `bringFloatedDictsIntoScope` ud_binds uds_app + -- zapSubst: we have now fully applied the substitution + -- bringFloatedDictsIntoScope: some dicts may have floated out of + -- args_in; they should be in scope for fireRewriteRules (#21689) + + -- Try firing rewrite rules + -- See Note [Fire rules in the specialiser] + ; let (fun_out', args_out') = fireRewriteRules env_args fun_out args_out + + -- Make a call record, and return ; let uds_call = mkCallUDs env fun_out' args_out' - ; return (fun_out' `mkApps` args_out', uds_fun `thenUDs` uds_call `thenUDs` uds_args) } + ; return (fun_out' `mkApps` args_out', uds_app `thenUDs` uds_call) } ---------------- Lambda/case require dumping of usage details -------------------- specExpr env e@(Lam {}) @@ -1243,16 +1251,18 @@ -- See Note [Specialisation modulo dictionary selectors] -- Note [ClassOp/DFun selection] -- Note [Fire rules in the specialiser] -fireRewriteRules :: SpecEnv -> InExpr -> [OutExpr] -> (InExpr, [OutExpr]) +fireRewriteRules :: SpecEnv -- Substitution is already zapped + -> OutExpr -> [OutExpr] -> (OutExpr, [OutExpr]) fireRewriteRules env (Var f) args - | Just (rule, expr) <- specLookupRule env f args InitialPhase (getRules (se_rules env) f) + | let rules = getRules (se_rules env) f + , Just (rule, expr) <- specLookupRule env f args activeInInitialPhase rules , let rest_args = drop (ruleArity rule) args -- See Note [Extra args in the target] - zapped_subst = Core.zapSubst (se_subst env) - expr' = simpleOptExprWith defaultSimpleOpts zapped_subst expr + zapped_subst = se_subst env -- Just needed for the InScopeSet + expr' = simpleOptExprWith defaultSimpleOpts zapped_subst (mkApps expr rest_args) -- simplOptExpr needed because lookupRule returns -- (\x y. rhs) arg1 arg2 - , (fun, args) <- collectArgs expr' - = fireRewriteRules env fun (args++rest_args) + , (fun', args') <- collectArgs expr' + = fireRewriteRules env fun' args' fireRewriteRules _ fun args = (fun, args) -------------- @@ -1268,11 +1278,7 @@ -------------- specTickish :: SpecEnv -> CoreTickish -> CoreTickish -specTickish (SE { se_subst = subst }) (Breakpoint ext ix ids) - = Breakpoint ext ix [ id' | id <- ids, Var id' <- [Core.lookupIdSubst subst id]] - -- drop vars from the list if they have a non-variable substitution. - -- should never happen, but it's harmless to drop them anyway. -specTickish _ other_tickish = other_tickish +specTickish (SE { se_subst = subst }) bp = substTickish subst bp -------------- specCase :: SpecEnv @@ -1284,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') @@ -1322,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 @@ -1342,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) } @@ -1359,6 +1365,7 @@ where (env_rhs, args') = substBndrs env_alt args + {- Note [Fire rules in the specialiser] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider this (#21851) @@ -1383,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): @@ -1414,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] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1489,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 @@ -1626,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 @@ -1649,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) @@ -1670,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 @@ -1701,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] @@ -1759,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) @@ -1786,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'. @@ -1801,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] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1950,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 @@ -2131,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 @@ -2329,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: @@ -2481,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 @@ -2546,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. -- @@ -2650,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] @@ -2806,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 } @@ -2851,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` @@ -2903,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 @@ -2953,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 @@ -3007,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 @@ -3051,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 @@ -3089,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) @@ -3160,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`. @@ -3175,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}) @@ -3292,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 } @@ -3331,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 @@ -3358,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] @@ -3370,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 @@ -3447,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 @@ -3469,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') @@ -3484,21 +3652,9 @@ cloneRecBndrsSM :: SpecEnv -> [Id] -> SpecM (SpecEnv, [Id]) cloneRecBndrsSM env@(SE { se_subst = subst }) bndrs - = do { us <- getUniqueSupplyM - ; let (subst', bndrs') = Core.cloneRecIdBndrs subst us bndrs - env' = env { se_subst = subst' } + = 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 @@ -20,6 +20,8 @@ import GHC.Core.Opt.WorkWrap.Utils import GHC.Core.SimpleOpt +import GHC.Data.FastString + import GHC.Types.Var import GHC.Types.Id import GHC.Types.Id.Info @@ -33,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 @@ -68,9 +69,7 @@ wwTopBinds :: WwOpts -> UniqSupply -> CoreProgram -> CoreProgram wwTopBinds ww_opts us top_binds - = initUs_ us $ do - top_binds' <- mapM (wwBind ww_opts) top_binds - return (concat top_binds') + = initUs_ us $ concatMapM (wwBind ww_opts) top_binds {- ************************************************************************ @@ -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) @@ -821,7 +830,7 @@ NoInline _ -> inl_act fn_inl_prag _ -> inl_act wrap_prag - work_prag = InlinePragma { inl_src = SourceText "{-# INLINE" + work_prag = InlinePragma { inl_src = SourceText $ fsLit "{-# INLINE" , inl_inline = fn_inline_spec , inl_sat = Nothing , inl_act = work_act @@ -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]) @@ -889,7 +898,7 @@ mkStrWrapperInlinePrag (InlinePragma { inl_inline = fn_inl , inl_act = fn_act , inl_rule = rule_info }) rules - = InlinePragma { inl_src = SourceText "{-# INLINE" + = InlinePragma { inl_src = SourceText $ fsLit "{-# INLINE" , inl_sat = Nothing , inl_inline = fn_inl 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,19 +210,18 @@ -- 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 -- See Note [Freshen WW arguments] -- and Note [Zap IdInfo on worker args] - ; uniq_supply <- getUniqueSupplyM ; 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 uniq_supply zapped_arg_vars - res_ty' = substTyUnchecked subst res_ty + ; (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 ; (useful1, work_args_str, wrap_fn_str, fn_args) @@ -273,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 @@ -290,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] ~~~~~~~~~~~~~~~~~~~~~~~~ @@ -599,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] @@ -652,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 @@ -670,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) @@ -690,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 @@ -823,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] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -849,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 @@ -972,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') @@ -997,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 }) @@ -1174,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]). @@ -1182,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 @@ -1207,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 @@ -1218,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 @@ -1314,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 @@ -1389,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) @@ -159,9 +158,9 @@ -- So refer to printing j = e = pp_normal_bind where - (bndrs, body) = collectBinders expr - lhs_bndrs = take join_arity bndrs - rhs = mkLams (drop join_arity bndrs) body + (bndrs, body) = collectBinders expr + (lhs_bndrs, rest) = splitAt join_arity bndrs + rhs = mkLams rest body pprParendExpr expr = ppr_expr parens expr pprCoreExpr expr = ppr_expr noParens 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,51 +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, - mkHeteroPrimEqPred, mkHeteroReprPrimEqPred, + predTypeEqRel, pprPredType, + mkNomEqPred, mkReprEqPred, mkEqPred, mkEqPredRole, -- Class predicates mkClassPred, isDictTy, typeDeterminesValue, - isClassPred, isEqPredClass, isCTupleClass, + isClassPred, isEqualityClass, isCTupleClass, isUnaryClass, getClassPredTys, getClassPredTys_maybe, classMethodTy, classMethodInstTy, -- Implicit parameters - isIPLikePred, hasIPSuperClasses, 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( 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 -import Control.Monad ( guard ) +{- ********************************************************************* +* * +* 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 @@ -60,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. @@ -68,51 +134,144 @@ -- | A quantified predicate. -- - -- See Note [Quantified constraints] in GHC.Tc.Solver.Canonical + -- See Note [Quantified constraints] in GHC.Tc.Solver.Solve | ForAllPred [TyVar] [PredType] PredType -- 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) @@ -154,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 --------------------------------- @@ -171,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 @@ -189,66 +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.Canonical.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.Canonical. --} - -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 - -isEqPredClass :: Class -> Bool --- True of (~) and (~~) -isEqPredClass cls = cls `hasKey` eqTyConKey - || cls `hasKey` heqTyConKey - -isClassPred, isEqPred, isEqPrimPred :: PredType -> Bool -isClassPred ty = case tyConAppTyCon_maybe ty of - Just tyCon | isClassTyCon tyCon -> True - _ -> False - -isEqPred ty -- True of (a ~ b) and (a ~~ b) - -- ToDo: should we check saturation? - | Just tc <- tyConAppTyCon_maybe ty - , Just cls <- tyConClass_maybe tc - = isEqPredClass cls - | otherwise - = False - -isEqPrimPred ty = isCoVarType ty - -- True of (a ~# b) (a ~R# b) + | 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 {- ********************************************************************* * * @@ -256,6 +410,8 @@ * * ********************************************************************* -} +-- --------------------- Nomal implicit-parameter predicates --------------- + isIPTyCon :: TyCon -> Bool isIPTyCon tc = tc `hasKey` ipClassKey -- Class and its corresponding TyCon have the same Unique @@ -263,39 +419,49 @@ isIPClass :: Class -> Bool isIPClass cls = cls `hasKey` ipClassKey -isIPLikePred :: Type -> Bool --- See Note [Local implicit parameters] -isIPLikePred = is_ip_like_pred initIPRecTc +-- | Decomposes a predicate if it is an implicit parameter. Does not look in +-- superclasses. See also [Local implicit parameters]. +isIPPred_maybe :: Class -> [Type] -> Maybe (Type, Type) +isIPPred_maybe cls tys + | isIPClass cls + , [t1,t2] <- tys + = Just (t1,t2) + | 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) -is_ip_like_pred :: RecTcChecker -> Type -> Bool -is_ip_like_pred rec_clss ty - | Just (tc, tys) <- splitTyConApp_maybe ty - , Just rec_clss' <- if isTupleTyCon tc -- Tuples never cause recursion - then Just rec_clss - else checkRecTc rec_clss tc - , Just cls <- tyConClass_maybe tc - = isIPClass cls || has_ip_super_classes rec_clss' cls tys +-- --------------------- 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 - = False -- Includes things like (D []) where D is - -- a Constraint-ranged family; #7785 - -hasIPSuperClasses :: Class -> [Type] -> Bool --- See Note [Local implicit parameters] -hasIPSuperClasses = has_ip_super_classes initIPRecTc - -has_ip_super_classes :: RecTcChecker -> Class -> [Type] -> Bool -has_ip_super_classes rec_clss cls tys - = any ip_ish (classSCSelIds cls) - where - -- Check that the type of a superclass determines its value - -- sc_sel_id :: forall a b. C a b -> - ip_ish sc_sel_id = is_ip_like_pred rec_clss $ - classMethodInstTy sc_sel_id tys + = Nothing -initIPRecTc :: RecTcChecker -initIPRecTc = setRecTcMaxBound 1 initRecTc +-- | Is a type an 'ExceptionContext'? +isExceptionContextTy :: Type -> Bool +isExceptionContextTy ty + | Just tc <- tyConAppTyCon_maybe ty + = tc `hasKey` exceptionContextTyConKey + | otherwise + = False -- --------------------- CallStack predicates --------------------------------- @@ -329,19 +495,57 @@ | otherwise = False +-- --------------------- couldBeIPLike and mightMentionIP -------------------------- +-- See Note [Local implicit parameters] --- | Decomposes a predicate if it is an implicit parameter. Does not look in --- superclasses. See also [Local implicit parameters]. -isIPPred_maybe :: Type -> Maybe (FastString, Type) -isIPPred_maybe ty = - do (tc,[t1,t2]) <- splitTyConApp_maybe ty - guard (isIPTyCon tc) - x <- isStrLitTy t1 - return (x,t2) +couldBeIPLike :: Type -> Bool +-- Is `pred`, or any of its superclasses, an implicit parameter? +-- See Note [Local implicit parameters] +couldBeIPLike pred + = might_mention_ip1 initIPRecTc (const True) (const True) pred +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] +mightMentionIP = might_mention_ip initIPRecTc + +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 [ might_mention_ip1 rec_clss str_cond ty_cond (classMethodInstTy sc_sel_id tys) + | sc_sel_id <- classSCSelIds cls ] + + +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 + = 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 + +initIPRecTc :: RecTcChecker +initIPRecTc = setRecTcMaxBound 1 initRecTc + {- Note [Local implicit parameters] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The function isIPLikePred tells if this predicate, or any of its +See also wrinkle (SIP1) in Note [Shadowing of implicit parameters] in +GHC.Tc.Solver.Dict. + +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 @@ -349,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 @@ -390,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 ( @@ -361,8 +358,8 @@ (Reduction arg_co arg_ty) (Reduction res_co res_ty) = mkReduction - (mkFunCo1 r af w_co arg_co res_co) - (mkFunTy af w_ty arg_ty res_ty) + (mkFunCo r af w_co arg_co res_co) + (mkFunTy af w_ty arg_ty res_ty) {-# INLINE mkFunRedn #-} -- | Create a 'Reduction' associated to a Π type, @@ -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 @@ -41,14 +42,14 @@ import GHC.Unit.Module.ModGuts( ModGuts(..) ) import GHC.Unit.Module.Deps( Dependencies(..) ) -import GHC.Driver.Session( DynFlags ) +import GHC.Driver.DynFlags( DynFlags ) import GHC.Driver.Ppr( showSDoc ) import GHC.Core -- All of it import GHC.Core.Subst import GHC.Core.SimpleOpt ( exprIsLambda_maybe ) -import GHC.Core.FVs ( exprFreeVars, exprsFreeVars, bindFreeVars - , rulesFreeVarsDSet, exprsOrphNames ) +import GHC.Core.FVs ( exprFreeVars, bindFreeVars + , rulesFreeVarsDSet, orphNamesOfExprs ) import GHC.Core.Utils ( exprType, mkTick, mkTicks , stripTicksTopT, stripTicksTopE , isJoinBind, mkCastMCo ) @@ -62,7 +63,8 @@ import GHC.Core.Tidy ( tidyRules ) import GHC.Core.Map.Expr ( eqCoreExpr ) import GHC.Core.Opt.Arity( etaExpandToJoinPointRule ) -import GHC.Core.Opt.OccurAnal ( occurAnalyseExpr ) +import GHC.Core.Make ( mkCoreLams ) +import GHC.Core.Opt.OccurAnal( occurAnalyseExpr ) import GHC.Tc.Utils.TcType ( tcSplitTyConApp_maybe ) import GHC.Builtin.Types ( anyTypeOfKind ) @@ -83,7 +85,9 @@ import GHC.Data.FastString import GHC.Data.Maybe 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 @@ -204,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 @@ -218,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 @@ -441,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 @@ -465,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: @@ -519,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 @@ -549,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] ) @@ -563,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))) @@ -579,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 @@ -598,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: @@ -643,7 +676,8 @@ -} ------------------------------------ -matchRule :: RuleOpts -> InScopeEnv -> (Activation -> Bool) +matchRule :: HasDebugCallStack + => RuleOpts -> InScopeEnv -> (Activation -> Bool) -> Id -> [CoreExpr] -> [Maybe Name] -> CoreRule -> Maybe CoreExpr @@ -688,7 +722,8 @@ --------------------------------------- -matchN :: InScopeEnv +matchN :: HasDebugCallStack + => InScopeEnv -> RuleName -> [Var] -> [CoreExpr] -> [CoreExpr] -> CoreExpr -- ^ Target; can have more elements than the template -> Maybe CoreExpr @@ -702,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] @@ -721,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 @@ -750,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 @@ -796,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 :: *). @@ -892,8 +936,13 @@ -- * The BindWrapper in a RuleSubst are the bindings floated out -- from nested matches; see the Let case of match, below -- -data RuleSubst = RS { rs_tv_subst :: TvSubstEnv -- Range is the - , rs_id_subst :: IdSubstEnv -- template variables +data RuleSubst = RS { -- Substitution; applied only to the template, not the target + -- Domain is the template variables + -- Range never includes template variables + rs_tv_subst :: TvSubstEnv + , rs_id_subst :: IdSubstEnv + + -- Floated bindings , rs_binds :: BindWrapper -- Floated bindings , rs_bndrs :: [Var] -- Variables bound by floated lets } @@ -937,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 @@ -1037,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 @@ -1070,6 +1146,165 @@ -- because of the not-inRnEnvR ------------------------ Applications --------------------- +-- See Note [Matching higher order patterns] +match renv@(RV { rv_tmpls = tmpls, rv_lcl = rn_env }) + subst e1@App{} e2 + MRefl -- Like the App case we insist on Refl here + -- See Note [Casts in the target] + | (Var f, args) <- collectArgs e1 + , let f' = rnOccL rn_env f -- See similar rnOccL in match_var + , f' `elemVarSet` tmpls -- (HOP1) + , Just vs2 <- traverse arg_as_lcl_var args -- (HOP2), (HOP3) + , hasNoDups vs2 -- (HOP4) + , not can_decompose_app_instead + = match_tmpl_var renv subst f' (mkCoreLams vs2 e2) + -- match_tmpl_var checks (HOP5) and (HOP6) + where + arg_as_lcl_var :: CoreExpr -> Maybe Var + arg_as_lcl_var (Var v) + | Just v' <- rnOccL_maybe rn_env v + , not (v' `elemVarSet` tmpls) -- rnEnvL contains the template variables + = Just (to_target v') -- to_target: see (W1) + -- in Note [Matching higher order patterns] + arg_as_lcl_var _ = Nothing + + can_decompose_app_instead -- Template (e1 v), target (e2 v), and v # fvs(e2) + = case (e1, e2) of -- See (W2) in Note [Matching higher order patterns] + (App _ (Var v1), App f2 (Var v2)) + -> rnOccL rn_env v1 == rnOccR rn_env v2 + && not (v2 `elemVarSet` exprFreeVars f2) + _ -> False + + ---------------- + -- to_target: see (W1) in Note [Matching higher order patterns] + to_target :: Var -> Var -- From canonical variable back to target-expr variable + to_target v = lookupVarEnv rev_envR v `orElse` v + + rev_envR :: VarEnv Var -- Inverts rnEnvR: from canonical variable + -- back to target-expr variable + rev_envR = nonDetStrictFoldVarEnv_Directly add_one emptyVarEnv (rnEnvR rn_env) + add_one uniq var env = extendVarEnv env var (var `setVarUnique` uniq) + +{- Note [Matching higher order patterns] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Higher order patterns provide a limited form of higher order matching. +See GHC Proposal #555 + https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0555-template-patterns.rst +and #22465 for more details and related work. + +Consider the potential match: + + Template: forall f. foo (\x -> f x) + Target: foo (\x -> x*2 + x) + +The expression `x*2 + x` in the target is not literally an application of a +function to the variable `x`, so the simple application rule does not apply. +However, we can match them modulo beta equivalence with the substitution: + + [f :-> \x -> x*2 + x] + +The general problem of higher order matching is tricky to implement, but +the subproblem which we call /higher order pattern matching/ is sufficient +for the given example and much easier to implement. + +Design: + +We start with terminology. + +* /Template variables/. The forall'd variables are called the template + variables. In the example match above, `f` is a template variable. + +* /Local binders/. The local binders of a rule are the variables bound + inside the template. In the example match above, `x` is a local binder. + Note that local binders can be term variables and type variables. + +A /higher order pattern/ (HOP) is a sub-expression of the template, +of form (f x y z) where: + +* (HOP1) f is a template variable +* (HOP2) x, y, z are local binders (like y in rule "wombat" above; see definitions). +* (HOP3) The arguments x, y, z are term variables +* (HOP4) The arguments x, y, z are distinct (no duplicates) + +Matching of higher order patterns (HOP-matching). A higher order pattern (f x y z) +(in the template) matches any target expression e provided: + +* (HOP5) The target has the same type as the template +* (HOP6) No local binder is free in e, other than x, y, z. + +If these two condition hold, the higher order pattern (f x y z) matches +the target expression e, yielding the substitution [f :-> \x y z. e]. +Notice that this substitution is type preserving, and the RHS +of the substitution has no free local binders. + +HOP matching is small enough to be done in-line in the `match` function. +Two wrinkles: + +(W1) Consider the potential match: + Template: forall f. foo (\x -> f x) + Target: foo (\y -> (y, y)) + During matching we make `x` the canonical variable for the lambdas + and then we see: + Template: f x rnEnvL = [] + Target: (y, y) rnEnvR = [y :-> x] + We could bind [f :-> \x. (x,x)], by applying rnEnvR substitution to the target + expression. But that is tiresome (a) because it involves a traversal, and + (b) because rnEnvR is a VarEnv Var, and we don't have a substitution function + for that. + + So instead, we invert rnEnvR, and apply it to the binders, to get + [f :-> \y. (y,y)]. This is done by `to_target` in the HOP-matching case. + It takes a little bit of thinking to be sure this will work right in the case + of shadowing. E.g. Template (\x y. f x y) Target (\p p. p*p) + Here rnEnvR will be just [p :-> y], so after inversion we'll get + [f :-> \x p. p*p] + but that is fine. + +(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: + Template: forall f. foo (\x y. Just (f y x)) + Target: foo (\p q. Just (h (1+q) p))) + During matching we will encounter: + Template: f x y + Target: h (1+q) p rnEnvR = [p:->x, q:->y] + The rnEnvR renaming `[p:->x, q:->y]` is done by the matcher (today) on the fly, + to make the bound variables of the template and target "line up". + But now we can: + * Either use the new HOP rule to succeed with + [f :-> \x y. h (1+x) y] + * Or use the existing decompose-application rule to match + (f x) against (h (1+q)) and `y` against `p`. + This will succeed with + [f :-> \y. h (1+y)] + + Note that the result of the HOP rule will always be eta-equivalent to + the result of the decompose-application rule. But the proposal specifies + that we should use the decompose-application rule because it involves + less eta-expansion. + + But take care: + Template: forall f. foo (\x y. Just (f y x)) + Target: foo (\p q. Just (h (p+q) p))) + Then during matching we will encounter: + Template: f x y + Target: h (p+q) p rnEnvR = [p:->x, q:->y] + Now, we cannot use the decompose-application rule, because p is free in + (h (p+q)). So, we can only use the new HOP rule. + +(W3) You might wonder if a HOP can have /type/ arguments, thus (in Core) + RULE forall h. + 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 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 + has only term-variable arguments. +-} + -- Note the match on MRefl! We fail if there is a cast in the target -- (e1 e2) ~ (d1 d2) |> co -- See Note [Cancel reflexive casts]: in the Cast equations for 'match' @@ -1108,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 @@ -1267,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 @@ -1329,7 +1599,8 @@ not_captured fv = not (inRnEnvR rn_env fv) ------------------------------------------ -match_var :: RuleMatchEnv +match_var :: HasDebugCallStack + => RuleMatchEnv -> RuleSubst -> Var -- Template -> CoreExpr -- Target @@ -1365,7 +1636,8 @@ -- template x, so we must rename first! ------------------------------------------ -match_tmpl_var :: RuleMatchEnv +match_tmpl_var :: HasDebugCallStack + => RuleMatchEnv -> RuleSubst -> Var -- Template -> CoreExpr -- Target @@ -1378,7 +1650,7 @@ -- if the right side of the env is empty. | anyInRnEnvR rn_env (exprFreeVars e2) = Nothing -- Skolem-escape failure - -- e.g. match forall a. (\x-> a x) against (\y. y y) + -- e.g. match forall a. (\x -> a) against (\y -> y) | Just e1' <- lookupVarEnv id_subst v1' = if eqCoreExpr e1' e2' @@ -1398,6 +1670,7 @@ -- because no free var of e2' is in the rnEnvR of the envt ------------------------------------------ + match_ty :: RuleMatchEnv -> RuleSubst -> Type -- Template @@ -1409,12 +1682,13 @@ -- newtype T = MkT Int -- We only want to replace (f T) with f', not (f Int). -match_ty renv subst ty1 ty2 - = do { tv_subst' - <- Unify.ruleMatchTyKiX (rv_tmpls renv) (rv_lcl renv) tv_subst ty1 ty2 +match_ty (RV { rv_tmpls = tmpls, rv_lcl = rn_env }) + subst@(RS { rs_tv_subst = tv_subst }) + ty1 ty2 + = do { tv_subst' <- Unify.ruleMatchTyKiX tmpls rn_env tv_subst ty1 ty2 + -- NB: ruleMatchTyKiX applis tv_subst to ty1 only + -- and of course only binds 'tmpls' ; return (subst { rs_tv_subst = tv_subst' }) } - where - tv_subst = rs_tv_subst subst {- Note [Matching variable types] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1637,41 +1911,59 @@ vcat [ p $$ line | p <- bagToList results ] ] where + line = text (replicate 20 '-') env = RuleCheckEnv { rc_is_active = isActive phase , rc_id_unf = idUnfolding -- Not quite right -- Should use activeUnfolding , rc_pattern = rule_pat , rc_rules = rules , rc_ropts = ropts - } - results = unionManyBags (map (ruleCheckBind env) binds) - line = text (replicate 20 '-') + , rc_in_scope = emptyInScopeSet } -data RuleCheckEnv = RuleCheckEnv { - rc_is_active :: Activation -> Bool, - rc_id_unf :: IdUnfoldingFun, - rc_pattern :: String, - rc_rules :: Id -> [CoreRule], - rc_ropts :: RuleOpts -} + results = go env binds -ruleCheckBind :: RuleCheckEnv -> CoreBind -> Bag SDoc + go _ [] = emptyBag + go env (bind:binds) = let (env', ds) = ruleCheckBind env bind + in ds `unionBags` go env' binds + +data RuleCheckEnv = RuleCheckEnv + { rc_is_active :: Activation -> Bool + , rc_id_unf :: IdUnfoldingFun + , rc_pattern :: String + , rc_rules :: Id -> [CoreRule] + , rc_ropts :: RuleOpts + , rc_in_scope :: InScopeSet } + +extendInScopeRC :: RuleCheckEnv -> Var -> RuleCheckEnv +extendInScopeRC env@(RuleCheckEnv { rc_in_scope = in_scope }) v + = env { rc_in_scope = in_scope `extendInScopeSet` v } + +extendInScopeListRC :: RuleCheckEnv -> [Var] -> RuleCheckEnv +extendInScopeListRC env@(RuleCheckEnv { rc_in_scope = in_scope }) vs + = env { rc_in_scope = in_scope `extendInScopeSetList` vs } + +ruleCheckBind :: RuleCheckEnv -> CoreBind -> (RuleCheckEnv, Bag SDoc) -- The Bag returned has one SDoc for each call site found -ruleCheckBind env (NonRec _ r) = ruleCheck env r -ruleCheckBind env (Rec prs) = unionManyBags [ruleCheck env r | (_,r) <- prs] +ruleCheckBind env (NonRec b r) = (env `extendInScopeRC` b, ruleCheck env r) +ruleCheckBind env (Rec prs) = (env', unionManyBags (map (ruleCheck env') rhss)) + where + (bs, rhss) = unzip prs + env' = env `extendInScopeListRC` bs ruleCheck :: RuleCheckEnv -> CoreExpr -> Bag SDoc -ruleCheck _ (Var _) = emptyBag -ruleCheck _ (Lit _) = emptyBag -ruleCheck _ (Type _) = emptyBag -ruleCheck _ (Coercion _) = emptyBag -ruleCheck env (App f a) = ruleCheckApp env (App f a) [] -ruleCheck env (Tick _ e) = ruleCheck env e -ruleCheck env (Cast e _) = ruleCheck env e -ruleCheck env (Let bd e) = ruleCheckBind env bd `unionBags` ruleCheck env e -ruleCheck env (Lam _ e) = ruleCheck env e -ruleCheck env (Case e _ _ as) = ruleCheck env e `unionBags` - unionManyBags [ruleCheck env r | Alt _ _ r <- as] +ruleCheck _ (Var _) = emptyBag +ruleCheck _ (Lit _) = emptyBag +ruleCheck _ (Type _) = emptyBag +ruleCheck _ (Coercion _) = emptyBag +ruleCheck env (App f a) = ruleCheckApp env (App f a) [] +ruleCheck env (Tick _ e) = ruleCheck env e +ruleCheck env (Cast e _) = ruleCheck env e +ruleCheck env (Let bd e) = let (env', ds) = ruleCheckBind env bd + in ds `unionBags` ruleCheck env' e +ruleCheck env (Lam b e) = ruleCheck (env `extendInScopeRC` b) e +ruleCheck env (Case e b _ as) = ruleCheck env e `unionBags` + unionManyBags [ruleCheck (env `extendInScopeListRC` (b:bs)) r + | Alt _ bs r <- as] ruleCheckApp :: RuleCheckEnv -> Expr CoreBndr -> [Arg CoreBndr] -> Bag SDoc ruleCheckApp env (App f a) as = ruleCheck env a `unionBags` ruleCheckApp env f (a:as) @@ -1695,8 +1987,9 @@ vcat [text "Expression:" <+> ppr (mkApps (Var fn) args), vcat (map check_rule rules)] where - n_args = length args - i_args = args `zip` [1::Int ..] + in_scope = rc_in_scope env + n_args = length args + i_args = args `zip` [1::Int ..] rough_args = map roughTopName args check_rule rule = rule_herald rule <> colon <+> rule_info (rc_ropts env) rule @@ -1726,10 +2019,8 @@ mismatches = [i | (rule_arg, (arg,i)) <- rule_args `zip` i_args, not (isJust (match_fn rule_arg arg))] - lhs_fvs = exprsFreeVars rule_args -- Includes template tyvars match_fn rule_arg arg = match renv emptyRuleSubst rule_arg arg MRefl where - in_scope = mkInScopeSet (lhs_fvs `unionVarSet` exprFreeVars arg) renv = RV { rv_lcl = mkRnEnv2 in_scope , rv_tmpls = mkVarSet rule_bndrs , rv_fltR = mkEmptySubst in_scope 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,19 +260,20 @@ (env', r) = k env{soe_rec_ids = extendUnVarSetList bndrs (soe_rec_ids env)} --------------- -simple_opt_clo :: InScopeSet +simple_opt_clo :: HasDebugCallStack + => InScopeSet -> SimpleClo -> OutExpr simple_opt_clo in_scope (e_env, e) = simple_opt_expr (soeSetInScope in_scope e_env) e -simple_opt_expr :: HasCallStack => SimpleOptEnv -> InExpr -> OutExpr +simple_opt_expr :: HasDebugCallStack => SimpleOptEnv -> InExpr -> OutExpr simple_opt_expr env expr = go expr 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 --------------- @@ -263,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. @@ -273,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 @@ -335,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 @@ -399,7 +432,8 @@ simple_app env e as = finish_app env (simple_opt_expr env e) as -finish_app :: SimpleOptEnv -> OutExpr -> [SimpleClo] -> OutExpr +finish_app :: HasDebugCallStack + => SimpleOptEnv -> OutExpr -> [SimpleClo] -> OutExpr -- See Note [Eliminate casts in function position] finish_app env (Cast (Lam x e) co) as@(_:_) | not (isTyVar x) && not (isCoVar x) @@ -448,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 @@ -474,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 @@ -490,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] @@ -497,14 +532,27 @@ | otherwise = True -- Unconditionally safe to inline - safe_to_inline :: OccInfo -> Bool - safe_to_inline IAmALoopBreaker{} = False - safe_to_inline IAmDead = True - safe_to_inline OneOcc{ occ_in_lam = NotInsideLam - , occ_n_br = 1 } = True - safe_to_inline OneOcc{} = False - safe_to_inline ManyOccs{} = False +safe_to_inline :: OccInfo -> Bool +safe_to_inline IAmALoopBreaker{} = False +safe_to_inline IAmDead = True +safe_to_inline OneOcc{ occ_in_lam = NotInsideLam + , occ_n_br = 1 } = True +safe_to_inline OneOcc{} = False +safe_to_inline ManyOccs{} = False +do_beta_by_substitution :: Id -> CoreExpr -> Bool +-- True <=> you can inline (bndr = rhs) by substitution +-- See Note [Exploit occ-info in exprIsConApp_maybe] +do_beta_by_substitution bndr rhs + = 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 @@ -528,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 @@ -547,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 @@ -759,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 @@ -813,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. @@ -853,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. @@ -1078,6 +1137,45 @@ See test T16254, which checks the behavior of newtypes. +Note [Exploit occ-info in exprIsConApp_maybe] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose (#23159) we have a simple data constructor wrapper like this (this one +might have come from a data family instance): + $WK x y = K x y |> co +Now suppose the simplifier sees + case ($WK e1 e2) |> co2 of + K p q -> case q of ... + +`exprIsConApp_maybe` expands the wrapper on the fly +(see Note [beta-reduction in exprIsConApp_maybe]). It effectively expands +that ($WK e1 e2) to + let x = e1; y = e2 in K x y |> co + +So the Simplifier might end up producing this: + let x = e1; y = e2 + in case x of ... + +But suppose `q` was used just once in the body of the `K p q` alternative; we +don't want to wait a whole Simplifier iteration to inline that `x`. (e1 might +be another constructor for example.) This would happen if `exprIsConApp_maybe` +we created a let for every (non-trivial) argument. So let's not do that when +the binder is used just once! + +Instead, take advantage of the occurrence-info on `x` and `y` in the unfolding +of `$WK`. Since in `$WK` both `x` and `y` occur once, we want to effectively +expand `($WK e1 e2)` to `(K e1 e2 |> co)`. Hence in +`do_beta_by_substitution` we say "yes" if + + (a) the RHS is trivial (so we can duplicate it); + see call to `exprIsTrivial` +or + (b) the binder occurs at most once (so there is no worry about duplication); + see call to `safe_to_inline`. + +To see this in action, look at testsuite/tests/perf/compiler/T15703. The +initial Simlifier run takes 5 iterations without (b), but only 3 when we add +(b). + Note [Don't float join points] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ exprIsConApp_maybe should succeed on @@ -1158,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 @@ -1180,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" @@ -1193,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 @@ -1219,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) - | exprIsTrivial arg -- Don't duplicate stuff! - = go (extend subst bndr arg) floats body (CC 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 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) @@ -1244,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] @@ -1283,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, @@ -1301,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 @@ -1325,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) @@ -1349,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# ""#. @@ -1368,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] @@ -423,6 +426,11 @@ 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 @@ -430,12 +438,14 @@ -- | Clone a mutually recursive group of 'Id's cloneRecIdBndrs :: Subst -> UniqSupply -> [Id] -> (Subst, [Id]) -cloneRecIdBndrs subst us ids - = (subst', ids') - where - (subst', ids') = mapAccumL (clone_id subst') subst - (ids `zip` uniqsFromSupply us) +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,14 +599,16 @@ = 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 (map do_one ids) +substTickish subst (Breakpoint ext bid ids) + = Breakpoint ext bid (mapMaybe do_one ids) where - do_one = getIdFromTrivialExpr . lookupIdSubst subst + do_one = getIdFromTrivialExpr_maybe . lookupIdSubst subst + substTickish _subst other = other {- Note [Substitute lazily] @@ -649,6 +663,13 @@ for an Id in a breakpoint. We ensure this by never storing an Id with an unlifted type in a Breakpoint - see GHC.HsToCore.Ticks.mkTickish. Breakpoints can't handle free variables with unlifted types anyway. + +These measures are only reliable with unoptimized code. +Since we can now enable optimizations for GHCi with +@-fno-unoptimized-core-for-interpreter -O@, nontrivial expressions can be +substituted, e.g. by specializations. +Therefore we resort to discarding free variables from breakpoints when this +situation occurs. -} {- 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 @@ -324,7 +592,7 @@ See Note [Non-trivial definitional equality] in GHC.Core.TyCo.Rep. * Typechecker equality, as implemented by tcEqType. - GHC.Tc.Solver.Canonical.canEqNC also respects typechecker equality. + GHC.Tc.Solver.Equality.canonicaliseEquality also respects typechecker equality. Typechecker equality implied definitional equality: if two types are equal according to typechecker equality, then they are also equal according to @@ -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 - * TcCanonical.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 @@ -1,4 +1,4 @@ - +{-# LANGUAGE MultiWayIf #-} module GHC.Core.TyCo.FVs ( shallowTyCoVarsOfType, shallowTyCoVarsOfTypes, @@ -19,11 +19,12 @@ tyCoVarsOfCoDSet, tyCoFVsOfCo, tyCoFVsOfCos, tyCoVarsOfCoList, + coVarsOfCoDSet, coVarsOfCosDSet, almostDevoidCoVarOfCo, -- Injective free vars - injectiveVarsOfType, injectiveVarsOfTypes, + injectiveVarsOfType, injectiveVarsOfTypes, isInjectiveInType, invisibleVarsOfType, invisibleVarsOfTypes, -- Any and No Free vars @@ -39,10 +40,6 @@ -- * Occurrence-check expansion occCheckExpand, - -- * Well-scoped free variables - scopedSort, tyCoVarsOfTypeWellScoped, - tyCoVarsOfTypesWellScoped, - -- * Closing over kinds closeOverKindsDSet, closeOverKindsList, closeOverKinds, @@ -53,15 +50,15 @@ import GHC.Prelude -import {-# SOURCE #-} GHC.Core.Type( partitionInvisibleTypes, coreView ) +import {-# SOURCE #-} GHC.Core.Type( partitionInvisibleTypes, coreView, rewriterView ) import {-# SOURCE #-} GHC.Core.Coercion( coercionLKind ) 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 @@ -806,6 +812,28 @@ * * ********************************************************************* -} +isInjectiveInType :: TyVar -> Type -> Bool +-- True <=> tv /definitely/ appears injectively in ty +-- A bit more efficient that (tv `elemVarSet` injectiveTyVarsOfType ty) +-- Ignore occurrence in coercions, and even in injective positions of +-- type families. +isInjectiveInType tv ty + = go ty + where + go ty | Just ty' <- rewriterView ty = go ty' + go (TyVarTy tv') = tv' == tv + go (AppTy f a) = go f || go a + go (FunTy _ w ty1 ty2) = go w || go ty1 || go ty2 + go (TyConApp tc tys) = go_tc tc tys + go (ForAllTy (Bndr tv' _) ty) = go (tyVarKind tv') + || (tv /= tv' && go ty) + go LitTy{} = False + go (CastTy ty _) = go ty + go CoercionTy{} = False + + go_tc tc tys | isTypeFamilyTyCon tc = False + | otherwise = any go tys + -- | Returns the free variables of a 'Type' that are in injective positions. -- Specifically, it finds the free variables while: -- @@ -836,25 +864,30 @@ -> Type -> FV injectiveVarsOfType look_under_tfs = go where - go ty | Just ty' <- coreView ty - = go ty' - go (TyVarTy v) = unitFV v `unionFV` go (tyVarKind v) - go (AppTy f a) = go f `unionFV` go a - go (FunTy _ w ty1 ty2) = go w `unionFV` go ty1 `unionFV` go ty2 - go (TyConApp tc tys) = - case tyConInjectivityInfo tc of - Injective inj - | look_under_tfs || not (isTypeFamilyTyCon tc) - -> mapUnionFV go $ - filterByList (inj ++ repeat True) tys + go ty | Just ty' <- rewriterView ty = go ty' + go (TyVarTy v) = unitFV v `unionFV` go (tyVarKind v) + go (AppTy f a) = go f `unionFV` go a + go (FunTy _ w ty1 ty2) = go w `unionFV` go ty1 `unionFV` go ty2 + go (TyConApp tc tys) = go_tc tc tys + go (ForAllTy (Bndr tv _) ty) = go (tyVarKind tv) `unionFV` delFV tv (go ty) + go LitTy{} = emptyFV + go (CastTy ty _) = go ty + go CoercionTy{} = emptyFV + + go_tc tc tys + | isTypeFamilyTyCon tc + = if | look_under_tfs + , Injective flags <- tyConInjectivityInfo tc + -> mapUnionFV go $ + filterByList (flags ++ repeat True) tys -- Oversaturated arguments to a tycon are -- always injective, hence the repeat True - _ -> emptyFV - go (ForAllTy (Bndr tv _) ty) = go (tyVarKind tv) `unionFV` delFV tv (go ty) - go LitTy{} = emptyFV - go (CastTy ty _) = go ty - go CoercionTy{} = emptyFV + | otherwise -- No injectivity info for this type family + -> emptyFV + | otherwise -- Data type, injective in all positions + = mapUnionFV go tys + -- | Returns the free variables of a 'Type' that are in injective positions. -- Specifically, it finds the free variables while: -- @@ -916,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 @@ -949,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 - {- ************************************************************************ * * @@ -1058,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. @@ -1082,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 @@ -1096,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 @@ -1266,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 @@ -1289,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 #-} @@ -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, 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] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -325,113 +290,6 @@ be careful not to let any variables escape -- thus the last premise of the rule above. -Note [Constraints in kinds] -~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Do we allow a type constructor to have a kind like - S :: Eq a => a -> Type - -No, we do not. Doing so would mean would need a TyConApp like - S @k @(d :: Eq k) (ty :: k) - and we have no way to build, or decompose, evidence like - (d :: Eq k) at the type level. - -But we admit one exception: equality. We /do/ allow, say, - MkT :: (a ~ b) => a -> b -> Type a b - -Why? Because we can, without much difficulty. Moreover -we can promote a GADT data constructor (see TyCon -Note [Promoted data constructors]), like - data GT a b where - MkGT : a -> a -> GT a a -so programmers might reasonably expect to be able to -promote MkT as well. - -How does this work? - -* In GHC.Tc.Validity.checkConstraintsOK we reject kinds that - have constraints other than (a~b) and (a~~b). - -* In Inst.tcInstInvisibleTyBinder we instantiate a call - of MkT by emitting - [W] co :: alpha ~# beta - and producing the elaborated term - MkT @alpha @beta (Eq# alpha beta co) - We don't generate a boxed "Wanted"; we generate only a - regular old /unboxed/ primitive-equality Wanted, and build - the box on the spot. - -* How can we get such a MkT? By promoting a GADT-style data - constructor, written with an explicit equality constraint. - data T a b where - MkT :: (a~b) => a -> b -> T a b - See DataCon.mkPromotedDataCon - and Note [Promoted data constructors] in GHC.Core.TyCon - -* We support both homogeneous (~) and heterogeneous (~~) - equality. (See Note [The equality types story] - in GHC.Builtin.Types.Prim for a primer on these equality types.) - -* How do we prevent a MkT having an illegal constraint like - Eq a? We check for this at use-sites; see GHC.Tc.Gen.HsType.tcTyVar, - specifically dc_theta_illegal_constraint. - -* Notice that nothing special happens if - K :: (a ~# b) => blah - because (a ~# b) is not a predicate type, and is never - implicitly instantiated. (Mind you, it's not clear how you - could creates a type constructor with such a kind.) See - Note [Types for coercions, predicates, and evidence] - -* The existence of promoted MkT with an equality-constraint - argument is the (only) reason that the AnonTCB constructor - of TyConBndrVis carries an FunTyFlag. - For example, when we promote the data constructor - MkT :: forall a b. (a~b) => a -> b -> T a b - we get a PromotedDataCon with tyConBinders - Bndr (a :: Type) (NamedTCB Inferred) - Bndr (b :: Type) (NamedTCB Inferred) - Bndr (_ :: a ~ b) (AnonTCB FTF_C_T) - Bndr (_ :: a) (AnonTCB FTF_T_T)) - Bndr (_ :: b) (AnonTCB FTF_T_T)) - -* One might reasonably wonder who *unpacks* these boxes once they are - made. After all, there is no type-level `case` construct. The - surprising answer is that no one ever does. Instead, if a GADT - constructor is used on the left-hand side of a type family equation, - that occurrence forces GHC to unify the types in question. For - example: - - data G a where - MkG :: G Bool - - type family F (x :: G a) :: a where - F MkG = False - - When checking the LHS `F MkG`, GHC sees the MkG constructor and then must - unify F's implicit parameter `a` with Bool. This succeeds, making the equation - - F Bool (MkG @Bool ) = False - - Note that we never need unpack the coercion. This is because type - family equations are *not* parametric in their kind variables. That - is, we could have just said - - type family H (x :: G a) :: a where - H _ = False - - The presence of False on the RHS also forces `a` to become Bool, - giving us - - H Bool _ = False - - The fact that any of this works stems from the lack of phase - separation between types and kinds (unlike the very present phase - separation between terms and types). - - Once we have the ability to pattern-match on types below top-level, - this will no longer cut it, but it seems fine for now. - - Note [Arguments to type constructors] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Because of kind polymorphism, in addition to type application we now @@ -456,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? @@ -559,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) @@ -582,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, @@ -595,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). @@ -624,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 @@ -648,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] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -828,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 @@ -870,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 @@ -892,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 @@ -907,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 + {- %************************************************************************ %* * @@ -956,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 @@ -974,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. @@ -984,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 @@ -1028,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 @@ -1045,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 @@ -1070,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'. @@ -1152,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. @@ -1181,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] ~~~~~~~~~~~~ @@ -1253,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 @@ -1467,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; @@ -1512,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 @@ -1534,34 +1525,134 @@ -- 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_ref :: IORef (Maybe Coercion) } coHoleCoVar :: CoercionHole -> CoVar @@ -1582,19 +1673,7 @@ 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 @@ -1669,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 @@ -1759,7 +1808,6 @@ | tv `elemVarSet` acc = acc | otherwise = acc `extendVarSet` tv - we want to end up with fvs ty = go emptyVarSet ty emptyVarSet where @@ -1789,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 @@ -1827,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 @@ -1842,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 @@ -1858,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 @@ -1893,28 +1967,34 @@ -- function is used only in reporting, not decision-making. typeSize :: Type -> Int +-- The size of the syntax tree of a type. No special treatment +-- for type synonyms or type families. typeSize (LitTy {}) = 1 typeSize (TyVarTy {}) = 1 typeSize (AppTy t1 t2) = typeSize t1 + typeSize t2 typeSize (FunTy _ _ t1 t2) = typeSize t1 + typeSize t2 typeSize (ForAllTy (Bndr tv _) t) = typeSize (varType tv) + typeSize t -typeSize (TyConApp _ ts) = 1 + sum (map typeSize ts) +typeSize (TyConApp _ ts) = 1 + typesSize ts typeSize (CastTy ty co) = typeSize ty + coercionSize co typeSize (CoercionTy co) = coercionSize co +typesSize :: [Type] -> Int +typesSize tys = foldr ((+) . typeSize) 0 tys + coercionSize :: Coercion -> Int coercionSize (Refl ty) = typeSize ty coercionSize (GRefl _ ty MRefl) = typeSize ty 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 @@ -1922,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,11 +3,13 @@ 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 +data FunSel data CoSel data UnivCoProvenance data TyLit 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,22 +376,15 @@ = 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; -- those variables should be in scope already extendTvSubstWithClone (Subst in_scope idenv tenv cenv) tv tv' = Subst (extendInScopeSet in_scope tv') - idenv - (extendVarEnv tenv tv (mkTyVarTy tv')) - cenv + idenv + (extendVarEnv tenv tv (mkTyVarTy tv')) + cenv -- | Add a substitution from a 'CoVar' to a 'Coercion' to the 'Subst': -- you must ensure that the in-scope set satisfies @@ -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 #-} @@ -20,12 +19,14 @@ PromDataConInfo(..), TyConFlavour(..), -- * TyConBinder - TyConBinder, TyConBndrVis(..), TyConPiTyBinder, + TyConBinder, TyConBndrVis(..), mkNamedTyConBinder, mkNamedTyConBinders, mkRequiredTyConBinder, - mkAnonTyConBinder, mkAnonTyConBinders, mkInvisAnonTyConBinder, + mkAnonTyConBinder, mkAnonTyConBinders, tyConBinderForAllTyFlag, tyConBndrVisForAllTyFlag, isNamedTyConBinder, - isVisibleTyConBinder, isInvisibleTyConBinder, isVisibleTcbVis, + isVisibleTyConBinder, isInvisSpecTyConBinder, isInvisibleTyConBinder, + isInferredTyConBinder, + isVisibleTcbVis, isInvisSpecTcbVis, -- ** Field labels tyConFieldLabels, lookupTyConFieldLabel, @@ -45,8 +46,9 @@ noTcTyConScopedTyVars, -- ** Predicates on TyCons - isAlgTyCon, isVanillaAlgTyCon, - isClassTyCon, isFamInstTyCon, + isAlgTyCon, isVanillaAlgTyCon, isClassTyCon, + isUnaryClassTyCon, isUnaryClassTyCon_maybe, + isFamInstTyCon, isPrimTyCon, isTupleTyCon, isUnboxedTupleTyCon, isBoxedTupleTyCon, isUnboxedSumTyCon, isPromotedTupleTyCon, @@ -55,10 +57,10 @@ tyConMustBeSaturated, isPromotedDataCon, isPromotedDataCon_maybe, isDataKindsPromotedDataCon, - isKindTyCon, isLiftedTypeKindTyConName, + isKindTyCon, isKindName, isLiftedTypeKindTyConName, isTauTyCon, isFamFreeTyCon, isForgetfulSynTyCon, - isDataTyCon, + isBoxedDataTyCon, isTypeDataTyCon, isEnumerationTyCon, isNewTyCon, isAbstractTyCon, @@ -67,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, @@ -84,8 +87,6 @@ tyConCType_maybe, tyConDataCons, tyConDataCons_maybe, tyConSingleDataCon_maybe, tyConSingleDataCon, - tyConAlgDataCons_maybe, - tyConSingleAlgDataCon_maybe, tyConFamilySize, tyConStupidTheta, tyConArity, @@ -123,11 +124,12 @@ tyConRepModOcc, -- * Primitive representations of Types - PrimRep(..), PrimElemRep(..), + PrimRep(..), PrimElemRep(..), Levity(..), + PrimOrVoidRep(..), primElemRepToPrimRep, - isVoidRep, isGcPtrRep, - primRepSizeB, - primElemRepSizeB, + isGcPtrRep, + primRepSizeB, primRepSizeW64_B, + primElemRepSizeB, primElemRepSizeW64_B, primRepIsFloat, primRepsCompatible, primRepCompatible, @@ -172,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(..)) @@ -194,7 +196,7 @@ * Type synonym families, also known as "type functions", map directly onto the type functions in FC: - type family F a :: * + type family F a :: Type type instance F Int = Bool ..etc... @@ -210,11 +212,11 @@ type instance F (F Int) = ... -- BAD! * Translation of type family decl: - type family F a :: * + type family F a :: Type translates to a FamilyTyCon 'F', whose FamTyConFlav is OpenSynFamilyTyCon - type family G a :: * where + type family G a :: Type where G Int = Bool G Bool = Char G a = () @@ -229,7 +231,7 @@ See also Note [Wrappers for data instance tycons] in GHC.Types.Id.Make * Data type families are declared thus - data family T a :: * + data family T a :: Type data instance T Int = T1 | T2 Bool Here T is the "family TyCon". @@ -321,7 +323,7 @@ should not think of a data family T as a *type function* at all, not even an injective one! We can't allow even injective type functions on the LHS of a type function: - type family injective G a :: * + type family injective G a :: Type type instance F (G Int) = Bool is no good, even if G is injective, because consider type instance G Int = Bool @@ -427,7 +429,7 @@ * [Injectivity annotation] in GHC.Hs.Decls * [Renaming injectivity annotation] in GHC.Rename.Module * [Verifying injectivity annotation] in GHC.Core.FamInstEnv - * [Type inference for type families with injectivity] in GHC.Tc.Solver.Interact + * [Type inference for type families with injectivity] in GHC.Tc.Solver.Equality Note [Sharing nullary TyConApps] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -445,38 +447,29 @@ ************************************************************************ * * - TyConBinder, TyConPiTyBinder + TyConBinder * * ************************************************************************ -} type TyConBinder = VarBndr TyVar TyConBndrVis -type TyConPiTyBinder = VarBndr TyCoVar TyConBndrVis - -- Only PromotedDataCon has TyConPiTyBinders - -- See Note [Promoted GADT data constructors] data TyConBndrVis - = NamedTCB ForAllTyFlag - | AnonTCB FunTyFlag + = NamedTCB ForAllTyFlag -- ^ A named, forall-bound variable (invisible or not) + | AnonTCB -- ^ an ordinary, visible type argument instance Outputable TyConBndrVis where ppr (NamedTCB flag) = ppr flag - ppr (AnonTCB af) = ppr af + ppr AnonTCB = text "AnonTCB" mkAnonTyConBinder :: TyVar -> TyConBinder -- Make a visible anonymous TyCon binder mkAnonTyConBinder tv = assert (isTyVar tv) $ - Bndr tv (AnonTCB visArgTypeLike) + Bndr tv AnonTCB mkAnonTyConBinders :: [TyVar] -> [TyConBinder] mkAnonTyConBinders tvs = map mkAnonTyConBinder tvs -mkInvisAnonTyConBinder :: TyVar -> TyConBinder --- Make an /invisible/ anonymous TyCon binder --- Not used much -mkInvisAnonTyConBinder tv = assert (isTyVar tv) $ - Bndr tv (AnonTCB invisArgTypeLike) - mkNamedTyConBinder :: ForAllTyFlag -> TyVar -> TyConBinder -- The odd argument order supports currying mkNamedTyConBinder vis tv = assert (isTyVar tv) $ @@ -495,14 +488,12 @@ | 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 -tyConBndrVisForAllTyFlag (NamedTCB vis) = vis -tyConBndrVisForAllTyFlag (AnonTCB af) -- See Note [AnonTCB with constraint arg] - | isVisibleFunArg af = Required - | otherwise = Inferred +tyConBndrVisForAllTyFlag (NamedTCB vis) = vis +tyConBndrVisForAllTyFlag AnonTCB = Required isNamedTyConBinder :: TyConBinder -> Bool -- Identifies kind variables @@ -517,12 +508,28 @@ isVisibleTcbVis :: TyConBndrVis -> Bool isVisibleTcbVis (NamedTCB vis) = isVisibleForAllTyFlag vis -isVisibleTcbVis (AnonTCB af) = isVisibleFunArg af +isVisibleTcbVis AnonTCB = True +isInvisSpecTcbVis :: TyConBndrVis -> Bool +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 @@ -530,7 +537,7 @@ where mk :: TyConBinder -> Kind -> Kind mk (Bndr tv (NamedTCB vis)) k = mkForAllTy (Bndr tv vis) k - mk (Bndr tv (AnonTCB af)) k = mkNakedFunTy af (varType tv) k + mk (Bndr tv AnonTCB) k = mkNakedFunTy FTF_T_T (varType tv) k -- mkNakedFunTy: see Note [Naked FunTy] in GHC.Builtin.Types -- | (mkTyConTy tc) returns (TyConApp tc []) @@ -549,9 +556,7 @@ mk_binder (Bndr tv tc_vis) = mkTyVarBinder vis tv where vis = case tc_vis of - AnonTCB af -- Note [AnonTCB with constraint arg] - | isInvisibleFunArg af -> InferredSpec - | otherwise -> SpecifiedSpec + AnonTCB -> SpecifiedSpec NamedTCB Required -> SpecifiedSpec NamedTCB (Invisible vis) -> vis @@ -561,35 +566,7 @@ = [ tv | Bndr tv vis <- tyConBinders tc , isVisibleTcbVis vis ] -{- Note [AnonTCB with constraint arg] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -It's pretty rare to have an (AnonTCB af) binder with af=FTF_C_T or FTF_C_C. -The only way it can occur is through equality constraints in kinds. These -can arise in one of two ways: - -* In a PromotedDataCon whose kind has an equality constraint: - - 'MkT :: forall a b. (a~b) => blah - - See Note [Constraints in kinds] in GHC.Core.TyCo.Rep, and - Note [Promoted data constructors] in this module. - -* In a data type whose kind has an equality constraint, as in the - following example from #12102: - - data T :: forall a. (IsTypeLit a ~ 'True) => a -> Type - -When mapping an (AnonTCB FTF_C_x) to an ForAllTyFlag, in -tyConBndrVisForAllTyFlag, we use "Inferred" to mean "the user cannot -specify this arguments, even with visible type/kind application; -instead the type checker must fill it in. - -We map (AnonTCB FTF_T_x) to Required, of course: the user must -provide it. It would be utterly wrong to do this for constraint -arguments, which is why AnonTCB must have the FunTyFlag in -the first place. - -Note [Building TyVarBinders from TyConBinders] +{- Note [Building TyVarBinders from TyConBinders] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We sometimes need to build the quantified type of a value from the TyConBinders of a type or class. For that we need not @@ -613,21 +590,21 @@ information right; and that info is in the TyConBinders. Here is an example: - data App a b = MkApp (a b) -- App :: forall {k}. (k->*) -> k -> * + data App a b = MkApp (a b) -- App :: forall {k}. (k->Type) -> k -> Type The TyCon has - tyConTyBinders = [ Named (Bndr (k :: *) Inferred), Anon (k->*), Anon k ] + tyConTyBinders = [ Named (Bndr (k :: Type) Inferred), Anon (k->Type), Anon k ] The TyConBinders for App line up with App's kind, given above. But the DataCon MkApp has the type - MkApp :: forall {k} (a:k->*) (b:k). a b -> App k a b + MkApp :: forall {k} (a:k->Type) (b:k). a b -> App k a b That is, its ForAllTyBinders should be - dataConUnivTyVarBinders = [ Bndr (k:*) Inferred - , Bndr (a:k->*) Specified + dataConUnivTyVarBinders = [ Bndr (k:Type) Inferred + , Bndr (a:k->Type) Specified , Bndr (b:k) Specified ] So tyConTyVarBinders converts TyCon's TyConBinders into TyVarBinders: @@ -635,17 +612,18 @@ - 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. -} {- Note [The binders/kind/arity fields of a TyCon] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ All TyCons have this group of fields - tyConBinders :: [TyConBinder/TyConPiTyBinder] + tyConBinders :: [TyConBinder] tyConResKind :: Kind tyConTyVars :: [TyVar] -- Cached = binderVars tyConBinders -- NB: Currently (Aug 2018), TyCons that own this @@ -656,13 +634,13 @@ They fit together like so: -* tyConBinders gives the telescope of type/coercion variables on the LHS of the +* tyConBinders gives the telescope of type variables on the LHS of the type declaration. For example: type App a (b :: k) = a b - tyConBinders = [ Bndr (k::*) (NamedTCB Inferred) - , Bndr (a:k->*) AnonTCB + tyConBinders = [ Bndr (k::Type) (NamedTCB Inferred) + , Bndr (a:k->Type) AnonTCB , Bndr (b:k) AnonTCB ] Note that there are three binders here, including the @@ -673,17 +651,17 @@ * See Note [VarBndrs, ForAllTyBinders, TyConBinders, and visibility] in GHC.Core.TyCo.Rep for what the visibility flag means. -* Each TyConBinder tyConBinders has a TyVar (sometimes it is TyCoVar), and +* Each TyConBinder in tyConBinders has a TyVar, and that TyVar may scope over some other part of the TyCon's definition. Eg type T a = a -> a we have - tyConBinders = [ Bndr (a:*) AnonTCB ] + tyConBinders = [ Bndr (a:Type) AnonTCB ] synTcRhs = a -> a So the 'a' scopes over the synTcRhs * From the tyConBinders and tyConResKind we can get the tyConKind E.g for our App example: - App :: forall k. (k->*) -> k -> * + App :: forall k. (k->Type) -> k -> Type We get a 'forall' in the kind for each NamedTCB, and an arrow for each AnonTCB @@ -745,15 +723,20 @@ ppr (Bndr v bi) = ppr bi <+> parens (pprBndr LetBind v) instance Binary TyConBndrVis where - put_ bh (AnonTCB af) = do { putByte bh 0; put_ bh af } + put_ bh AnonTCB = do { putByte bh 0 } put_ bh (NamedTCB vis) = do { putByte bh 1; put_ bh vis } get bh = do { h <- getByte bh ; case h of - 0 -> do { af <- get bh; return (AnonTCB af) } + 0 -> return AnonTCB _ -> do { vis <- get bh; return (NamedTCB vis) } } +instance NFData TyConBndrVis where + rnf AnonTCB = () + rnf (NamedTCB vis) = rnf vis + + {- ********************************************************************* * * The TyCon type @@ -766,15 +749,15 @@ -- things such as: -- -- 1) Data declarations: @data Foo = ...@ creates the @Foo@ type constructor of --- kind @*@ +-- kind @Type@ -- -- 2) Type synonyms: @type Foo = ...@ creates the @Foo@ type constructor -- -- 3) Newtypes: @newtype Foo a = MkFoo ...@ creates the @Foo@ type constructor --- of kind @* -> *@ +-- of kind @Type -> Type@ -- -- 4) Class declarations: @class Foo where@ creates the @Foo@ type constructor --- of kind @*@ +-- of kind @Constraint@ -- -- This data type also encodes a number of primitive, built in type constructors -- such as those for function and tuple types. @@ -874,11 +857,18 @@ -- any type synonym families (data families -- 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 - -- forgetfulness. + -- forgetfulness. False conveys definite information + -- (definitely not forgetful); True is always safe. + + synIsConcrete :: Bool -- True <= If 'tys' are concrete then the expansion + -- of (S tys) is definitely concrete + -- But False is always safe } -- | Represents families (both type and data) @@ -915,14 +905,17 @@ } -- | Represents promoted data constructor. + -- The kind of a promoted data constructor is the *wrapper* type of + -- the original data constructor. This type must not have constraints + -- (as checked in GHC.Tc.Gen.HsType.tcTyVar). | PromotedDataCon { -- See Note [Promoted data constructors] dataCon :: DataCon, -- ^ Corresponding data constructor tcRepName :: TyConRepName, promDcInfo :: PromDataConInfo -- ^ See comments with 'PromDataConInfo' } - -- | These exist only during type-checking. See Note [How TcTyCons work] - -- in "GHC.Tc.TyCl" + -- | These exist only during type-checking. + -- See Note [TcTyCon, MonoTcTyCon, and PolyTcTyCon] in "GHC.Tc.TyCl" | TcTyCon { -- NB: the tyConArity of a TcTyCon must match -- the number of Required (positional, user-specified) @@ -937,7 +930,7 @@ tctc_is_poly :: Bool, -- ^ Is this TcTyCon already generalized? -- Used only to make zonking more efficient - tctc_flavour :: TyConFlavour + tctc_flavour :: TyConFlavour TyCon -- ^ What sort of 'TyCon' this represents. } @@ -956,18 +949,7 @@ * tyConArity = length required_tvs tcTyConScopedTyVars are used only for MonoTcTyCons, not PolyTcTyCons. -See Note [TcTyCon, MonoTcTyCon, and PolyTcTyCon] in GHC.Tc.Utils.TcType. - -Note [Promoted GADT data constructors] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Any promoted GADT data constructor will have a type with equality -constraints in its type; e.g. - K :: forall a b. (a ~# [b]) => a -> b -> T a - -So, when promoted to become a type constructor, the tyConBinders -will include CoVars. That is why we use [TyConPiTyBinder] for the -tyconBinders field. TyConPiTyBinder is a synonym for TyConBinder, -but with the clue that the binder can be a CoVar not just a TyVar. +See Note [TcTyCon, MonoTcTyCon, and PolyTcTyCon] in GHC.Tc.TyCl Note [Representation-polymorphic TyCons] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1149,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) @@ -1204,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 @@ -1226,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 @@ -1301,16 +1291,16 @@ -- -- These are introduced by either a top level declaration: -- - -- > data family T a :: * + -- > data family T a :: Type -- -- Or an associated data type declaration, within a class declaration: -- -- > class C a b where - -- > data T b :: * + -- > data T b :: Type DataFamilyTyCon TyConRepName - -- | An open type synonym family e.g. @type family F x y :: * -> *@ + -- | An open type synonym family e.g. @type family F x y :: Type -> Type@ | OpenSynFamilyTyCon -- | A closed type synonym family e.g. @@ -1374,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 @@ -1444,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 @@ -1568,14 +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 - | LiftedRep - | UnliftedRep -- ^ Unlifted pointer +-- 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 @@ -1586,12 +1766,16 @@ | Word32Rep -- ^ Unsigned, 32 bit value | Word64Rep -- ^ Unsigned, 64 bit value | WordRep -- ^ Unsigned, word-sized value - | AddrRep -- ^ A pointer, but /not/ to a Haskell value (use '(Un)liftedRep') + | AddrRep -- ^ A pointer, but /not/ to a Haskell value (use 'BoxedRep') | FloatRep | DoubleRep | 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 @@ -1612,9 +1796,12 @@ ppr r = text (show r) instance Binary PrimRep where - put_ bh VoidRep = putByte bh 0 - put_ bh LiftedRep = putByte bh 1 - put_ bh UnliftedRep = putByte bh 2 + put_ bh (BoxedRep ml) = case ml of + -- cheaper storage of the levity than using + -- the Binary (Maybe Levity) instance + 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 @@ -1632,9 +1819,9 @@ get bh = do h <- getByte bh case h of - 0 -> pure VoidRep - 1 -> pure LiftedRep - 2 -> pure UnliftedRep + 0 -> pure $ BoxedRep Nothing + 1 -> pure $ BoxedRep (Just Lifted) + 2 -> pure $ BoxedRep (Just Unlifted) 3 -> pure Int8Rep 4 -> pure Int16Rep 5 -> pure Int32Rep @@ -1655,14 +1842,9 @@ 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 LiftedRep = True -isGcPtrRep UnliftedRep = True -isGcPtrRep _ = False +isGcPtrRep (BoxedRep _) = True +isGcPtrRep _ = False -- A PrimRep is compatible with another iff one can be coerced to the other. -- See Note [Bad unsafe coercion] in GHC.Core.Lint for when are two types coercible. @@ -1703,14 +1885,41 @@ FloatRep -> fLOAT_SIZE DoubleRep -> dOUBLE_SIZE AddrRep -> platformWordSizeInBytes platform - LiftedRep -> platformWordSizeInBytes platform - UnliftedRep -> platformWordSizeInBytes platform - VoidRep -> 0 + BoxedRep _ -> platformWordSizeInBytes platform (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 @@ -1886,15 +2095,13 @@ -- right-hand side. It lives only during the type-checking of a -- mutually-recursive group of tycons; it is then zonked to a proper -- TyCon in zonkTcTyCon. --- See also Note [Kind checking recursive type and class declarations] --- in "GHC.Tc.TyCl". +-- See Note [TcTyCon, MonoTcTyCon, and PolyTcTyCon] in "GHC.Tc.TyCl" mkTcTyCon :: Name -> [TyConBinder] -> Kind -- ^ /result/ kind only -> [(Name,TcTyVar)] -- ^ Scoped type variables; - -- see Note [How TcTyCons work] in GHC.Tc.TyCl -> Bool -- ^ Is this TcTyCon generalised already? - -> TyConFlavour -- ^ What sort of 'TyCon' this represents + -> TyConFlavour TyCon -- ^ What sort of 'TyCon' this represents -> TyCon mkTcTyCon name binders res_kind scoped_tvs poly flav = mkTyCon name binders res_kind (constRoles binders Nominal) $ @@ -1906,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] @@ -1922,13 +2129,17 @@ -- | Create a type synonym 'TyCon' mkSynonymTyCon :: Name -> [TyConBinder] -> Kind -- ^ /result/ kind - -> [Role] -> Type -> Bool -> Bool -> Bool -> TyCon -mkSynonymTyCon name binders res_kind roles rhs is_tau is_fam_free is_forgetful + -> [Role] -> Type + -> Bool -> Bool -> Bool -> Bool + -> TyCon +mkSynonymTyCon name binders res_kind roles rhs is_tau + is_fam_free is_forgetful is_concrete = mkTyCon name binders res_kind roles $ SynonymTyCon { synTcRhs = rhs , synIsTau = is_tau , synIsFamFree = is_fam_free - , synIsForgetful = is_forgetful } + , synIsForgetful = is_forgetful + , synIsConcrete = is_concrete } -- | Create a type family 'TyCon' mkFamilyTyCon :: Name -> [TyConBinder] -> Kind -- ^ /result/ kind @@ -1946,7 +2157,7 @@ -- as the data constructor itself; when we pretty-print -- the TyCon we add a quote; see the Outputable TyCon instance mkPromotedDataCon :: DataCon -> Name -> TyConRepName - -> [TyConPiTyBinder] -> Kind -> [Role] + -> [TyConBinder] -> Kind -> [Role] -> PromDataConInfo -> TyCon mkPromotedDataCon con name rep_name binders res_kind roles rep_info = mkTyCon name binders res_kind roles $ @@ -1980,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 } @@ -2003,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. @@ -2018,32 +2241,46 @@ -- (where r is the role passed in): -- If (T a1 b1 c1) ~r (T a2 b2 c2), then (a1 ~r1 a2), (b1 ~r2 b2), and (c1 ~r3 c2) -- (where r1, r2, and r3, are the roles given by tyConRolesX tc r) --- See also Note [Decomposing TyConApp equalities] in "GHC.Tc.Solver.Canonical" +-- 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 Note [How TcTyCons work] item (1) 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): -- If (T tys ~r t), then (t's head ~r T). --- See also Note [Decomposing TyConApp equalities] in "GHC.Tc.Solver.Canonical" +-- See also Note [Decomposing TyConApp equalities] in "GHC.Tc.Solver.Equality" +-- +-- NB: at Nominal role, isGenerativeTyCon is simple: +-- isGenerativeTyCon tc Nominal +-- = not (isTypeFamilyTyCon tc || isSynonymTyCon tc) isGenerativeTyCon :: TyCon -> Role -> Bool isGenerativeTyCon tc@(TyCon { tyConDetails = details }) role = go role details @@ -2054,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 }) @@ -2111,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. @@ -2145,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? @@ -2167,13 +2429,13 @@ _ -> False | otherwise = False --- | Is this a synonym 'TyCon' that can have may have further instances appear? +-- | Is this a type family 'TyCon' (whether open or closed)? isTypeFamilyTyCon :: TyCon -> Bool isTypeFamilyTyCon (TyCon { tyConDetails = details }) | FamilyTyCon { famTcFlav = flav } <- details = not (isDataFamFlav flav) | otherwise = False --- | Is this a synonym 'TyCon' that can have may have further instances appear? +-- | Is this a data family 'TyCon'? isDataFamilyTyCon :: TyCon -> Bool isDataFamilyTyCon (TyCon { tyConDetails = details }) | FamilyTyCon { famTcFlav = flav } <- details = isDataFamFlav flav @@ -2194,14 +2456,14 @@ isBuiltInSynFamTyCon_maybe :: TyCon -> Maybe BuiltInSynFamily isBuiltInSynFamTyCon_maybe (TyCon { tyConDetails = details }) - | FamilyTyCon {famTcFlav = BuiltInSynFamTyCon ops } <- details = Just ops - | otherwise = Nothing + | FamilyTyCon {famTcFlav = BuiltInSynFamTyCon ops} <- details = Just ops + | otherwise = Nothing -- | Extract type variable naming the result of injective type family tyConFamilyResVar_maybe :: TyCon -> Maybe Name tyConFamilyResVar_maybe (TyCon { tyConDetails = details }) | FamilyTyCon {famTcResVar = res} <- details = res - | otherwise = Nothing + | otherwise = Nothing -- | @'tyConInjectivityInfo' tc@ returns @'Injective' is@ if @tc@ is an -- injective tycon (where @is@ states for which 'tyConBinders' @tc@ is @@ -2227,12 +2489,6 @@ tyConAssoc_maybe :: TyCon -> Maybe TyCon tyConAssoc_maybe = tyConFlavourAssoc_maybe . tyConFlavour --- | Get the enclosing class TyCon (if there is one) for the given TyConFlavour -tyConFlavourAssoc_maybe :: TyConFlavour -> Maybe TyCon -tyConFlavourAssoc_maybe (DataFamilyFlavour mb_parent) = mb_parent -tyConFlavourAssoc_maybe (OpenTypeFamilyFlavour mb_parent) = mb_parent -tyConFlavourAssoc_maybe _ = Nothing - -- The unit tycon didn't used to be classed as a tuple tycon -- but I thought that was silly so I've undone it -- If it can't be for some reason, it should be a AlgTyCon @@ -2315,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) @@ -2389,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) @@ -2403,30 +2679,24 @@ | TcTyCon{} <- details = False | PromotedDataCon{} <- details = pprPanic "tcHasFixedRuntimeRep datacon" (ppr tc) --- | Is this 'TyCon' concrete (i.e. not a synonym/type family)? --- +-- | Is this 'TyCon' concrete? +-- More specifically, if 'tys' are all concrete, is (T tys) concrete? +-- (for synonyms this requires us to look at the RHS) -- Used for representation polymorphism checks. +-- See Note [Concrete types] in GHC.Tc.Utils.Concrete isConcreteTyCon :: TyCon -> Bool -isConcreteTyCon = isConcreteTyConFlavour . tyConFlavour +isConcreteTyCon tc@(TyCon { tyConDetails = details }) + = case details of + AlgTyCon {} -> True -- Includes AbstractTyCon + PrimTyCon {} -> True + PromotedDataCon {} -> True + FamilyTyCon {} -> False --- | Is this 'TyConFlavour' concrete (i.e. not a synonym/type family)? --- --- Used for representation polymorphism checks. -isConcreteTyConFlavour :: TyConFlavour -> Bool -isConcreteTyConFlavour = \case - ClassFlavour -> True - TupleFlavour {} -> True - SumFlavour -> True - DataTypeFlavour -> True - NewtypeFlavour -> True - AbstractTypeFlavour -> True -- See Note [Concrete types] in GHC.Tc.Utils.Concrete - DataFamilyFlavour {} -> False - OpenTypeFamilyFlavour {} -> False - ClosedTypeFamilyFlavour -> False - TypeSynonymFlavour -> False - BuiltInTypeFlavour -> True - PromotedDataConFlavour -> True + SynonymTyCon { synIsConcrete = is_conc } -> is_conc + TcTyCon {} -> pprPanic "isConcreteTyCon" (ppr tc) + -- isConcreteTyCon is only used on "real" tycons + {- ----------------------------------------------- -- TcTyCon @@ -2530,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@ @@ -2545,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 @@ -2558,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 @@ -2583,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) @@ -2646,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 @@ -2671,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 }) @@ -2774,43 +3047,7 @@ then text "[tc]" else empty --- | Paints a picture of what a 'TyCon' represents, in broad strokes. --- This is used towards more informative error messages. -data TyConFlavour - = ClassFlavour - | TupleFlavour Boxity - | SumFlavour - | DataTypeFlavour - | NewtypeFlavour - | AbstractTypeFlavour - | DataFamilyFlavour (Maybe TyCon) -- Just tc <=> (tc == associated class) - | OpenTypeFamilyFlavour (Maybe TyCon) -- Just tc <=> (tc == associated class) - | ClosedTypeFamilyFlavour - | TypeSynonymFlavour - | BuiltInTypeFlavour -- ^ e.g., the @(->)@ 'TyCon'. - | PromotedDataConFlavour - deriving Eq - -instance Outputable TyConFlavour where - ppr = text . go - where - go ClassFlavour = "class" - go (TupleFlavour boxed) | isBoxed boxed = "tuple" - | otherwise = "unboxed tuple" - go SumFlavour = "unboxed sum" - go DataTypeFlavour = "data type" - go NewtypeFlavour = "newtype" - go AbstractTypeFlavour = "abstract type" - go (DataFamilyFlavour (Just _)) = "associated data family" - go (DataFamilyFlavour Nothing) = "data family" - go (OpenTypeFamilyFlavour (Just _)) = "associated type family" - go (OpenTypeFamilyFlavour Nothing) = "type family" - go ClosedTypeFamilyFlavour = "type family" - go TypeSynonymFlavour = "type synonym" - go BuiltInTypeFlavour = "built-in type" - go PromotedDataConFlavour = "promoted data constructor" - -tyConFlavour :: TyCon -> TyConFlavour +tyConFlavour :: TyCon -> TyConFlavour TyCon tyConFlavour (TyCon { tyConDetails = details }) | AlgTyCon { algTcFlavour = parent, algTcRhs = rhs } <- details = case parent of @@ -2821,12 +3058,13 @@ SumTyCon {} -> SumFlavour DataTyCon {} -> DataTypeFlavour NewTyCon {} -> NewtypeFlavour + UnaryClassTyCon {} -> ClassFlavour AbstractTyCon {} -> AbstractTypeFlavour | FamilyTyCon { famTcFlav = flav, famTcParent = parent } <- details = case flav of - DataFamilyTyCon{} -> DataFamilyFlavour parent - OpenSynFamilyTyCon -> OpenTypeFamilyFlavour parent + DataFamilyTyCon{} -> OpenFamilyFlavour (IAmData DataType) parent + OpenSynFamilyTyCon -> OpenFamilyFlavour IAmType parent ClosedSynFamilyTyCon{} -> ClosedTypeFamilyFlavour AbstractClosedSynFamilyTyCon -> ClosedTypeFamilyFlavour BuiltInSynFamTyCon{} -> ClosedTypeFamilyFlavour @@ -2837,24 +3075,22 @@ | TcTyCon { tctc_flavour = flav } <-details = flav -- | Can this flavour of 'TyCon' appear unsaturated? -tcFlavourMustBeSaturated :: TyConFlavour -> Bool +tcFlavourMustBeSaturated :: TyConFlavour tc -> Bool tcFlavourMustBeSaturated ClassFlavour = False tcFlavourMustBeSaturated DataTypeFlavour = False tcFlavourMustBeSaturated NewtypeFlavour = False -tcFlavourMustBeSaturated DataFamilyFlavour{} = False tcFlavourMustBeSaturated TupleFlavour{} = False tcFlavourMustBeSaturated SumFlavour = False tcFlavourMustBeSaturated AbstractTypeFlavour {} = False tcFlavourMustBeSaturated BuiltInTypeFlavour = False tcFlavourMustBeSaturated PromotedDataConFlavour = False +tcFlavourMustBeSaturated (OpenFamilyFlavour td _)= case td of { IAmData {} -> False; IAmType -> True } tcFlavourMustBeSaturated TypeSynonymFlavour = True -tcFlavourMustBeSaturated OpenTypeFamilyFlavour{} = True tcFlavourMustBeSaturated ClosedTypeFamilyFlavour = True -- | Is this flavour of 'TyCon' an open type family or a data family? -tcFlavourIsOpen :: TyConFlavour -> Bool -tcFlavourIsOpen DataFamilyFlavour{} = True -tcFlavourIsOpen OpenTypeFamilyFlavour{} = True +tcFlavourIsOpen :: TyConFlavour tc -> Bool +tcFlavourIsOpen OpenFamilyFlavour{} = True tcFlavourIsOpen ClosedTypeFamilyFlavour = False tcFlavourIsOpen ClassFlavour = False tcFlavourIsOpen DataTypeFlavour = False @@ -2896,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 @@ -100,10 +100,10 @@ delFromTyConEnv x y = delFromUFM x y delListFromTyConEnv x y = delListFromUFM x y filterTyConEnv x y = filterUFM x y -anyTyConEnv f x = foldUFM ((||) . f) False x +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 @@ -3,7 +3,7 @@ -- -- Type - public interface -{-# LANGUAGE FlexibleContexts, PatternSynonyms, ViewPatterns, MultiWayIf #-} +{-# LANGUAGE FlexibleContexts, PatternSynonyms, ViewPatterns, MultiWayIf, RankNTypes #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -- | Main functions for manipulating types and type-related things @@ -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,20 +69,18 @@ mkCharLitTy, isCharLitTy, isLitTy, - isPredTy, - getRuntimeRep, splitRuntimeRep_maybe, kindRep_maybe, kindRep, getLevity, levityType_maybe, mkCastTy, mkCoercionTy, splitCastTy_maybe, - userTypeError_maybe, pprUserTypeErrorTy, + ErrorMsgType, + userTypeError_maybe, deepUserTypeError_maybe, pprUserTypeErrorTy, coAxNthLHS, stripCoercionTy, - splitInvisPiTys, splitInvisPiTysN, - invisibleTyBndrCount, + splitInvisPiTys, splitInvisPiTysN, invisibleBndrCount, filterOutInvisibleTypes, filterOutInferredTypes, partitionInvisibleTypes, partitionInvisibles, tyConForAllTyFlags, appTyForAllTyFlags, @@ -110,8 +108,9 @@ isTyVarTy, isFunTy, isCoercionTy, isCoercionTy_maybe, isForAllTy, isForAllTy_ty, isForAllTy_co, + isForAllTy_invis_ty, isPiTy, isTauTy, isFamFreeTy, - isCoVarType, isAtomicTy, + isAtomicTy, isValidJoinPointType, tyConAppNeedsKindSig, @@ -120,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, @@ -132,8 +131,9 @@ isUnliftedType, isBoxedType, isUnboxedTupleType, isUnboxedSumType, kindBoxedRepLevity_maybe, mightBeLiftedType, mightBeUnliftedType, - isAlgType, isDataFamilyAppType, - isPrimitiveType, isStrictType, + definitelyLiftedType, definitelyUnliftedType, + isAlgType, isDataFamilyApp, isSatTyFamApp, + isPrimitiveType, isStrictType, isTerminatingType, isLevityTy, isLevityVar, isRuntimeRepTy, isRuntimeRepVar, isRuntimeRepKindedTy, dropRuntimeRepArgs, @@ -151,7 +151,7 @@ Kind, -- ** Finding the kind of a type - typeKind, typeHasFixedRuntimeRep, argsHaveFixedRuntimeRep, + typeKind, typeHasFixedRuntimeRep, tcIsLiftedTypeKind, isConstraintKind, isConstraintLikeKind, returnsConstraintKind, tcIsBoxedTypeKind, isTypeLikeKind, @@ -168,22 +168,18 @@ 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, -- * Other views onto Types - coreView, + coreView, coreFullView, rewriterView, tyConsOfType, @@ -195,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, @@ -221,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, - isConcrete, isFixedRuntimeRepKind, + isConcreteType, + isFixedRuntimeRepKind ) where import GHC.Prelude @@ -244,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 @@ -270,9 +255,9 @@ 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, mkFunCo1 + , mkKindCo, mkSubCo, mkFunCo, funRole , decomposePiCos, coercionKind , coercionRKind, coercionType , isReflexiveCo, seqCo @@ -285,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# @@ -360,6 +344,19 @@ ************************************************************************ -} +rewriterView :: Type -> Maybe Type +-- Unwrap a type synonym only when either: +-- The type synonym is forgetful, or +-- the type synonym mentions a type family in its expansion +-- See Note [Rewriting synonyms] +{-# INLINE rewriterView #-} +rewriterView (TyConApp tc tys) + | isTypeSynonymTyCon tc + , isForgetfulSynTyCon tc || not (isFamFreeTyCon tc) + = expandSynTyConApp_maybe tc tys +rewriterView _other + = Nothing + coreView :: Type -> Maybe Type -- ^ This function strips off the /top layer only/ of a type synonym -- application (if any) its underlying representation type. @@ -401,7 +398,11 @@ expandSynTyConApp_maybe tc arg_tys | Just (tvs, rhs) <- synTyConDefn_maybe tc , arg_tys `saturates` tyConArity tc - = Just (expand_syn tvs rhs arg_tys) + = Just $! (expand_syn tvs rhs arg_tys) + -- Why strict application? Because every client of this function will evaluat + -- that (expand_syn ...) thunk, so it's more efficient not to build a thunk. + -- Mind you, this function is always INLINEd, so the client context is probably + -- enough to avoid thunk construction and so the $! is just belt-and-braces. | otherwise = Nothing @@ -410,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. @@ -529,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) @@ -554,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 ~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -686,8 +677,8 @@ -- * False of type variables, type family applications, -- and of other reps such as @IntRep :: RuntimeRep@. isLiftedRuntimeRep :: RuntimeRepType -> Bool -isLiftedRuntimeRep rep = - runtimeRepLevity_maybe rep == Just Lifted +isLiftedRuntimeRep rep + = runtimeRepLevity_maybe rep == Just Lifted -- | Check whether a type of kind 'RuntimeRep' is unlifted. -- @@ -770,7 +761,7 @@ -- expands to `Boxed lev` and returns `Nothing` otherwise. -- -- Types with this runtime rep are represented by pointers on the GC'd heap. -isBoxedRuntimeRep_maybe :: RuntimeRepType -> Maybe Type +isBoxedRuntimeRep_maybe :: RuntimeRepType -> Maybe LevityType isBoxedRuntimeRep_maybe rep | Just (rr_tc, args) <- splitRuntimeRep_maybe rep , rr_tc `hasKey` boxedRepDataConKey @@ -779,9 +770,10 @@ | otherwise = Nothing --- | Check whether a type of kind 'RuntimeRep' is lifted, unlifted, or unknown. +-- | Check whether a type (usually of kind 'RuntimeRep') is lifted, unlifted, +-- or unknown. Returns Nothing if the type isn't of kind 'RuntimeRep'. -- --- `isLiftedRuntimeRep rr` returns: +-- `runtimeRepLevity_maybe rr` returns: -- -- * `Just Lifted` if `rr` is `LiftedRep :: RuntimeRep` -- * `Just Unlifted` if `rr` is definitely unlifted, e.g. `IntRep` @@ -793,7 +785,9 @@ if (rr_tc `hasKey` boxedRepDataConKey) then case args of [lev] -> levityType_maybe lev - _ -> pprPanic "runtimeRepLevity_maybe" (ppr rep) + _ -> Nothing -- Type isn't of kind RuntimeRep + -- The latter case happens via the call to isLiftedRuntimeRep + -- 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 @@ -804,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 @@ -827,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. @@ -867,7 +861,8 @@ -- ^ What to do with coercion holes. -- See Note [Coercion holes] in "GHC.Core.TyCo.Rep". - , tcm_tycobinder :: env -> TyCoVar -> ForAllTyFlag -> m (env, TyCoVar) + , tcm_tycobinder :: forall r. env -> TyCoVar -> ForAllTyFlag + -> (env -> TyCoVar -> m r) -> m r -- ^ The returned env is used in the extended scope , tcm_tycon :: TyCon -> m TyCon @@ -880,21 +875,22 @@ {-# INLINE mapTyCo #-} -- See Note [Specialising mappers] mapTyCo :: Monad m => TyCoMapper () m - -> ( Type -> m Type - , [Type] -> m [Type] - , Coercion -> m Coercion - , [Coercion] -> m[Coercion]) + -> ( Type -> m Type + , [Type] -> m [Type] + , Coercion -> m Coercion + , [Coercion] -> m [Coercion] ) mapTyCo mapper = case mapTyCoX mapper of (go_ty, go_tys, go_co, go_cos) -> (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 - , env -> [Coercion] -> m[Coercion]) + , env -> [Coercion] -> m [Coercion] ) mapTyCoX (TyCoMapper { tcm_tyvar = tyvar , tcm_tycobinder = tycobinder , tcm_tycon = tycon @@ -902,20 +898,21 @@ , tcm_hole = cohole }) = (go_ty, go_tys, go_co, go_cos) where - go_tys _ [] = return [] - go_tys env (ty:tys) = (:) <$> go_ty env ty <*> go_tys env tys + -- See Note [Use explicit recursion in mapTyCo] + go_tys !_ [] = return [] + go_tys !env (ty:tys) = (:) <$> go_ty env ty <*> go_tys env tys - go_ty env (TyVarTy tv) = tyvar env tv - go_ty env (AppTy t1 t2) = mkAppTy <$> go_ty env t1 <*> go_ty env t2 - go_ty _ ty@(LitTy {}) = return ty - go_ty env (CastTy ty co) = mkCastTy <$> go_ty env ty <*> go_co env co - go_ty env (CoercionTy co) = CoercionTy <$> go_co env co + go_ty !env (TyVarTy tv) = tyvar env tv + go_ty !env (AppTy t1 t2) = mkAppTy <$> go_ty env t1 <*> go_ty env t2 + go_ty !_ ty@(LitTy {}) = return ty + go_ty !env (CastTy ty co) = mkCastTy <$> go_ty env ty <*> go_co env co + go_ty !env (CoercionTy co) = CoercionTy <$> go_co env co - go_ty env ty@(FunTy _ w arg res) + go_ty !env ty@(FunTy _ w arg res) = do { w' <- go_ty env w; arg' <- go_ty env arg; res' <- go_ty env res ; return (ty { ft_mult = w', ft_arg = arg', ft_res = res' }) } - go_ty env ty@(TyConApp tc tys) + go_ty !env ty@(TyConApp tc tys) | isTcTyCon tc = do { tc' <- tycon tc ; mkTyConApp tc' <$> go_tys env tys } @@ -927,36 +924,41 @@ | otherwise = mkTyConApp tc <$> go_tys env tys - go_ty env (ForAllTy (Bndr tv vis) inner) - = do { (env', tv') <- tycobinder env tv vis + go_ty !env (ForAllTy (Bndr tv vis) inner) + = do { tycobinder env tv vis $ \env' tv' -> do ; inner' <- go_ty env' inner ; return $ ForAllTy (Bndr tv' vis) inner' } - go_cos _ [] = return [] - go_cos env (co:cos) = (:) <$> go_co env co <*> go_cos env cos + -- 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_mco !_ MRefl = return MRefl + go_mco !env (MCo co) = MCo <$> (go_co env co) - 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 - go_co env (FunCo r afl afr cw c1 c2) = mkFunCo2 r afl afr <$> go_co env cw + 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 + go_co !env (FunCo r afl afr cw c1 c2) = mkFunCo2 r afl afr <$> go_co env cw <*> 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 (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 (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) + go_co !env (CoVarCo cv) = covar env cv + go_co !env (HoleCo hole) = cohole env hole + 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 (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 co@(TyConAppCo r tc cos) | isTcTyCon tc = do { tc' <- tycon tc ; mkTyConAppCo r tc' <$> go_cos env cos } @@ -967,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 - ; (env', tv') <- tycobinder env tv Inferred + ; 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 @@ -1028,7 +1040,7 @@ Note [Decomposing fat arrow c=>t] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Can we unify (a b) with (Eq a => ty)? If we do so, we end up with -a partial application like ((=>) Eq a) which doesn't make sense in +a partial application like ((=>) (Eq a)) which doesn't make sense in source Haskell. In contrast, we *can* unify (a b) with (t1 -> t2). Here's an example (#9858) of how you might do it: i :: (Typeable a, Typeable b) => Proxy (a b) -> TypeRep @@ -1039,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@ @@ -1127,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. @@ -1208,19 +1219,50 @@ | LitTy l <- coreFullView ty = Just l | otherwise = Nothing +-- | A type of kind 'ErrorMessage' (from the 'GHC.TypeError' module). +type ErrorMsgType = Type + -- | Is this type a custom user error? --- If so, give us the kind and the error message. -userTypeError_maybe :: Type -> Maybe Type -userTypeError_maybe t - = do { (tc, _kind : msg : _) <- splitTyConApp_maybe t +-- If so, give us the error message. +userTypeError_maybe :: Type -> Maybe ErrorMsgType +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 :: Type -> SDoc +pprUserTypeErrorTy :: ErrorMsgType -> SDoc pprUserTypeErrorTy ty = case splitTyConApp_maybe ty of @@ -1246,7 +1288,6 @@ -- An unevaluated type function _ -> ppr ty - {- ********************************************************************* * * FunTy @@ -1290,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) @@ -1307,9 +1350,12 @@ -> Maybe Coercion -- ^ Return Just if this TyConAppCo should be represented as a FunCo tyConAppFunCo_maybe r tc cos - | Just (af, mult, arg, res) <- ty_con_app_fun_maybe (mkReflCo r manyDataConTy) tc cos - = Just (mkFunCo1 r af mult arg res) - | otherwise = Nothing + | Just (af, mult, arg, res) <- ty_con_app_fun_maybe mult_refl tc cos + = Just (mkFunCo r af mult arg res) + | otherwise + = Nothing + where + mult_refl = mkReflCo (funRole r SelMult) manyDataConTy ty_con_app_fun_maybe :: (HasDebugCallStack, Outputable a) => a -> TyCon -> [a] -> Maybe (FunTyFlag, a, a, a) @@ -1376,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 @@ -1390,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 @@ -1444,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 @@ -1558,7 +1614,7 @@ Just (_, tys) -> Just tys Nothing -> Nothing -tyConAppArgs :: HasCallStack => Type -> [Type] +tyConAppArgs :: HasDebugCallStack => Type -> [Type] tyConAppArgs ty = tyConAppArgs_maybe ty `orElse` pprPanic "tyConAppArgs" (ppr ty) -- | Attempts to tease a type apart into a type constructor and the application @@ -1572,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 @@ -1591,14 +1647,14 @@ -- 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: --- see Note [Decomposing FunTy] in GHC.Tc.Solver.Canonical +-- 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 -- -- Consequently, you may need to zonk your type before -- using this function. -tcSplitTyConApp_maybe :: HasCallStack => Type -> Maybe (TyCon, [Type]) +tcSplitTyConApp_maybe :: HasDebugCallStack => Type -> Maybe (TyCon, [Type]) -- Defined here to avoid module loops between Unify and TcType. tcSplitTyConApp_maybe ty = case coreFullView ty of @@ -1732,17 +1788,28 @@ tyConBindersPiTyBinders = map to_tyb where to_tyb (Bndr tv (NamedTCB vis)) = Named (Bndr tv vis) - to_tyb (Bndr tv (AnonTCB af)) = Anon (tymult (varType tv)) af + 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 ) @@ -1794,7 +1861,7 @@ = ( Bndr v (NamedTCB Required) : binders , fvs `delVarSet` v `unionVarSet` kind_vars ) | otherwise - = ( Bndr v (AnonTCB visArgTypeLike) : binders + = ( Bndr v AnonTCB : binders , fvs `unionVarSet` kind_vars ) where (binders, fvs) = go vs @@ -1863,6 +1930,15 @@ | otherwise = False +-- | Like `isForAllTy`, but returns True only if it is an inferred tyvar binder +isForAllTy_invis_ty :: Type -> Bool +isForAllTy_invis_ty ty + | ForAllTy (Bndr tv (Invisible InferredSpec)) _ <- coreFullView ty + , isTyVar tv + = True + + | otherwise = False + -- | Like `isForAllTy`, but returns True only if it is a covar binder isForAllTy_co :: Type -> Bool isForAllTy_co ty @@ -1880,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 @@ -1899,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 @@ -1951,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. -- @@ -1992,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. @@ -2195,32 +2291,46 @@ isFamFreeTy (CastTy ty _) = isFamFreeTy ty isFamFreeTy (CoercionTy _) = False -- Not sure about this --- | 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 +-- | 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 -- isFamFree and isTauTy buildSynTyCon name binders res_kind roles rhs - = mkSynonymTyCon name binders res_kind roles rhs is_tau is_fam_free is_forgetful + = 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_forgetful = any (not . (`elemVarSet` tyCoVarsOfType rhs) . binderVar) binders || - uniqSetAny isForgetfulSynTyCon (tyConsOfType rhs) - -- NB: This 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) + 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! + {- ************************************************************************ * * @@ -2237,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. -- @@ -2247,14 +2362,11 @@ -- 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 Just Unlifted -> True - Nothing -> - pprPanic "isUnliftedType" (ppr ty <+> dcolon <+> ppr (typeKind ty)) + Nothing -> pprPanic "isUnliftedType" (ppr ty <+> dcolon <+> ppr (typeKind ty)) -- | Returns: -- @@ -2264,6 +2376,9 @@ mightBeLiftedType :: Type -> Bool mightBeLiftedType = mightBeLifted . typeLevity_maybe +definitelyLiftedType :: Type -> Bool +definitelyLiftedType = not . mightBeUnliftedType + -- | Returns: -- -- * 'False' if the type is /guaranteed/ lifted or @@ -2272,6 +2387,9 @@ mightBeUnliftedType :: Type -> Bool mightBeUnliftedType = mightBeUnlifted . typeLevity_maybe +definitelyUnliftedType :: Type -> Bool +definitelyUnliftedType = not . mightBeLiftedType + -- | See "Type#type_classification" for what a boxed type is. -- Panics on representation-polymorphic types; See 'mightBeUnliftedType' for -- a more approximate predicate that behaves better in the presence of @@ -2355,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'. @@ -2368,6 +2480,18 @@ isStrictType :: HasDebugCallStack => Type -> Bool isStrictType = isUnliftedType +isTerminatingType :: HasDebugCallStack => Type -> Bool +-- ^ True <=> a term of this type cannot be bottom +-- This identifies the types described by +-- Note [NON-BOTTOM-DICTS invariant] in GHC.Core +-- 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 (isUnaryClassTyCon tc) + -- A non-unary class TyCon is terminating + -- See (UCM3) in Note [Unary class magic] in GHC.Core.TyCon + _ -> False + isPrimitiveType :: Type -> Bool -- ^ Returns true of types that are opaque to Haskell. isPrimitiveType ty = case splitTyConApp_maybe ty of @@ -2489,8 +2613,6 @@ torc is TYPE or CONSTRAINT ty : body_torc rep - bndr_torc is Type or Constraint - ki : bndr_torc ki : Type `a` is a type variable `a` is not free in rep @@ -2509,10 +2631,6 @@ Note that: * (FORALL1) rejects (forall (a::Maybe). blah) -* (FORALL1) accepts (forall (a :: t1~t2) blah), where the type variable - (not coercion variable!) 'a' has a kind (t1~t2) that in turn has kind - Constraint. See Note [Constraints in kinds] in GHC.Core.TyCo.Rep. - * (FORALL2) Surprise 1: See GHC.Core.TyCo.Rep Note [Unused coercion variable in ForAllTy] @@ -2557,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 @@ -2574,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) @@ -2631,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 @@ -2723,43 +2833,37 @@ 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 'isConcrete'. +-- or @'TYPE r@ is concrete. See 'isConcreteType'. -- -- __Precondition:__ The type has kind `TYPE blah` or `CONSTRAINT blah` isFixedRuntimeRepKind :: HasDebugCallStack => Kind -> Bool isFixedRuntimeRepKind k = assertPpr (isTYPEorCONSTRAINT k) (ppr k) $ -- the isLiftedTypeKind check is necessary b/c of Constraint - isConcrete k + isConcreteType k -- | Tests whether the given type is concrete, i.e. it -- whether it consists only of concrete type constructors, -- concrete type variables, and applications. -- -- See Note [Concrete types] in GHC.Tc.Utils.Concrete. -isConcrete :: Type -> Bool -isConcrete = go +isConcreteType :: Type -> Bool +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 ty | Just ty' <- coreView ty = go ty' - 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) - | isConcreteTyCon tc = all go tys - | otherwise = False + go (TyConApp tc tys) = go_tc tc tys go ForAllTy{} = False go (FunTy _ w t1 t2) = go w && go (typeKind t1) && go t1 @@ -2768,7 +2872,22 @@ 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 + , Just ty' <- expandSynTyConApp_maybe tc tys + = go ty' + -- Apart from forgetful synonyms, isConcreteTyCon + -- is enough; no need to expand. This is good for e.g + -- type LiftedRep = BoxedRep Lifted + | isConcreteTyCon tc + = all go tys + + | otherwise -- E.g. type families + = False + {- %************************************************************************ %* * @@ -2815,8 +2934,7 @@ injective_vars_of_binder :: TyConBinder -> FV injective_vars_of_binder (Bndr tv vis) = case vis of - AnonTCB af | isVisibleFunArg af - -> injectiveVarsOfType False -- conservative choice + AnonTCB -> injectiveVarsOfType False -- conservative choice (varType tv) NamedTCB argf | source_of_injectivity argf -> unitFV tv `unionFV` @@ -3152,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. @@ -3313,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,30 +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 -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,52 +16,53 @@ -} -{-# LANGUAGE BangPatterns #-} module GHC.Core.Unfold ( Unfolding, UnfoldingGuidance, -- Abstract types + ExprSize(..), sizeExpr, + + ArgSummary(..), nonTriv, + CallCtxt(..), + UnfoldingOpts (..), defaultUnfoldingOpts, updateCreationThreshold, updateUseThreshold, updateFunAppDiscount, updateDictDiscount, updateVeryAggressive, updateCaseScaling, updateCaseThreshold, updateReportPrefix, - ArgSummary(..), - - couldBeSmallEnoughToInline, inlineBoringOk, - smallEnoughToInline, - - callSiteInline, CallCtxt(..), - calcUnfoldingGuidance + inlineBoringOk, calcUnfoldingGuidance, + uncondInlineJoin ) where import GHC.Prelude -import GHC.Driver.Flags - 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.Basic ( Arity, RecFlag ) +import GHC.Types.ForeignCall +import GHC.Types.Tickish + +import GHC.Builtin.PrimOps import GHC.Builtin.Names + import GHC.Data.Bag -import GHC.Utils.Logger + import GHC.Utils.Misc import GHC.Utils.Outputable -import GHC.Types.ForeignCall -import GHC.Types.Name -import GHC.Types.Tickish import qualified Data.ByteString as BS -import Data.List (isPrefixOf) - +import Data.List.NonEmpty (nonEmpty) +import qualified Data.List.NonEmpty as NE -- | Unfolding options data UnfoldingOpts = UnfoldingOpts @@ -151,25 +152,42 @@ updateReportPrefix :: Maybe String -> UnfoldingOpts -> UnfoldingOpts updateReportPrefix n opts = opts { unfoldingReportPrefix = n } -{- -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. +data ArgSummary = TrivArg -- Nothing interesting + | NonTrivArg -- Arg has structure + | ValueArg -- Arg is a con-app or PAP + -- ..or con-like. Note [Conlike is interesting] -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. +instance Outputable ArgSummary where + ppr TrivArg = text "TrivArg" + ppr NonTrivArg = text "NonTrivArg" + ppr ValueArg = text "ValueArg" -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. +nonTriv :: ArgSummary -> Bool +nonTriv TrivArg = False +nonTriv _ = True +data CallCtxt + = BoringCtxt + | RhsCtxt RecFlag -- Rhs of a let-binding; see Note [RHS of lets] + | DiscArgCtxt -- Argument of a function with non-zero arg discount + | RuleArgCtxt -- We are somewhere in the argument of a function with rules + + | ValAppCtxt -- We're applied to at least one value arg + -- This arises when we have ((f x |> co) y) + -- Then the (f x) has argument 'x' but in a ValAppCtxt + + | CaseCtxt -- We're the scrutinee of a case + -- that decomposes its scrutinee + +instance Outputable CallCtxt where + ppr CaseCtxt = text "CaseCtxt" + ppr ValAppCtxt = text "ValAppCtxt" + ppr BoringCtxt = text "BoringCtxt" + ppr (RhsCtxt ir)= text "RhsCtxt" <> parens (ppr ir) + ppr DiscArgCtxt = text "DiscArgCtxt" + ppr RuleArgCtxt = text "RuleArgCtxt" + +{- Note [Calculate unfolding guidance on the non-occ-anal'd expression] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Notice that we give the non-occur-analysed expression to @@ -201,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] @@ -275,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 @@ -283,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] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -379,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 @@ -455,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 @@ -490,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) @@ -535,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 @@ -562,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 @@ -631,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 @@ -662,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 @@ -703,6 +850,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 @@ -930,561 +1079,3 @@ sizeZero = SizeIs 0 emptyBag 0 sizeN n = SizeIs n emptyBag 0 - -{- -************************************************************************ -* * -\subsection[considerUnfolding]{Given all the info, do (not) do the unfolding} -* * -************************************************************************ - -We use 'couldBeSmallEnoughToInline' to avoid exporting inlinings that -we ``couldn't possibly use'' on the other side. Can be overridden w/ -flaggery. Just the same as smallEnoughToInline, except that it has no -actual arguments. --} - -couldBeSmallEnoughToInline :: UnfoldingOpts -> Int -> CoreExpr -> Bool -couldBeSmallEnoughToInline opts threshold rhs - = case sizeExpr opts threshold [] body of - TooBig -> False - _ -> True - where - (_, body) = collectBinders rhs - ----------------- -smallEnoughToInline :: UnfoldingOpts -> Unfolding -> Bool -smallEnoughToInline opts (CoreUnfolding {uf_guidance = guidance}) - = case guidance of - UnfIfGoodArgs {ug_size = size} -> size <= unfoldingUseThreshold opts - UnfWhen {} -> True - UnfNever -> False -smallEnoughToInline _ _ - = False - -{- -************************************************************************ -* * -\subsection{callSiteInline} -* * -************************************************************************ - -This is the key function. It decides whether to inline a variable at a call site - -callSiteInline is used at call sites, so it is a bit more generous. -It's a very important function that embodies lots of heuristics. -A non-WHNF can be inlined if it doesn't occur inside a lambda, -and occurs exactly once or - occurs once in each branch of a case and is small - -If the thing is in WHNF, there's no danger of duplicating work, -so we can inline if it occurs once, or is small - -NOTE: we don't want to inline top-level functions that always diverge. -It just makes the code bigger. Tt turns out that the convenient way to prevent -them inlining is to give them a NOINLINE pragma, which we do in -StrictAnal.addStrictnessInfoToTopId --} - -data ArgSummary = TrivArg -- Nothing interesting - | NonTrivArg -- Arg has structure - | ValueArg -- Arg is a con-app or PAP - -- ..or con-like. Note [Conlike is interesting] - -instance Outputable ArgSummary where - ppr TrivArg = text "TrivArg" - ppr NonTrivArg = text "NonTrivArg" - ppr ValueArg = text "ValueArg" - -nonTriv :: ArgSummary -> Bool -nonTriv TrivArg = False -nonTriv _ = True - -data CallCtxt - = BoringCtxt - | RhsCtxt RecFlag -- Rhs of a let-binding; see Note [RHS of lets] - | DiscArgCtxt -- Argument of a function with non-zero arg discount - | RuleArgCtxt -- We are somewhere in the argument of a function with rules - - | ValAppCtxt -- We're applied to at least one value arg - -- This arises when we have ((f x |> co) y) - -- Then the (f x) has argument 'x' but in a ValAppCtxt - - | CaseCtxt -- We're the scrutinee of a case - -- that decomposes its scrutinee - -instance Outputable CallCtxt where - ppr CaseCtxt = text "CaseCtxt" - ppr ValAppCtxt = text "ValAppCtxt" - ppr BoringCtxt = text "BoringCtxt" - ppr (RhsCtxt ir)= text "RhsCtxt" <> parens (ppr ir) - ppr DiscArgCtxt = text "DiscArgCtxt" - ppr RuleArgCtxt = text "RuleArgCtxt" - -callSiteInline :: Logger - -> UnfoldingOpts - -> Int -- Case depth - -> 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 - = case idUnfolding id of - -- idUnfolding checks for loop-breakers, returning NoUnfolding - -- Things with an INLINE pragma may have an unfolding *and* - -- be a loop breaker (maybe the knot is not yet untied) - CoreUnfolding { uf_tmpl = unf_template - , uf_cache = unf_cache - , uf_guidance = guidance } - | active_unfolding -> tryUnfolding logger opts case_depth id lone_variable - arg_infos cont_info unf_template - unf_cache guidance - | otherwise -> traceInline logger opts id "Inactive unfolding:" (ppr id) Nothing - NoUnfolding -> Nothing - BootUnfolding -> Nothing - OtherCon {} -> Nothing - DFunUnfolding {} -> Nothing -- Never unfold a DFun - --- | 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 - -- We take care to ensure that doc is used in only one branch, ensuring that - -- the simplifier can push its allocation into the branch. See Note [INLINE - -- conditional tracing utilities]. - | enable = logTraceMsg logger str doc result - | otherwise = result - where - enable - | logHasDumpFlag logger Opt_D_dump_verbose_inlinings - = True - | Just prefix <- unfoldingReportPrefix opts - = prefix `isPrefixOf` occNameString (getOccName inline_id) - | otherwise - = False -{-# INLINE traceInline #-} -- see Note [INLINE conditional tracing utilities] - -{- Note [Avoid inlining into deeply nested cases] - ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -Consider a function f like this: - - f arg1 arg2 = - case ... - ... -> g arg1 - ... -> g arg2 - -This function is small. So should be safe to inline. -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 ... - -f2 arg1 arg2 ... = ... - case _foo of - alt1 -> ... f3 arg1 ... - alt2 -> ... f3 arg2 ... - -f3 arg1 arg2 ... = ... - -... repeats up to n times. And then f1 is -applied to some arguments: - -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: - -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: - -foo = - ... - case _foo of - alt1 -> ... 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 -ticks/RAM. This pattern happened #18730. - -To combat this we introduce one more heuristic when weighing inlining decision. -We keep track of a "case-depth". Which increases each time we look inside a case -expression with more than one alternative. - -We then apply a penalty to inlinings based on the case-depth at which they would -be inlined. Bounding the number of inlinings in such a scenario. - -The heuristic can be tuned in two ways: - -* 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. - Scaling can be set with -funfolding-case-scaling. - -Some guidance on setting these defaults: - -* A low treshold (<= 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. - -The end result is that we are settling for a scaling of 30, with a threshold of 2. -This gives us minimal compiler perf regressions. No nofib runtime regressions and -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. - --} - -tryUnfolding :: Logger -> UnfoldingOpts -> Int -> Id -> Bool -> [ArgSummary] -> CallCtxt - -> CoreExpr -> UnfoldingCache -> UnfoldingGuidance - -> Maybe CoreExpr -tryUnfolding logger opts !case_depth id lone_variable arg_infos - cont_info unf_template unf_cache guidance - = case guidance of - UnfNever -> traceInline logger opts id str (text "UnfNever") Nothing - - UnfWhen { ug_arity = uf_arity, ug_unsat_ok = unsat_ok, ug_boring_ok = boring_ok } - | enough_args && (boring_ok || some_benefit || unfoldingVeryAggressive opts) - -- See Note [INLINE for small functions] (3) - -> traceInline logger opts id str (mk_doc some_benefit empty True) (Just unf_template) - | otherwise - -> traceInline logger opts id str (mk_doc some_benefit empty False) Nothing - where - some_benefit = calc_some_benefit uf_arity - 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 - 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 - 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 - , text "depth based penalty =" <+> int depth_penalty - , text "discounted size =" <+> int adjusted_size ] - - where - -- 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 - -- Ids that are never going to inline anyway. - -- See Note [UnfoldingCache] in GHC.Core - UnfoldingCache{ uf_is_work_free = is_wf, uf_expandable = is_exp } = unf_cache - - mk_doc some_benefit extra_doc yes_or_no - = vcat [ text "arg infos" <+> ppr arg_infos - , text "interesting continuation" <+> ppr cont_info - , text "some_benefit" <+> ppr some_benefit - , text "is exp:" <+> ppr is_exp - , text "is work-free:" <+> ppr is_wf - , text "guidance" <+> ppr guidance - , extra_doc - , text "ANSWER =" <+> if yes_or_no then text "YES" else text "NO"] - - ctx = log_default_dump_context (logFlags logger) - str = "Considering inlining: " ++ showSDocOneLine ctx (ppr id) - n_val_args = length arg_infos - - -- some_benefit is used when the RHS is small enough - -- and the call has enough (or too many) value - -- 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 - -- expected by the unfolding - calc_some_benefit uf_arity - | not saturated = interesting_args -- Under-saturated - -- Note [Unsaturated applications] - | otherwise = interesting_args -- Saturated or over-saturated - || interesting_call - where - saturated = n_val_args >= uf_arity - over_saturated = n_val_args > uf_arity - interesting_args = any nonTriv arg_infos - -- NB: (any nonTriv arg_infos) looks at the - -- over-saturated args too which is "wrong"; - -- but if over-saturated we inline anyway. - - interesting_call - | over_saturated - = True - | otherwise - = case cont_info of - CaseCtxt -> not (lone_variable && is_exp) -- Note [Lone variables] - 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 - -> uf_arity > 0 -- See Note [RHS of lets] - _other -> False -- See Note [Nested functions] - - -{- Note [RHS of lets] -~~~~~~~~~~~~~~~~~~~~~ -When the call is the argument of a function with a RULE, or the RHS of a let, -we are a little bit keener to inline (in tryUnfolding). For example - f y = (y,y,y) - g y = let x = f y in ...(case x of (a,b,c) -> ...) ... -We'd inline 'f' if the call was in a case context, and it kind-of-is, -only we can't see it. Also - x = f v -could be expensive whereas - x = case v of (a,b) -> a -is patently cheap and may allow more eta expansion. - -So, in `interesting_call` in `tryUnfolding`, we treat the RHS of a -/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 - -Note [Unsaturated applications] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When a call is not saturated, we *still* inline if one of the -arguments has interesting structure. That's sometimes very important. -A good example is the Ord instance for Bool in Base: - - Rec { - $fOrdBool =GHC.Classes.D:Ord - @ Bool - ... - $cmin_ajX - - $cmin_ajX [Occ=LoopBreaker] :: Bool -> Bool -> Bool - $cmin_ajX = GHC.Classes.$dmmin @ Bool $fOrdBool - } - -But the defn of GHC.Classes.$dmmin is: - - $dmmin :: forall a. GHC.Classes.Ord a => a -> a -> a - {- Arity: 3, HasNoCafRefs, Strictness: SLL, - Unfolding: (\ @ a $dOrd :: GHC.Classes.Ord a x :: a y :: a -> - case @ a GHC.Classes.<= @ a $dOrd x y of wild { - GHC.Types.False -> y GHC.Types.True -> x }) -} - -We *really* want to inline $dmmin, even though it has arity 3, in -order to unravel the recursion. - - -Note [Things to watch] -~~~~~~~~~~~~~~~~~~~~~~ -* { y = I# 3; x = y `cast` co; ...case (x `cast` co) of ... } - Assume x is exported, so not inlined unconditionally. - Then we want x to inline unconditionally; no reason for it - not to, and doing so avoids an indirection. - -* { x = I# 3; ....f x.... } - Make sure that x does not inline unconditionally! - Lest we get extra allocation. - -Note [Nested functions] -~~~~~~~~~~~~~~~~~~~~~~~ -At one time we treated a call of a non-top-level function as -"interesting" (regardless of how boring the context) in the hope -that inlining it would eliminate the binding, and its allocation. -Specifically, in the default case of interesting_call we had - _other -> not is_top && uf_arity > 0 - -But actually postInlineUnconditionally does some of this and overall -it makes virtually no difference to nofib. So I simplified away this -special case - -Note [Cast then apply] -~~~~~~~~~~~~~~~~~~~~~~ -Consider - myIndex = __inline_me ( (/\a. ) |> co ) - co :: (forall a. a -> a) ~ (forall a. T a) - ... /\a.\x. case ((myIndex a) |> sym co) x of { ... } ... - -We need to inline myIndex to unravel this; but the actual call (myIndex a) has -no value arguments. The ValAppCtxt gives it enough incentive to inline. - -Note [Inlining in ArgCtxt] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -The condition (arity > 0) here is very important, because otherwise -we end up inlining top-level stuff into useless places; eg - x = I# 3# - f = \y. g x -This can make a very big difference: it adds 16% to nofib 'integer' allocs, -and 20% to 'power'. - -At one stage I replaced this condition by 'True' (leading to the above -slow-down). The motivation was test eyeball/inline1.hs; but that seems -to work ok now. - -NOTE: arguably, we should inline in ArgCtxt only if the result of the -call is at least CONLIKE. At least for the cases where we use ArgCtxt -for the RHS of a 'let', we only profit from the inlining if we get a -CONLIKE thing (modulo lets). - -Note [Lone variables] -~~~~~~~~~~~~~~~~~~~~~ -See also Note [Interaction of exprIsWorkFree and lone variables] -which appears below - -The "lone-variable" case is important. I spent ages messing about -with unsatisfactory variants, but this is nice. The idea is that if a -variable appears all alone - - as an arg of lazy fn, or rhs BoringCtxt - as scrutinee of a case CaseCtxt - as arg of a fn ArgCtxt -AND - it is bound to a cheap expression - -then we should not inline it (unless there is some other reason, -e.g. it is the sole occurrence). That is what is happening at -the use of 'lone_variable' in 'interesting_call'. - -Why? At least in the case-scrutinee situation, turning - let x = (a,b) in case x of y -> ... -into - let x = (a,b) in case (a,b) of y -> ... -and thence to - let x = (a,b) in let y = (a,b) in ... -is bad if the binding for x will remain. - -Another example: I discovered that strings -were getting inlined straight back into applications of 'error' -because the latter is strict. - s = "foo" - f = \x -> ...(error s)... - -Fundamentally such contexts should not encourage inlining because, provided -the RHS is "expandable" (see Note [exprIsExpandable] in GHC.Core.Utils) the -context can ``see'' the unfolding of the variable (e.g. case or a -RULE) so there's no gain. - -However, watch out: - - * Consider this: - foo = \n. [n]) {-# INLINE foo #-} - bar = foo 20 {-# INLINE bar #-} - baz = \n. case bar of { (m:_) -> m + n } - Here we really want to inline 'bar' so that we can inline 'foo' - and the whole thing unravels as it should obviously do. This is - important: in the NDP project, 'bar' generates a closure data - structure rather than a list. - - So the non-inlining of lone_variables should only apply if the - unfolding is regarded as expandable; because that is when - exprIsConApp_maybe looks through the unfolding. Hence the "&& - is_exp" in the CaseCtxt branch of interesting_call - - * Even a type application or coercion isn't a lone variable. - Consider - case $fMonadST @ RealWorld of { :DMonad a b c -> c } - We had better inline that sucker! The case won't see through it. - - For now, I'm treating treating a variable applied to types - in a *lazy* context "lone". The motivating example was - f = /\a. \x. BIG - g = /\a. \y. h (f a) - There's no advantage in inlining f here, and perhaps - a significant disadvantage. Hence some_val_args in the Stop case - -Note [Interaction of exprIsWorkFree and lone variables] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The lone-variable test says "don't inline if a case expression -scrutinises a lone variable whose unfolding is cheap". It's very -important that, under these circumstances, exprIsConApp_maybe -can spot a constructor application. So, for example, we don't -consider - let x = e in (x,x) -to be cheap, and that's good because exprIsConApp_maybe doesn't -think that expression is a constructor application. - -In the 'not (lone_variable && is_wf)' test, I used to test is_value -rather than is_wf, which was utterly wrong, because the above -expression responds True to exprIsHNF, which is what sets is_value. - -This kind of thing can occur if you have - - {-# INLINE foo #-} - foo = let x = e in (x,x) - -which Roman did. - - --} - -computeDiscount :: [Int] -> Int -> [ArgSummary] -> CallCtxt - -> Int -computeDiscount arg_discounts res_discount arg_infos cont_info - - = 10 -- Discount of 10 because the result replaces the call - -- so we count 10 for the function itself - - + 10 * length actual_arg_discounts - -- Discount of 10 for each arg supplied, - -- because the result replaces the call - - + total_arg_discount + res_discount' - where - actual_arg_discounts = zipWith mk_arg_discount arg_discounts arg_infos - total_arg_discount = sum actual_arg_discounts - - mk_arg_discount _ TrivArg = 0 - mk_arg_discount _ NonTrivArg = 10 - mk_arg_discount discount ValueArg = discount - - res_discount' - | LT <- arg_discounts `compareLength` arg_infos - = res_discount -- Over-saturated - | otherwise - = case cont_info of - BoringCtxt -> 0 - CaseCtxt -> res_discount -- Presumably a constructor - ValAppCtxt -> res_discount -- Presumably a function - _ -> 40 `min` res_discount - -- ToDo: this 40 `min` res_discount doesn't seem right - -- for DiscArgCtxt it shouldn't matter because the function will - -- get the arg discount for any non-triv arg - -- for RuleArgCtxt we do want to be keener to inline; but not only - -- constructor results - -- for RhsCtxt I suppose that exposing a data con is good in general - -- And 40 seems very arbitrary - -- - -- res_discount can be very large when a function returns - -- constructors; but we only want to invoke that large discount - -- when there's a case continuation. - -- Otherwise we, rather arbitrarily, threshold it. Yuk. - -- But we want to avoid inlining large functions that return - -- constructors into contexts that are simply "interesting" 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,2093 +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.Canonical), 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 - deriving (Functor) - -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) - -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 @@ -6,17 +6,19 @@ , bottomUE , deleteUE , lookupUE + , popUE , scaleUE , scaleUsage , supUE , supUEs - , unitUE + , singleUsageUE , zeroUE ) where import Data.Foldable import GHC.Prelude import GHC.Core.Multiplicity +import GHC.Types.Var import GHC.Types.Name import GHC.Types.Name.Env import GHC.Utils.Outputable @@ -54,8 +56,13 @@ -- For now, we use extra multiplicity Bottom for empty case. data UsageEnv = UsageEnv !(NameEnv Mult) Bool -unitUE :: NamedThing n => n -> Mult -> UsageEnv -unitUE x w = UsageEnv (unitNameEnv (getName x) w) False +-- | Record a single usage of an Id, i.e. {n: 1} +-- Exception: We do not record external names (both GlobalIds and top-level LocalIds) +-- because they're not relevant to linearity checking. +singleUsageUE :: Id -> UsageEnv +singleUsageUE x | isExternalName n = zeroUE + | otherwise = UsageEnv (unitNameEnv n OneTy) False + where n = getName x zeroUE, bottomUE :: UsageEnv zeroUE = UsageEnv emptyNameEnv False @@ -83,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 @@ -97,6 +108,9 @@ case lookupNameEnv e (getName x) of Just w -> MUsage w Nothing -> if has_bottom then Bottom else Zero + +popUE :: NamedThing n => UsageEnv -> n -> (Usage, UsageEnv) +popUE ue x = (lookupUE ue x, deleteUE ue x) instance Outputable UsageEnv where ppr (UsageEnv ne b) = text "UsageEnv:" <+> ppr ne <+> ppr b diff --git a/GHC/Core/Utils.hs b/GHC/Core/Utils.hs --- a/GHC/Core/Utils.hs +++ b/GHC/Core/Utils.hs @@ -11,2668 +11,3056 @@ -- * Constructing expressions mkCast, mkCastMCo, mkPiMCo, mkTick, mkTicks, mkTickNoHNF, tickHNFArgs, - bindNonRec, needsCaseBinding, - mkAltExpr, mkDefaultCase, mkSingleAltCase, - - -- * Taking expressions apart - findDefault, addDefault, findAlt, isDefaultAlt, - mergeAlts, trimConArgs, - filterAlts, combineIdenticalAlts, refineDefaultAlt, - scaleAltsBy, - - -- * Properties of expressions - exprType, coreAltType, coreAltsType, mkLamType, mkLamTypes, - mkFunctionType, - exprIsTrivial, getIdFromTrivialExpr, getIdFromTrivialExpr_maybe, - trivial_expr_fold, - exprIsDupable, exprIsCheap, exprIsExpandable, exprIsCheapX, CheapAppFun, - exprIsHNF, exprOkForSpeculation, exprOkForSideEffects, exprOkForSpecEval, - exprIsWorkFree, exprIsConLike, - isCheapApp, isExpandableApp, isSaturatedConApp, - exprIsTickedString, exprIsTickedString_maybe, - exprIsTopLevelBindable, - altsAreExhaustive, etaExpansionTick, - - -- * Equality - cheapEqExpr, cheapEqExpr', diffBinds, - - -- * Manipulating data constructors and types - exprToType, - applyTypeToArgs, - dataConRepInstPat, dataConRepFSInstPat, - isEmptyTy, normSplitTyConApp_maybe, - - -- * Working with ticks - stripTicksTop, stripTicksTopE, stripTicksTopT, - stripTicksE, stripTicksT, - - -- * InScopeSet things which work over CoreBinds - mkInScopeSetBndrs, extendInScopeSetBind, extendInScopeSetBndrs, - - -- * StaticPtr - collectMakeStaticArgs, - - -- * Join points - isJoinBind, - - -- * Tag inference - mkStrictFieldSeqs, shouldStrictifyIdForCbv, shouldUseCbvForId, - - -- * unsafeEqualityProof - isUnsafeEqualityProof, - - -- * Dumping stuff - dumpIdInfoOfProgram - ) where - -import GHC.Prelude -import GHC.Platform - -import GHC.Core -import GHC.Core.Ppr -import GHC.Core.DataCon -import GHC.Core.Type as Type -import GHC.Core.FamInstEnv -import GHC.Core.TyCo.Compare( eqType, eqTypeX ) -import GHC.Core.Coercion -import GHC.Core.Reduction -import GHC.Core.TyCon -import GHC.Core.Multiplicity - -import GHC.Builtin.Names ( makeStaticName, unsafeEqualityProofIdKey ) -import GHC.Builtin.PrimOps - -import GHC.Types.Var -import GHC.Types.SrcLoc -import GHC.Types.Var.Env -import GHC.Types.Var.Set -import GHC.Types.Name -import GHC.Types.Literal -import GHC.Types.Tickish -import GHC.Types.Id -import GHC.Types.Id.Info -import GHC.Types.Basic( Arity, Levity(..) - ) -import GHC.Types.Unique -import GHC.Types.Unique.Set -import GHC.Types.Demand - -import GHC.Data.FastString -import GHC.Data.Maybe -import GHC.Data.List.SetOps( minusList ) -import GHC.Data.OrdList - -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 Data.Ord ( comparing ) -import qualified Data.Set as Set -import GHC.Types.RepType (isZeroBitTy) - -{- -************************************************************************ -* * -\subsection{Find the type of a Core atom/expression} -* * -************************************************************************ --} - -exprType :: HasDebugCallStack => CoreExpr -> Type --- ^ Recover the type of a well-typed Core expression. Fails when --- applied to the actual 'GHC.Core.Type' expression as it cannot --- really be said to have a type -exprType (Var var) = idType var -exprType (Lit lit) = literalType lit -exprType (Coercion co) = coercionType co -exprType (Let bind body) - | NonRec tv rhs <- bind -- See Note [Type bindings] - , Type ty <- rhs = substTyWithUnchecked [tv] [ty] (exprType body) - | otherwise = exprType body -exprType (Case _ _ ty _) = ty -exprType (Cast _ co) = coercionRKind co -exprType (Tick _ e) = exprType e -exprType (Lam binder expr) = mkLamType binder (exprType expr) -exprType e@(App _ _) - = case collectArgs e of - (fun, args) -> applyTypeToArgs (pprCoreExpr e) (exprType fun) args - -exprType other = pprPanic "exprType" (pprCoreExpr other) - -coreAltType :: CoreAlt -> Type --- ^ Returns the type of the alternatives right hand side -coreAltType alt@(Alt _ bs rhs) - = case occCheckExpand bs rhs_ty of - -- Note [Existential variables and silly type synonyms] - Just ty -> ty - Nothing -> pprPanic "coreAltType" (pprCoreAlt alt $$ ppr rhs_ty) - where - rhs_ty = exprType rhs - -coreAltsType :: [CoreAlt] -> Type --- ^ Returns the type of the first alternative, which should be the same as for all alternatives -coreAltsType (alt:_) = coreAltType alt -coreAltsType [] = panic "coreAltsType" - -mkLamType :: HasDebugCallStack => Var -> Type -> Type --- ^ 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 - - | isCoVar v - , v `elemVarSet` tyCoVarsOfType body_ty - = mkForAllTy (Bndr v Required) body_ty - - | otherwise - = mkFunctionType (varMult v) (varType v) body_ty - -mkLamTypes vs ty = foldr mkLamType ty vs - -{- -Note [Type bindings] -~~~~~~~~~~~~~~~~~~~~ -Core does allow type bindings, although such bindings are -not much used, except in the output of the desugarer. -Example: - let a = Int in (\x:a. x) -Given this, exprType must be careful to substitute 'a' in the -result type (#8522). - -Note [Existential variables and silly type synonyms] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - data T = forall a. T (Funny a) - type Funny a = Bool - f :: T -> Bool - f (T x) = x - -Now, the type of 'x' is (Funny a), where 'a' is existentially quantified. -That means that 'exprType' and 'coreAltsType' may give a result that *appears* -to mention an out-of-scope type variable. See #3409 for a more real-world -example. - -Various possibilities suggest themselves: - - - Ignore the problem, and make Lint not complain about such variables - - - Expand all type synonyms (or at least all those that discard arguments) - This is tricky, because at least for top-level things we want to - retain the type the user originally specified. - - - Expand synonyms on the fly, when the problem arises. That is what - we are doing here. It's not too expensive, I think. - -Note that there might be existentially quantified coercion variables, too. --} - -applyTypeToArgs :: HasDebugCallStack => SDoc -> 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 - = go op_ty args - where - go op_ty [] = op_ty - go op_ty (Type ty : args) = go_ty_args op_ty [ty] args - go op_ty (Coercion co : args) = go_ty_args op_ty [mkCoercionTy co] args - go op_ty (_ : args) | Just (_, _, _, res_ty) <- splitFunTy_maybe op_ty - = go res_ty args - go _ args = pprPanic "applyTypeToArgs" (panic_msg args) - - -- go_ty_args: accumulate type arguments so we can - -- instantiate all at once with piResultTys - go_ty_args op_ty rev_tys (Type ty : args) - = go_ty_args op_ty (ty:rev_tys) args - go_ty_args op_ty rev_tys (Coercion co : args) - = go_ty_args op_ty (mkCoercionTy co : rev_tys) args - 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 - , text "Args:" <+> ppr args - , text "Args':" <+> ppr as ] - -mkCastMCo :: CoreExpr -> MCoercionR -> CoreExpr -mkCastMCo e MRefl = e -mkCastMCo e (MCo co) = Cast e co - -- We are careful to use (MCo co) only when co is not reflexive - -- Hence (Cast e co) rather than (mkCast e co) - -mkPiMCo :: Var -> MCoercionR -> MCoercionR -mkPiMCo _ MRefl = MRefl -mkPiMCo v (MCo co) = MCo (mkPiCo Representational v co) - - -{- ********************************************************************* -* * - Casts -* * -********************************************************************* -} - --- | 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)) - "Trying to coerce" (text "(" <> ppr expr - $$ text "::" <+> ppr (exprType expr) <> text ")" - $$ ppr co $$ ppr (coercionType co) - $$ callStackDoc) $ - (Cast expr co) - - -{- ********************************************************************* -* * - Attaching ticks -* * -********************************************************************* -} - --- | Wraps the given expression in the source annotation, dropping the --- annotation if possible. -mkTick :: CoreTickish -> CoreExpr -> CoreExpr -mkTick t orig_expr = mkTick' id id orig_expr - where - -- 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). - -- If we want to push the tick deeper, we pre-compose `top` with a function - -- adding the tick. - mkTick' :: (CoreExpr -> CoreExpr) -- apply after adding tick (float through) - -> (CoreExpr -> CoreExpr) -- apply before adding tick (float with) - -> CoreExpr -- current expression - -> CoreExpr - mkTick' top rest expr = case expr of - - -- Cost centre ticks should never be reordered relative to each - -- other. Therefore we can stop whenever two collide. - Tick t2 e - | ProfNote{} <- t2, ProfNote{} <- t -> top $ Tick t $ rest expr - - -- Otherwise we assume that ticks of different placements float - -- through each other. - | tickishPlace t2 /= tickishPlace t -> mkTick' (top . Tick t2) rest e - - -- For annotations this is where we make sure to not introduce - -- redundant ticks. - | tickishContains t t2 -> mkTick' top rest e - | tickishContains t2 t -> orig_expr - | otherwise -> mkTick' top (rest . Tick t2) e - - -- Ticks don't care about types, so we just float all ticks - -- through them. Note that it's not enough to check for these - -- cases top-level. While mkTick will never produce Core with type - -- expressions below ticks, such constructs can be the result of - -- unfoldings. We therefore make an effort to put everything into - -- the right place no matter what we start with. - Cast e co -> mkTick' (top . flip Cast co) rest e - Coercion co -> Coercion co - - Lam x e - -- Always float through type lambdas. Even for non-type lambdas, - -- floating is allowed for all but the most strict placement rule. - | not (isRuntimeVar x) || tickishPlace t /= PlaceRuntime - -> mkTick' (top . Lam x) rest e - - -- If it is both counting and scoped, we split the tick into its - -- two components, often allowing us to keep the counting tick on - -- the outside of the lambda and push the scoped tick inside. - -- The point of this is that the counting tick can probably be - -- floated, and the lambda may then be in a position to be - -- beta-reduced. - | canSplit - -> top $ Tick (mkNoScope t) $ rest $ Lam x $ mkTick (mkNoCount t) e - - App f arg - -- Always float through type applications. - | not (isRuntimeArg arg) - -> mkTick' (top . flip App arg) rest f - - -- We can also float through constructor applications, placement - -- permitting. Again we can split. - | isSaturatedConApp expr && (tickishPlace t==PlaceCostCentre || canSplit) - -> if tickishPlace t == PlaceCostCentre - then top $ rest $ tickHNFArgs t expr - else top $ Tick (mkNoScope t) $ rest $ tickHNFArgs (mkNoCount t) expr - - Var x - | notFunction && tickishPlace t == PlaceCostCentre - -> orig_expr - | notFunction && canSplit - -> top $ Tick (mkNoScope t) $ rest expr - where - -- SCCs can be eliminated on variables provided the variable - -- is not a function. In these cases the SCC makes no difference: - -- the cost of evaluating the variable will be attributed to its - -- definition site. When the variable refers to a function, however, - -- an SCC annotation on the variable affects the cost-centre stack - -- when the function is called, so we must retain those. - notFunction = not (isFunTy (idType x)) - - Lit{} - | tickishPlace t == PlaceCostCentre - -> orig_expr - - -- Catch-all: Annotate where we stand - _any -> top $ Tick t $ rest expr - -mkTicks :: [CoreTickish] -> CoreExpr -> CoreExpr -mkTicks ticks expr = foldr mkTick expr ticks - -isSaturatedConApp :: CoreExpr -> Bool -isSaturatedConApp e = go e [] - where go (App f a) as = go f (a:as) - go (Var fun) args - = isConLikeId fun && idArity fun == valArgCount args - go (Cast f _) as = go f as - go _ _ = False - -mkTickNoHNF :: CoreTickish -> CoreExpr -> CoreExpr -mkTickNoHNF t e - | exprIsHNF e = tickHNFArgs t e - | otherwise = mkTick t e - --- push a tick into the arguments of a HNF (call or constructor app) -tickHNFArgs :: CoreTickish -> CoreExpr -> CoreExpr -tickHNFArgs t e = push t e - where - push t (App f (Type u)) = App (push t f) (Type u) - push t (App f arg) = App (push t f) (mkTick t arg) - push _t e = e - --- | Strip ticks satisfying a predicate from top of an expression -stripTicksTop :: (CoreTickish -> Bool) -> Expr b -> ([CoreTickish], Expr b) -stripTicksTop p = go [] - where go ts (Tick t e) | p t = go (t:ts) e - go ts other = (reverse ts, other) - --- | Strip ticks satisfying a predicate from top of an expression, --- returning the remaining expression -stripTicksTopE :: (CoreTickish -> Bool) -> Expr b -> Expr b -stripTicksTopE p = go - where go (Tick t e) | p t = go e - go other = other - --- | Strip ticks satisfying a predicate from top of an expression, --- returning the ticks -stripTicksTopT :: (CoreTickish -> Bool) -> Expr b -> [CoreTickish] -stripTicksTopT p = go [] - where go ts (Tick t e) | p t = go (t:ts) e - go ts _ = ts - --- | Completely strip ticks satisfying a predicate from an --- expression. Note this is O(n) in the size of the expression! -stripTicksE :: (CoreTickish -> Bool) -> Expr b -> Expr b -stripTicksE p expr = go expr - where go (App e a) = App (go e) (go a) - go (Lam b e) = Lam b (go e) - go (Let b e) = Let (go_bs b) (go e) - go (Case e b t as) = Case (go e) b t (map go_a as) - go (Cast e c) = Cast (go e) c - go (Tick t e) - | p t = go e - | otherwise = Tick t (go e) - go other = other - go_bs (NonRec b e) = NonRec b (go e) - go_bs (Rec bs) = Rec (map go_b bs) - go_b (b, e) = (b, go e) - go_a (Alt c bs e) = Alt c bs (go e) - -stripTicksT :: (CoreTickish -> Bool) -> Expr b -> [CoreTickish] -stripTicksT p expr = fromOL $ go expr - where go (App e a) = go e `appOL` go a - go (Lam _ e) = go e - go (Let b e) = go_bs b `appOL` go e - go (Case e _ _ as) = go e `appOL` concatOL (map go_a as) - go (Cast e _) = go e - go (Tick t e) - | p t = t `consOL` go e - | otherwise = go e - go _ = nilOL - go_bs (NonRec _ e) = go e - go_bs (Rec bs) = concatOL (map go_b bs) - go_b (_, e) = go e - go_a (Alt _ _ e) = go e - -{- -************************************************************************ -* * -\subsection{Other expression construction} -* * -************************************************************************ --} - -bindNonRec :: HasDebugCallStack => Id -> CoreExpr -> CoreExpr -> CoreExpr --- ^ @bindNonRec x r b@ produces either: --- --- > let x = r in b --- --- or: --- --- > case r of x { _DEFAULT_ -> b } --- --- depending on whether we have to use a @case@ or @let@ --- binding for the expression (see 'needsCaseBinding'). --- It's used by the desugarer to avoid building bindings --- that give Core Lint a heart attack, although actually --- the simplifier deals with them perfectly well. See --- also 'GHC.Core.Make.mkCoreLet' -bindNonRec bndr rhs body - | isTyVar bndr = let_bind - | isCoVar bndr = if isCoArg rhs then let_bind - {- See Note [Binding coercions] -} else case_bind - | isJoinId bndr = let_bind - | needsCaseBinding (idType bndr) rhs = case_bind - | otherwise = let_bind - where - 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) - -mkAltExpr :: AltCon -- ^ Case alternative constructor - -> [CoreBndr] -- ^ Things bound by the pattern match - -> [Type] -- ^ The type arguments to the case alternative - -> CoreExpr --- ^ This guy constructs the value that the scrutinee must have --- given that you are in one particular branch of a case -mkAltExpr (DataAlt con) args inst_tys - = mkConApp con (map Type inst_tys ++ varsToCoreExprs args) -mkAltExpr (LitAlt lit) [] [] - = Lit lit -mkAltExpr (LitAlt _) _ _ = panic "mkAltExpr LitAlt" -mkAltExpr DEFAULT _ _ = panic "mkAltExpr DEFAULT" - -mkDefaultCase :: CoreExpr -> Id -> CoreExpr -> CoreExpr --- Make (case x of y { DEFAULT -> e } -mkDefaultCase scrut case_bndr body - = Case scrut case_bndr (exprType body) [Alt DEFAULT [] body] - -mkSingleAltCase :: CoreExpr -> Id -> AltCon -> [Var] -> CoreExpr -> CoreExpr --- Use this function if possible, when building a case, --- because it ensures that the type on the Case itself --- doesn't mention variables bound by the case --- See Note [Care with the type of a case expression] -mkSingleAltCase scrut case_bndr con bndrs body - = Case scrut case_bndr case_ty [Alt con bndrs body] - where - body_ty = exprType body - - case_ty -- See Note [Care with the type of a case expression] - | Just body_ty' <- occCheckExpand bndrs body_ty - = body_ty' - - | otherwise - = pprPanic "mkSingleAltCase" (ppr scrut $$ ppr bndrs $$ ppr body_ty) - -{- Note [Care with the type of a case expression] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider a phantom type synonym - type S a = Int -and we want to form the case expression - case x of K (a::*) -> (e :: S a) - -We must not make the type field of the case-expression (S a) because -'a' isn't in scope. Hence the call to occCheckExpand. This caused -issue #17056. - -NB: this situation can only arise with type synonyms, which can -falsely "mention" type variables that aren't "really there", and which -can be eliminated by expanding the synonym. - -Note [Binding coercions] -~~~~~~~~~~~~~~~~~~~~~~~~ -Consider binding a CoVar, c = e. Then, we must satisfy -Note [Core type and coercion invariant] in GHC.Core, -which allows only (Coercion co) on the RHS. - -************************************************************************ -* * - Operations over case alternatives -* * -************************************************************************ - -The default alternative must be first, if it exists at all. -This makes it easy to find, though it makes matching marginally harder. --} - --- | Extract the default case alternative -findDefault :: [Alt b] -> ([Alt b], Maybe (Expr b)) -findDefault (Alt DEFAULT args rhs : alts) = assert (null args) (alts, Just rhs) -findDefault alts = (alts, Nothing) - -addDefault :: [Alt b] -> Maybe (Expr b) -> [Alt b] -addDefault alts Nothing = alts -addDefault alts (Just rhs) = Alt DEFAULT [] rhs : alts - -isDefaultAlt :: Alt b -> Bool -isDefaultAlt (Alt DEFAULT _ _) = True -isDefaultAlt _ = False - --- | Find the case alternative corresponding to a particular --- constructor: panics if no such constructor exists -findAlt :: AltCon -> [Alt b] -> Maybe (Alt b) - -- A "Nothing" result *is* legitimate - -- See Note [Unreachable code] -findAlt con alts - = case alts of - (deflt@(Alt DEFAULT _ _):alts) -> go alts (Just deflt) - _ -> go alts Nothing - where - go [] deflt = deflt - go (alt@(Alt con1 _ _) : alts) deflt - = case con `cmpAltCon` con1 of - LT -> deflt -- Missed it already; the alts are in increasing order - EQ -> Just alt - GT -> assert (not (con1 == DEFAULT)) $ go alts deflt - -{- Note [Unreachable code] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -It is possible (although unusual) for GHC to find a case expression -that cannot match. For example: - - data Col = Red | Green | Blue - x = Red - f v = case x of - Red -> ... - _ -> ...(case x of { Green -> e1; Blue -> e2 })... - -Suppose that for some silly reason, x isn't substituted in the case -expression. (Perhaps there's a NOINLINE on it, or profiling SCC stuff -gets in the way; cf #3118.) Then the full-laziness pass might produce -this - - x = Red - lvl = case x of { Green -> e1; Blue -> e2 }) - f v = case x of - Red -> ... - _ -> ...lvl... - -Now if x gets inlined, we won't be able to find a matching alternative -for 'Red'. That's because 'lvl' is unreachable. So rather than crashing -we generate (error "Inaccessible alternative"). - -Similar things can happen (augmented by GADTs) when the Simplifier -filters down the matching alternatives in GHC.Core.Opt.Simplify.rebuildCase. --} - ---------------------------------- -mergeAlts :: [Alt a] -> [Alt a] -> [Alt a] --- ^ Merge alternatives preserving order; alternatives in --- the first argument shadow ones in the second -mergeAlts [] as2 = as2 -mergeAlts as1 [] = as1 -mergeAlts (a1:as1) (a2:as2) - = case a1 `cmpAlt` a2 of - LT -> a1 : mergeAlts as1 (a2:as2) - EQ -> a1 : mergeAlts as1 as2 -- Discard a2 - GT -> a2 : mergeAlts (a1:as1) as2 - - ---------------------------------- -trimConArgs :: AltCon -> [CoreArg] -> [CoreArg] --- ^ Given: --- --- > case (C a b x y) of --- > C b x y -> ... --- --- We want to drop the leading type argument of the scrutinee --- leaving the arguments to match against the pattern - -trimConArgs DEFAULT args = assert (null args) [] -trimConArgs (LitAlt _) args = assert (null args) [] -trimConArgs (DataAlt dc) args = dropList (dataConUnivTyVars dc) args - -filterAlts :: TyCon -- ^ Type constructor of scrutinee's type (used to prune possibilities) - -> [Type] -- ^ And its type arguments - -> [AltCon] -- ^ 'imposs_cons': constructors known to be impossible due to the form of the scrutinee - -> [Alt b] -- ^ Alternatives - -> ([AltCon], [Alt b]) - -- Returns: - -- 1. Constructors that will never be encountered by the - -- *default* case (if any). A superset of imposs_cons - -- 2. The new alternatives, trimmed by - -- a) remove imposs_cons - -- b) remove constructors which can't match because of GADTs - -- - -- NB: the final list of alternatives may be empty: - -- This is a tricky corner case. If the data type has no constructors, - -- which GHC allows, or if the imposs_cons covers all constructors (after taking - -- account of GADTs), then no alternatives can match. - -- - -- If callers need to preserve the invariant that there is always at least one branch - -- in a "case" statement then they will need to manually add a dummy case branch that just - -- calls "error" or similar. -filterAlts _tycon inst_tys imposs_cons alts - = imposs_deflt_cons `seqList` - (imposs_deflt_cons, addDefault trimmed_alts maybe_deflt) - -- Very important to force `imposs_deflt_cons` as that forces `alt_cons`, which - -- is essentially as retaining `alts_wo_default` or any `Alt b` for that matter - -- leads to a huge space leak (see #22102 and !8896) - where - (alts_wo_default, maybe_deflt) = findDefault alts - alt_cons = [con | Alt con _ _ <- alts_wo_default] - - trimmed_alts = filterOut (impossible_alt inst_tys) alts_wo_default - - imposs_cons_set = Set.fromList imposs_cons - imposs_deflt_cons = - imposs_cons ++ filterOut (`Set.member` imposs_cons_set) alt_cons - -- "imposs_deflt_cons" are handled - -- EITHER by the context, - -- OR by a non-DEFAULT branch in this case expression. - - impossible_alt :: [Type] -> Alt b -> Bool - impossible_alt _ (Alt con _ _) | con `Set.member` imposs_cons_set = True - impossible_alt inst_tys (Alt (DataAlt con) _ _) = dataConCannotMatch inst_tys con - impossible_alt _ _ = False - --- | Refine the default alternative to a 'DataAlt', if there is a unique way to do so. --- See Note [Refine DEFAULT case alternatives] -refineDefaultAlt :: [Unique] -- ^ Uniques for constructing new binders - -> Mult -- ^ Multiplicity annotation of the case expression - -> TyCon -- ^ Type constructor of scrutinee's type - -> [Type] -- ^ Type arguments of scrutinee's type - -> [AltCon] -- ^ Constructors that cannot match the DEFAULT (if any) - -> [CoreAlt] - -> (Bool, [CoreAlt]) -- ^ 'True', if a default alt was replaced with a 'DataAlt' -refineDefaultAlt us mult tycon tys imposs_deflt_cons all_alts - | Alt DEFAULT _ rhs : rest_alts <- all_alts - , isAlgTyCon tycon -- It's a data type, tuple, or unboxed tuples. - , not (isNewTyCon tycon) -- Exception 1 in Note [Refine DEFAULT case alternatives] - , not (isTypeDataTyCon tycon) -- Exception 2 in Note [Refine DEFAULT case alternatives] - , Just all_cons <- tyConDataCons_maybe tycon - , let imposs_data_cons = mkUniqSet [con | DataAlt con <- imposs_deflt_cons] - -- We now know it's a data type, so we can use - -- UniqSet rather than Set (more efficient) - impossible con = con `elementOfUniqSet` imposs_data_cons - || dataConCannotMatch tys con - = case filterOut impossible all_cons of - -- Eliminate the default alternative - -- altogether if it can't match: - [] -> (False, rest_alts) - - -- It matches exactly one constructor, so fill it in: - [con] -> (True, mergeAlts rest_alts [Alt (DataAlt con) (ex_tvs ++ arg_ids) rhs]) - -- We need the mergeAlts to keep the alternatives in the right order - where - (ex_tvs, arg_ids) = dataConRepInstPat us mult con tys - - -- It matches more than one, so do nothing - _ -> (False, all_alts) - - | debugIsOn, isAlgTyCon tycon, null (tyConDataCons tycon) - , not (isFamilyTyCon tycon || isAbstractTyCon tycon) - -- Check for no data constructors - -- This can legitimately happen for abstract types and type families, - -- so don't report that - = (False, all_alts) - - | otherwise -- The common case - = (False, all_alts) - -{- Note [Refine DEFAULT case alternatives] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -refineDefaultAlt replaces the DEFAULT alt with a constructor if there -is one possible value it could be. - -The simplest example being - foo :: () -> () - foo x = case x of !_ -> () -which rewrites to - foo :: () -> () - foo x = case x of () -> () - -There are two reasons in general why replacing a DEFAULT alternative -with a specific constructor is desirable. - -1. We can simplify inner expressions. For example - - data Foo = Foo1 () - - test :: Foo -> () - test x = case x of - DEFAULT -> mid (case x of - Foo1 x1 -> x1) - - refineDefaultAlt fills in the DEFAULT here with `Foo ip1` and then - x becomes bound to `Foo ip1` so is inlined into the other case - which causes the KnownBranch optimisation to kick in. If we don't - refine DEFAULT to `Foo ip1`, we are left with both case expressions. - -2. combineIdenticalAlts does a better job. For example (Simon Jacobi) - data D = C0 | C1 | C2 - - case e of - DEFAULT -> e0 - C0 -> e1 - C1 -> e1 - - When we apply combineIdenticalAlts to this expression, it can't - combine the alts for C0 and C1, as we already have a default case. - But if we apply refineDefaultAlt first, we get - case e of - C0 -> e1 - C1 -> e1 - C2 -> e0 - and combineIdenticalAlts can turn that into - case e of - DEFAULT -> e1 - C2 -> e0 - - It isn't obvious that refineDefaultAlt does this but if you look - at its one call site in GHC.Core.Opt.Simplify.Utils then the - `imposs_deflt_cons` argument is populated with constructors which - are matched elsewhere. - -There are two exceptions where we avoid refining a DEFAULT case: - -* Exception 1: Newtypes - - We can have a newtype, if we are just doing an eval: - - case x of { DEFAULT -> e } - - And we don't want to fill in a default for them! - -* Exception 2: `type data` declarations - - The data constructors for a `type data` declaration (see - Note [Type data declarations] in GHC.Rename.Module) do not exist at the - value level. Nevertheless, it is possible to strictly evaluate a value - whose type is a `type data` declaration. Test case - type-data/should_compile/T2294b.hs contains an example: - - type data T a where - A :: T Int - - f :: T a -> () - f !x = () - - We want to generate the following Core for f: - - f = \(@a) (x :: T a) -> - case x of - __DEFAULT -> () - - Namely, we do _not_ want to match on `A`, as it doesn't exist at the value - level! - -Note [Combine identical alternatives] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -If several alternatives are identical, merge them into a single -DEFAULT alternative. I've occasionally seen this making a big -difference: - - case e of =====> case e of - C _ -> f x D v -> ....v.... - D v -> ....v.... DEFAULT -> f x - DEFAULT -> f x - -The point is that we merge common RHSs, at least for the DEFAULT case. -[One could do something more elaborate but I've never seen it needed.] -To avoid an expensive test, we just merge branches equal to the *first* -alternative; this picks up the common cases - a) all branches equal - b) some branches equal to the DEFAULT (which occurs first) - -The case where Combine Identical Alternatives transformation showed up -was like this (base/Foreign/C/Err/Error.hs): - - x | p `is` 1 -> e1 - | p `is` 2 -> e2 - ...etc... - -where @is@ was something like - - p `is` n = p /= (-1) && p == n - -This gave rise to a horrible sequence of cases - - case p of - (-1) -> $j p - 1 -> e1 - DEFAULT -> $j p - -and similarly in cascade for all the join points! - -Note [Combine identical alternatives: wrinkles] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -* It's important that we try to combine alternatives *before* - simplifying them, rather than after. Reason: because - Simplify.simplAlt may zap the occurrence info on the binders in the - alternatives, which in turn defeats combineIdenticalAlts use of - isDeadBinder (see #7360). - - You can see this in the call to combineIdenticalAlts in - GHC.Core.Opt.Simplify.Utils.prepareAlts. Here the alternatives have type InAlt - (the "In" meaning input) rather than OutAlt. - -* combineIdenticalAlts does not work well for nullary constructors - case x of y - [] -> f [] - (_:_) -> f y - Here we won't see that [] and y are the same. Sigh! This problem - is solved in CSE, in GHC.Core.Opt.CSE.combineAlts, which does a better version - of combineIdenticalAlts. But sadly it doesn't have the occurrence info we have - here. - See Note [Combine case alts: awkward corner] in GHC.Core.Opt.CSE). - -Note [Care with impossible-constructors when combining alternatives] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose we have (#10538) - data T = A | B | C | D - - case x::T of (Imposs-default-cons {A,B}) - DEFAULT -> e1 - A -> e2 - B -> e1 - -When calling combineIdentialAlts, we'll have computed that the -"impossible constructors" for the DEFAULT alt is {A,B}, since if x is -A or B we'll take the other alternatives. But suppose we combine B -into the DEFAULT, to get - - case x::T of (Imposs-default-cons {A}) - DEFAULT -> e1 - A -> e2 - -Then we must be careful to trim the impossible constructors to just {A}, -else we risk compiling 'e1' wrong! - -Not only that, but we take care when there is no DEFAULT beforehand, -because we are introducing one. Consider - - case x of (Imposs-default-cons {A,B,C}) - A -> e1 - B -> e2 - C -> e1 - -Then when combining the A and C alternatives we get - - case x of (Imposs-default-cons {B}) - DEFAULT -> e1 - B -> e2 - -Note that we have a new DEFAULT branch that we didn't have before. So -we need delete from the "impossible-default-constructors" all the -known-con alternatives that we have eliminated. (In #11172 we -missed the first one.) - --} - -combineIdenticalAlts :: [AltCon] -- Constructors that cannot match DEFAULT - -> [CoreAlt] - -> (Bool, -- True <=> something happened - [AltCon], -- New constructors that cannot match DEFAULT - [CoreAlt]) -- New alternatives --- See Note [Combine identical alternatives] --- True <=> we did some combining, result is a single DEFAULT alternative -combineIdenticalAlts imposs_deflt_cons (Alt con1 bndrs1 rhs1 : rest_alts) - | all isDeadBinder bndrs1 -- Remember the default - , not (null elim_rest) -- alternative comes first - = (True, imposs_deflt_cons', deflt_alt : filtered_rest) - where - (elim_rest, filtered_rest) = partition identical_to_alt1 rest_alts - deflt_alt = Alt DEFAULT [] (mkTicks (concat tickss) rhs1) - - -- See Note [Care with impossible-constructors when combining alternatives] - imposs_deflt_cons' = imposs_deflt_cons `minusList` elim_cons - elim_cons = elim_con1 ++ map (\(Alt con _ _) -> con) elim_rest - elim_con1 = case con1 of -- Don't forget con1! - DEFAULT -> [] - _ -> [con1] - - cheapEqTicked e1 e2 = cheapEqExpr' tickishFloatable e1 e2 - identical_to_alt1 (Alt _con bndrs rhs) - = all isDeadBinder bndrs && rhs `cheapEqTicked` rhs1 - tickss = map (\(Alt _ _ rhs) -> stripTicksT tickishFloatable rhs) elim_rest - -combineIdenticalAlts imposs_cons alts - = (False, imposs_cons, alts) - --- Scales the multiplicity of the binders of a list of case alternatives. That --- is, in [C x1…xn -> u], the multiplicity of x1…xn is scaled. -scaleAltsBy :: Mult -> [CoreAlt] -> [CoreAlt] -scaleAltsBy w alts = map scaleAlt alts - where - scaleAlt :: CoreAlt -> CoreAlt - scaleAlt (Alt con bndrs rhs) = Alt con (map scaleBndr bndrs) rhs - - scaleBndr :: CoreBndr -> CoreBndr - scaleBndr b = scaleVarBy w b - - -{- ********************************************************************* -* * - exprIsTrivial -* * -************************************************************************ - -Note [exprIsTrivial] -~~~~~~~~~~~~~~~~~~~~ -@exprIsTrivial@ is true of expressions we are unconditionally happy to - duplicate; simple variables and constants, and type - applications. Note that primop Ids aren't considered - trivial unless - -Note [Variables are trivial] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -There used to be a gruesome test for (hasNoBinding v) in the -Var case: - exprIsTrivial (Var v) | hasNoBinding v = idArity v == 0 -The idea here is that a constructor worker, like \$wJust, is -really short for (\x -> \$wJust x), because \$wJust has no binding. -So it should be treated like a lambda. Ditto unsaturated primops. -But now constructor workers are not "have-no-binding" Ids. And -completely un-applied primops and foreign-call Ids are sufficiently -rare that I plan to allow them to be duplicated and put up with -saturating them. - -Note [Tick trivial] -~~~~~~~~~~~~~~~~~~~ -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. - -Note [Empty case is trivial] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The expression (case (x::Int) Bool of {}) is just a type-changing -case used when we are sure that 'x' will not return. See -Note [Empty case alternatives] in GHC.Core. - -If the scrutinee is trivial, then so is the whole expression; and the -CoreToSTG pass in fact drops the case expression leaving only the -scrutinee. - -Having more trivial expressions is good. Moreover, if we don't treat -it as trivial we may land up with let-bindings like - let v = case x of {} in ... -and after CoreToSTG that gives - let v = x in ... -and that confuses the code generator (#11155). So best to kill -it off at source. --} - -{-# INLINE trivial_expr_fold #-} -trivial_expr_fold :: (Id -> r) -> (Literal -> r) -> r -> r -> CoreExpr -> r --- ^ The worker function for Note [exprIsTrivial] and Note [getIdFromTrivialExpr] --- This is meant to have the code of both functions in one place and make it --- easy to derive custom predicates. --- --- (trivial_expr_fold k_id k_triv k_not_triv e) --- * returns (k_id x) if `e` is a variable `x` (with trivial wrapping) --- * returns (k_lit x) if `e` is a trivial literal `l` (with trivial wrapping) --- * returns k_triv if `e` is a literal, type, or coercion (with trivial wrapping) --- * returns k_not_triv otherwise --- --- where "trivial wrapping" is --- * Type application or abstraction --- * Ticks other than `tickishIsCode` --- * `case e of {}` an empty case -trivial_expr_fold k_id k_lit k_triv k_not_triv = go - where - 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 (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 _ = k_not_triv - -exprIsTrivial :: CoreExpr -> Bool -exprIsTrivial e = trivial_expr_fold (const True) (const True) True False e - -{- -Note [getIdFromTrivialExpr] -~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When substituting in a breakpoint we need to strip away the type cruft -from a trivial expression and get back to the Id. The invariant is -that the expression we're substituting was originally trivial -according to exprIsTrivial, AND the expression is not a literal. -See Note [substTickish] for how breakpoint substitution preserves -this extra invariant. - -We also need this functionality in CorePrep to extract out Id of a -function which we are saturating. However, in this case we don't know -if the variable actually refers to a literal; thus we use -'getIdFromTrivialExpr_maybe' to handle this case. See test -T12076lit for an example where this matters. --} - -getIdFromTrivialExpr :: HasDebugCallStack => CoreExpr -> Id --- See Note [getIdFromTrivialExpr] -getIdFromTrivialExpr e = trivial_expr_fold id (const panic) panic panic e - where - panic = pprPanic "getIdFromTrivialExpr" (ppr e) - -getIdFromTrivialExpr_maybe :: CoreExpr -> Maybe Id -getIdFromTrivialExpr_maybe e = trivial_expr_fold Just (const Nothing) Nothing Nothing e - -{- ********************************************************************* -* * - exprIsDupable -* * -************************************************************************ - -Note [exprIsDupable] -~~~~~~~~~~~~~~~~~~~~ -@exprIsDupable@ is true of expressions that can be duplicated at a modest - cost in code size. This will only happen in different case - branches, so there's no issue about duplicating work. - - That is, exprIsDupable returns True of (f x) even if - f is very very expensive to call. - - Its only purpose is to avoid fruitless let-binding - and then inlining of case join points --} - -exprIsDupable :: Platform -> CoreExpr -> Bool -exprIsDupable platform e - = isJust (go dupAppSize e) - where - go :: Int -> CoreExpr -> Maybe Int - go n (Type {}) = Just n - go n (Coercion {}) = Just n - go n (Var {}) = decrement n - go n (Tick _ e) = go n e - go n (Cast e _) = go n e - go n (App f a) | Just n' <- go n a = go n' f - go n (Lit lit) | litIsDupable platform lit = decrement n - go _ _ = Nothing - - decrement :: Int -> Maybe Int - decrement 0 = Nothing - decrement n = Just (n-1) - -dupAppSize :: Int -dupAppSize = 8 -- Size of term we are prepared to duplicate - -- This is *just* big enough to make test MethSharing - -- inline enough join points. Really it should be - -- smaller, and could be if we fixed #4960. - -{- -************************************************************************ -* * - exprIsCheap, exprIsExpandable -* * -************************************************************************ - -Note [exprIsWorkFree] -~~~~~~~~~~~~~~~~~~~~~ -exprIsWorkFree is used when deciding whether to inline something; we -don't inline it if doing so might duplicate work, by peeling off a -complete copy of the expression. Here we do not want even to -duplicate a primop (#5623): - eg let x = a #+ b in x +# x - we do not want to inline/duplicate x - -Previously we were a bit more liberal, which led to the primop-duplicating -problem. However, being more conservative did lead to a big regression in -one nofib benchmark, wheel-sieve1. The situation looks like this: - - let noFactor_sZ3 :: GHC.Types.Int -> GHC.Types.Bool - noFactor_sZ3 = case s_adJ of _ { GHC.Types.I# x_aRs -> - case GHC.Prim.<=# x_aRs 2 of _ { - GHC.Types.False -> notDivBy ps_adM qs_adN; - GHC.Types.True -> lvl_r2Eb }} - go = \x. ...(noFactor (I# y))....(go x')... - -The function 'noFactor' is heap-allocated and then called. Turns out -that 'notDivBy' is strict in its THIRD arg, but that is invisible to -the caller of noFactor, which therefore cannot do w/w and -heap-allocates noFactor's argument. At the moment (May 12) we are just -going to put up with this, because the previous more aggressive inlining -(which treated 'noFactor' as work-free) was duplicating primops, which -in turn was making inner loops of array calculations runs slow (#5623) - -Note [Case expressions are work-free] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Are case-expressions work-free? Consider - let v = case x of (p,q) -> p - go = \y -> ...case v of ... -Should we inline 'v' at its use site inside the loop? At the moment -we do. I experimented with saying that case are *not* work-free, but -that increased allocation slightly. It's a fairly small effect, and at -the moment we go for the slightly more aggressive version which treats -(case x of ....) as work-free if the alternatives are. - -Moreover it improves arities of overloaded functions where -there is only dictionary selection (no construction) involved - -Note [exprIsCheap] -~~~~~~~~~~~~~~~~~~ -See also Note [Interaction of exprIsWorkFree and lone variables] in GHC.Core.Unfold - -@exprIsCheap@ looks at a Core expression and returns \tr{True} if -it is obviously in weak head normal form, or is cheap to get to WHNF. -Note that that's not the same as exprIsDupable; an expression might be -big, and hence not dupable, but still cheap. - -By ``cheap'' we mean a computation we're willing to: - push inside a lambda, or - inline at more than one place -That might mean it gets evaluated more than once, instead of being -shared. The main examples of things which aren't WHNF but are -``cheap'' are: - - * case e of - pi -> ei - (where e, and all the ei are cheap) - - * let x = e in b - (where e and b are cheap) - - * op x1 ... xn - (where op is a cheap primitive operator) - - * error "foo" - (because we are happy to substitute it inside a lambda) - -Notice that a variable is considered 'cheap': we can push it inside a lambda, -because sharing will make sure it is only evaluated once. - -Note [exprIsCheap and exprIsHNF] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Note that exprIsHNF does not imply exprIsCheap. Eg - let x = fac 20 in Just x -This responds True to exprIsHNF (you can discard a seq), but -False to exprIsCheap. - -Note [Arguments and let-bindings exprIsCheapX] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -What predicate should we apply to the argument of an application, or the -RHS of a let-binding? - -We used to say "exprIsTrivial arg" due to concerns about duplicating -nested constructor applications, but see #4978. So now we just recursively -use exprIsCheapX. - -We definitely want to treat let and app the same. The principle here is -that - let x = blah in f x -should behave equivalently to - f blah - -This in turn means that the 'letrec g' does not prevent eta expansion -in this (which it previously was): - f = \x. let v = case x of - True -> letrec g = \w. blah - in g - False -> \x. x - in \w. v True --} - --------------------- -exprIsWorkFree :: CoreExpr -> Bool -- See Note [exprIsWorkFree] -exprIsWorkFree e = exprIsCheapX isWorkFreeApp e - -exprIsCheap :: CoreExpr -> Bool -exprIsCheap e = exprIsCheapX isCheapApp e - -exprIsCheapX :: CheapAppFun -> CoreExpr -> Bool -{-# INLINE exprIsCheapX #-} --- allow specialization of exprIsCheap and exprIsWorkFree --- instead of having an unknown call to ok_app -exprIsCheapX ok_app e - = ok e - where - ok e = go 0 e - - -- n is the number of value arguments - go n (Var v) = ok_app v n - go _ (Lit {}) = True - go _ (Type {}) = True - go _ (Coercion {}) = True - go n (Cast e _) = go n e - go n (Case scrut _ _ alts) = ok scrut && - and [ go n rhs | Alt _ _ rhs <- alts ] - 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 n (Let (NonRec _ r) e) = go n e && ok r - go n (Let (Rec prs) e) = 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... - - 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.) --} - -------------------------------------- -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 - -isWorkFreeApp :: CheapAppFun -isWorkFreeApp fn n_val_args - | n_val_args == 0 -- No value args - = True - | n_val_args < idArity fn -- Partial application - = True - | otherwise - = case idDetails fn of - DataConWorkId {} -> True - _ -> False - -isCheapApp :: CheapAppFun -isCheapApp fn n_val_args - | isWorkFreeApp fn n_val_args = True - | isDeadEndId fn = True -- See Note [isCheapApp: bottoming functions] - | otherwise - = case idDetails fn of - DataConWorkId {} -> True -- Actually handled by isWorkFreeApp - RecSelId {} -> n_val_args == 1 -- See Note [Record selection] - ClassOpId {} -> n_val_args == 1 - PrimOpId op _ -> primOpIsCheap op - _ -> False - -- In principle we should worry about primops - -- that return a type variable, since the result - -- might be applied to something, but I'm not going - -- to bother to check the number of args - -isExpandableApp :: CheapAppFun -isExpandableApp fn n_val_args - | isWorkFreeApp fn n_val_args = True - | otherwise - = case idDetails fn of - RecSelId {} -> n_val_args == 1 -- See Note [Record selection] - ClassOpId {} -> n_val_args == 1 - PrimOpId {} -> False - _ | isDeadEndId fn -> False - -- See Note [isExpandableApp: bottoming functions] - | isConLikeId fn -> True - | all_args_are_preds -> True - | otherwise -> False - - where - -- See if all the arguments are PredTys (implicit params or classes) - -- If so we'll regard it as expandable; see Note [Expandable overloadings] - all_args_are_preds = all_pred_args n_val_args (idType fn) - - all_pred_args n_val_args ty - | n_val_args == 0 - = True - - | Just (bndr, ty) <- splitPiTy_maybe ty - = case bndr of - Named {} -> all_pred_args n_val_args ty - Anon _ af -> isInvisibleFunArg af && all_pred_args (n_val_args-1) ty - - | otherwise - = False - -{- Note [isCheapApp: bottoming functions] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -I'm not sure why we have a special case for bottoming -functions in isCheapApp. Maybe we don't need it. - -Note [isExpandableApp: bottoming functions] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -It's important that isExpandableApp does not respond True to bottoming -functions. Recall undefined :: HasCallStack => a -Suppose isExpandableApp responded True to (undefined d), and we had: - - x = undefined - -Then Simplify.prepareRhs would ANF the RHS: - - d = - x = undefined d - -This is already bad: we gain nothing from having x bound to (undefined -var), unlike the case for data constructors. Worse, we get the -simplifier loop described in OccurAnal Note [Cascading inlines]. -Suppose x occurs just once; OccurAnal.occAnalNonRecRhs decides x will -certainly_inline; so we end up inlining d right back into x; but in -the end x doesn't inline because it is bottom (preInlineUnconditionally); -so the process repeats.. We could elaborate the certainly_inline logic -some more, but it's better just to treat bottoming bindings as -non-expandable, because ANFing them is a bad idea in the first place. - -Note [Record selection] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -I'm experimenting with making record selection -look cheap, so we will substitute it inside a -lambda. Particularly for dictionary field selection. - -BUT: Take care with (sel d x)! The (sel d) might be cheap, but -there's no guarantee that (sel d x) will be too. Hence (n_val_args == 1) - -Note [Expandable overloadings] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose the user wrote this - {-# RULE forall x. foo (negate x) = h x #-} - f x = ....(foo (negate x)).... -They'd expect the rule to fire. But since negate is overloaded, we might -get this: - f = \d -> let n = negate d in \x -> ...foo (n x)... -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. - - -************************************************************************ -* * - exprOkForSpeculation -* * -************************************************************************ --} - ------------------------------ --- | 'exprOkForSpeculation' returns True of an expression that is: --- --- * Safe to evaluate even if normal order eval might not --- evaluate the expression at all, or --- --- * 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 --- --- 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) --- --- For @exprOkForSideEffects@ the list is the same, but omitting (e). --- --- Note that --- exprIsHNF implies exprOkForSpeculation --- exprOkForSpeculation implies exprOkForSideEffects --- --- See Note [PrimOp can_fail and has_side_effects] in "GHC.Builtin.PrimOps" --- and Note [Transformations affected by can_fail and has_side_effects] --- --- As an example of the considerations in this test, consider: --- --- > let x = case y# +# 1# of { r# -> I# r# } --- > in E --- --- being translated to: --- --- > case y# +# 1# of { r# -> --- > let x = I# r# --- > in E --- > } --- --- 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. - -exprOkForSpeculation, exprOkForSideEffects :: CoreExpr -> Bool -exprOkForSpeculation = expr_ok fun_always_ok primOpOkForSpeculation -exprOkForSideEffects = expr_ok fun_always_ok primOpOkForSideEffects - -fun_always_ok :: Id -> Bool -fun_always_ok _ = True - --- | A special version of 'exprOkForSpeculation' used during --- Note [Speculative evaluation]. When the predicate arg `fun_ok` returns False --- for `b`, then `b` is never considered ok-for-spec. -exprOkForSpecEval :: (Id -> Bool) -> CoreExpr -> Bool -exprOkForSpecEval fun_ok = expr_ok fun_ok primOpOkForSpeculation - -expr_ok :: (Id -> Bool) -> (PrimOp -> Bool) -> CoreExpr -> Bool -expr_ok _ _ (Lit _) = True -expr_ok _ _ (Type _) = True -expr_ok _ _ (Coercion _) = True - -expr_ok fun_ok primop_ok (Var v) = app_ok fun_ok primop_ok v [] -expr_ok fun_ok primop_ok (Cast e _) = expr_ok fun_ok primop_ok e -expr_ok fun_ok primop_ok (Lam b e) - | isTyVar b = expr_ok fun_ok primop_ok e - | otherwise = True - --- Tick annotations that *tick* cannot be speculated, because these --- are meant to identify whether or not (and how often) the particular --- source expression was evaluated at runtime. -expr_ok fun_ok primop_ok (Tick tickish e) - | tickishCounts tickish = False - | 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. - -expr_ok fun_ok primop_ok (Case scrut bndr _ alts) - = -- See Note [exprOkForSpeculation: case expressions] - expr_ok fun_ok primop_ok scrut - && isUnliftedType (idType bndr) - -- OK to call isUnliftedType: binders always have a fixed RuntimeRep - && all (\(Alt _ _ rhs) -> expr_ok fun_ok primop_ok rhs) alts - && altsAreExhaustive alts - -expr_ok fun_ok primop_ok other_expr - | (expr, args) <- collectArgs other_expr - = case stripTicksTopE (not . tickishCounts) expr of - Var f -> - app_ok fun_ok primop_ok f args - - -- 'LitRubbish' is the only literal that can occur in the head of an - -- application and will not be matched by the above case (Var /= Lit). - -- See Note [How a rubbish literal can be the head of an application] - -- in GHC.Types.Literal - Lit lit | debugIsOn, not (isLitRubbish lit) - -> pprPanic "Non-rubbish lit in app head" (ppr lit) - | otherwise - -> True - - _ -> False - ------------------------------ -app_ok :: (Id -> Bool) -> (PrimOp -> Bool) -> Id -> [CoreExpr] -> Bool -app_ok fun_ok primop_ok fun args - | not (fun_ok fun) - = False -- This code path is only taken for Note [Speculative evaluation] - | otherwise - = case idDetails fun of - DFunId new_type -> not new_type - -- DFuns terminate, unless the dict is implemented - -- with a newtype in which case they may not - - 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 - - PrimOpId op _ - | primOpIsDiv op - , [arg1, Lit lit] <- args - -> not (isZeroLit lit) && expr_ok fun_ok primop_ok arg1 - -- Special case for dividing operations that fail - -- In general they are NOT ok-for-speculation - -- (which primop_ok will catch), but they ARE OK - -- if the divisor is definitely non-zero. - -- 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 - - _ -- Unlifted types - -- c.f. the Var case of exprIsHNF - | Just Unlifted <- typeLevity_maybe (idType fun) - -> assertPpr (n_val_args == 0) (ppr fun $$ ppr args) - True -- Our only unlifted types are Int# etc, so will have - -- no value args. The assert is just to check this. - -- 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] - | fun `hasKey` unsafeEqualityProofIdKey -> True - - | otherwise -> False - -- NB: even in the nullary case, do /not/ check - -- for evaluated-ness of the fun; - -- see Note [exprOkForSpeculation and evaluated variables] - where - n_val_args = valArgCount args - (arg_tys, _) = splitPiTys (idType fun) - - -- Used for arguments to primops and to partial applications - arg_ok :: PiTyVarBinder -> CoreExpr -> Bool - arg_ok (Named _) _ = True -- A type argument - arg_ok (Anon ty _) arg -- A term argument - | Just Lifted <- typeLevity_maybe (scaledThing ty) - = True -- See Note [Primops with lifted arguments] - | 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 -altsAreExhaustive (Alt con1 _ _ : alts) - = case con1 of - DEFAULT -> True - LitAlt {} -> False - DataAlt c -> alts `lengthIs` (tyConFamilySize (dataConTyCon c) - 1) - -- It is possible to have an exhaustive case that does not - -- enumerate all constructors, notably in a GADT match, but - -- we behave conservatively here -- I don't think it's important - -- enough to deserve special treatment - --- | Should we look past this tick when eta-expanding the given function? --- --- See Note [Ticks and mandatory eta expansion] --- Takes the function we are applying as argument. -etaExpansionTick :: Id -> GenTickish pass -> Bool -etaExpansionTick id t - = hasNoBinding id && - ( tickishFloatable t || isProfTick t ) - -{- Note [exprOkForSpeculation: case expressions] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -exprOkForSpeculation accepts very special case expressions. -Reason: (a ==# b) is ok-for-speculation, but the litEq rules -in GHC.Core.Opt.ConstantFold convert it (a ==# 3#) to - case a of { DEFAULT -> 0#; 3# -> 1# } -for excellent reasons described in - GHC.Core.Opt.ConstantFold Note [The litEq rule: converting equality to case]. -So, annoyingly, we want that case expression to be -ok-for-speculation too. Bother. - -But we restrict it sharply: - -* We restrict it to unlifted scrutinees. Consider this: - case x of y { - DEFAULT -> ... (let v::Int# = case y of { True -> e1 - ; False -> e2 } - in ...) ... - - Does the RHS of v satisfy the let-can-float invariant? Previously we said - yes, on the grounds that y is evaluated. But the binder-swap done - by GHC.Core.Opt.SetLevels would transform the inner alternative to - DEFAULT -> ... (let v::Int# = case x of { ... } - in ...) .... - which does /not/ satisfy the let-can-float invariant, because x is - not evaluated. See Note [Binder-swap during float-out] - in GHC.Core.Opt.SetLevels. To avoid this awkwardness it seems simpler - to stick to unlifted scrutinees where the issue does not - arise. - -* We restrict it to exhaustive alternatives. A non-exhaustive - case manifestly isn't ok-for-speculation. for example, - this is a valid program (albeit a slightly dodgy one) - let v = case x of { B -> ...; C -> ... } - in case x of - A -> ... - _ -> ...v...v.... - Should v be considered ok-for-speculation? Its scrutinee may be - evaluated, but the alternatives are incomplete so we should not - evaluate it strictly. - - Now, all this is for lifted types, but it'd be the same for any - finite unlifted type. We don't have many of them, but we might - add unlifted algebraic types in due course. - - ------ Historical note: #15696: -------- - Previously GHC.Core.Opt.SetLevels used exprOkForSpeculation to guide - floating of single-alternative cases; it now uses exprIsHNF - Note [Floating single-alternative cases]. - - But in those days, consider - case e of x { DEAFULT -> - ...(case x of y - A -> ... - _ -> ...(case (case x of { B -> p; C -> p }) of - I# r -> blah)... - If GHC.Core.Opt.SetLevels considers the inner nested case as - ok-for-speculation it can do case-floating (in GHC.Core.Opt.SetLevels). - So we'd float to: - case e of x { DEAFULT -> - case (case x of { B -> p; C -> p }) of I# r -> - ...(case x of y - A -> ... - _ -> ...blah...)... - which is utterly bogus (seg fault); see #5453. - ------ Historical note: #3717: -------- - foo :: Int -> Int - foo 0 = 0 - foo n = (if n < 5 then 1 else 2) `seq` foo (n-1) - -In earlier GHCs, we got this: - T.$wfoo = - \ (ww :: GHC.Prim.Int#) -> - case ww of ds { - __DEFAULT -> case (case <# ds 5 of _ { - GHC.Types.False -> lvl1; - GHC.Types.True -> lvl}) - of _ { __DEFAULT -> - T.$wfoo (GHC.Prim.-# ds_XkE 1) }; - 0 -> 0 } - -Before join-points etc we could only get rid of two cases (which are -redundant) by recognising that the (case <# ds 5 of { ... }) is -ok-for-speculation, even though it has /lifted/ type. But now join -points do the job nicely. -------- 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: - * 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? - -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... } - -And now the expression does not obey the let-can-float invariant! Yikes! -Moreover we really might float (dataToTag# 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. - -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 -* * -************************************************************************ --} - --- Note [exprIsHNF] See also Note [exprIsCheap and exprIsHNF] --- ~~~~~~~~~~~~~~~~ --- | 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: --- --- > case x of _ -> e --- --- into: --- --- > e --- --- and to decide whether it's safe to discard a 'seq'. --- --- 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: --- --- > (:) (f x) (map f xs) --- > map (...redex...) --- --- because 'seq' on such things completes immediately. --- --- For unlifted argument types, we have to be careful: --- --- > C (f x :: Int#) --- --- Suppose @f x@ diverges; then @C (f x)@ is not a value. --- We check for this using needsCaseBinding below -exprIsHNF :: CoreExpr -> Bool -- True => Value-lambda, constructor, PAP -exprIsHNF = exprIsHNFlike isDataConWorkId isEvaldUnfolding - --- | Similar to 'exprIsHNF' but includes CONLIKE functions as well as --- data constructors. Conlike arguments are considered interesting by the --- inliner. -exprIsConLike :: CoreExpr -> Bool -- True => lambda, conlike, PAP -exprIsConLike = exprIsHNFlike isConLikeId isConLikeUnfolding - --- | Returns true for values or value-like expressions. These are lambdas, --- constructors / CONLIKE functions (as determined by the function argument) --- or PAPs. --- -exprIsHNFlike :: HasDebugCallStack => (Var -> Bool) -> (Unfolding -> Bool) -> CoreExpr -> Bool -exprIsHNFlike is_con is_con_unf = is_hnf_like - 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 - || is_con_unf (idUnfolding v) - -- Check the thing's unfolding; it might be bound to a value - -- or to a guaranteed-evaluated variable (isEvaldUnfolding) - -- Contrast with Note [exprOkForSpeculation and evaluated variables] - -- We don't look through loop breakers here, which is a bit conservative - -- but otherwise I worry that if an Id's unfolding is just itself, - -- we could get an infinite loop - || ( typeLevity_maybe (idType v) == Just Unlifted ) - -- Unlifted binders are always evaluated (#20140) - - is_hnf_like (Lit l) = not (isLitRubbish l) - -- Regarding a LitRubbish as ConLike leads to unproductive inlining in - -- WWRec, see #20035 - is_hnf_like (Type _) = True -- Types are honorary Values; - -- we don't mind copying them - is_hnf_like (Coercion _) = True -- Same for coercions - is_hnf_like (Lam b e) = isRuntimeVar b || is_hnf_like e - is_hnf_like (Tick tickish e) = not (tickishCounts tickish) - && is_hnf_like e - -- 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 - | 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 _ = 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 - - id_app_is_value id n_val_args - = is_con id - || idArity id > n_val_args - -{- -Note [exprIsHNF Tick] -~~~~~~~~~~~~~~~~~~~~~ -We can discard source annotations on HNFs as long as they aren't -tick-like: - - scc c (\x . e) => \x . e - scc c (C x1..xn) => C x1..xn - -So we regard these as HNFs. Tick annotations that tick are not -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. --} - --- | Can we bind this 'CoreExpr' at the top level? -exprIsTopLevelBindable :: CoreExpr -> Type -> Bool --- See Note [Core top-level string literals] --- Precondition: exprType expr = ty --- Top-level literal strings can't even be wrapped in ticks --- see Note [Core top-level string literals] in "GHC.Core" -exprIsTopLevelBindable expr ty - = not (mightBeUnliftedType ty) - -- Note that 'expr' may not have a fixed runtime representation here, - -- consequently we must use 'mightBeUnliftedType' rather than 'isUnliftedType', - -- as the latter would panic. - || exprIsTickedString expr - --- | Check if the expression is zero or more Ticks wrapped around a literal --- string. -exprIsTickedString :: CoreExpr -> Bool -exprIsTickedString = isJust . exprIsTickedString_maybe - --- | Extract a literal string from an expression that is zero or more Ticks --- wrapped around a literal string. Returns Nothing if the expression has a --- different shape. --- Used to "look through" Ticks in places that need to handle literal strings. -exprIsTickedString_maybe :: CoreExpr -> Maybe ByteString -exprIsTickedString_maybe (Lit (LitString bs)) = Just bs -exprIsTickedString_maybe (Tick t e) - -- we don't tick literals with CostCentre ticks, compare to mkTick - | tickishPlace t == PlaceCostCentre = Nothing - | otherwise = exprIsTickedString_maybe e -exprIsTickedString_maybe _ = Nothing - -{- -************************************************************************ -* * - Instantiating data constructors -* * -************************************************************************ - -These InstPat functions go here to avoid circularity between DataCon and Id --} - -dataConRepInstPat :: [Unique] -> Mult -> DataCon -> [Type] -> ([TyCoVar], [Id]) -dataConRepFSInstPat :: [FastString] -> [Unique] -> Mult -> DataCon -> [Type] -> ([TyCoVar], [Id]) - -dataConRepInstPat = dataConInstPat (repeat ((fsLit "ipv"))) -dataConRepFSInstPat = dataConInstPat - -dataConInstPat :: [FastString] -- A long enough list of FSs to use for names - -> [Unique] -- An equally long list of uniques, at least one for each binder - -> Mult -- The multiplicity annotation of the case expression: scales the multiplicity of variables - -> DataCon - -> [Type] -- Types to instantiate the universally quantified tyvars - -> ([TyCoVar], [Id]) -- Return instantiated variables --- dataConInstPat arg_fun fss us mult con inst_tys returns a tuple --- (ex_tvs, arg_ids), --- --- ex_tvs are intended to be used as binders for existential type args --- --- arg_ids are intended to be used as binders for value arguments, --- and their types have been instantiated with inst_tys and ex_tys --- The arg_ids include both evidence and --- programmer-specified arguments (both after rep-ing) --- --- Example. --- The following constructor T1 --- --- data T a where --- T1 :: forall b. Int -> b -> T(a,b) --- ... --- --- has representation type --- forall a. forall a1. forall b. (a ~ (a1,b)) => --- Int -> b -> T a --- --- dataConInstPat fss us T1 (a1',b') will return --- --- ([a1'', b''], [c :: (a1', b')~(a1'', b''), x :: Int, y :: b'']) --- --- where the double-primed variables are created with the FastStrings and --- Uniques given as fss and us -dataConInstPat fss uniqs mult con inst_tys - = assert (univ_tvs `equalLength` inst_tys) $ - (ex_bndrs, arg_ids) - where - univ_tvs = dataConUnivTyVars con - ex_tvs = dataConExTyCoVars con - arg_tys = dataConRepArgTys con - arg_strs = dataConRepStrictness con -- 1-1 with arg_tys - n_ex = length ex_tvs - - -- split the Uniques and FastStrings - (ex_uniqs, id_uniqs) = splitAt n_ex uniqs - (ex_fss, id_fss) = splitAt n_ex fss - - -- Make the instantiating substitution for universals - univ_subst = zipTvSubst univ_tvs inst_tys - - -- Make existential type variables, applying and extending the substitution - (full_subst, ex_bndrs) = mapAccumL mk_ex_var univ_subst - (zip3 ex_tvs ex_fss ex_uniqs) - - mk_ex_var :: Subst -> (TyCoVar, FastString, Unique) -> (Subst, TyCoVar) - mk_ex_var subst (tv, fs, uniq) = (Type.extendTCvSubstWithClone subst tv - new_tv - , new_tv) - where - new_tv | isTyVar tv - = mkTyVar (mkSysTvName uniq fs) kind - | otherwise - = mkCoVar (mkSystemVarName uniq fs) kind - kind = Type.substTyUnchecked subst (varType tv) - - -- Make value vars, instantiating types - arg_ids = zipWith4 mk_id_var id_uniqs id_fss arg_tys arg_strs - mk_id_var uniq fs (Scaled m ty) str - = setCaseBndrEvald str $ -- See Note [Mark evaluated arguments] - mkLocalIdOrCoVar name (mult `mkMultMul` m) (Type.substTy full_subst ty) - where - name = mkInternalName uniq (mkVarOccFS fs) noSrcSpan - -{- -Note [Mark evaluated arguments] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When pattern matching on a constructor with strict fields, the binder -can have an 'evaldUnfolding'. Moreover, it *should* have one, so that -when loading an interface file unfolding like: - data T = MkT !Int - f x = case x of { MkT y -> let v::Int# = case y of I# n -> n+1 - in ... } -we don't want Lint to complain. The 'y' is evaluated, so the -case in the RHS of the binding for 'v' is fine. But only if we -*know* that 'y' is evaluated. - -c.f. add_evals in GHC.Core.Opt.Simplify.simplAlt - -************************************************************************ -* * - Equality -* * -************************************************************************ --} - --- | A cheap equality test which bales out fast! --- If it returns @True@ the arguments are definitely equal, --- otherwise, they may or may not be equal. -cheapEqExpr :: Expr b -> Expr b -> Bool -cheapEqExpr = cheapEqExpr' (const False) - --- | Cheap expression equality test, can ignore ticks by type. -cheapEqExpr' :: (CoreTickish -> Bool) -> Expr b -> Expr b -> Bool -{-# INLINE cheapEqExpr' #-} -cheapEqExpr' ignoreTick e1 e2 - = go e1 e2 - where - go (Var v1) (Var v2) = v1 == v2 - go (Lit lit1) (Lit lit2) = lit1 == lit2 - go (Type t1) (Type t2) = t1 `eqType` t2 - go (Coercion c1) (Coercion c2) = c1 `eqCoercion` c2 - go (App f1 a1) (App f2 a2) = f1 `go` f2 && a1 `go` a2 - go (Cast e1 t1) (Cast e2 t2) = e1 `go` e2 && t1 `eqCoercion` t2 - - go (Tick t1 e1) e2 | ignoreTick t1 = go e1 e2 - go e1 (Tick t2 e2) | ignoreTick t2 = go e1 e2 - go (Tick t1 e1) (Tick t2 e2) = t1 == t2 && e1 `go` e2 - - go _ _ = False - - - --- Used by diffBinds, which is itself only used in GHC.Core.Lint.lintAnnots -eqTickish :: RnEnv2 -> CoreTickish -> CoreTickish -> Bool -eqTickish env (Breakpoint lext lid lids) (Breakpoint rext rid rids) - = lid == rid && - map (rnOccL env) lids == map (rnOccR env) rids && - lext == rext -eqTickish _ l r = l == r - --- | Finds differences between core bindings, see @diffExpr@. --- --- The main problem here is that while we expect the binds to have the --- same order in both lists, this is not guaranteed. To do this --- properly we'd either have to do some sort of unification or check --- all possible mappings, which would be seriously expensive. So --- instead we simply match single bindings as far as we can. This --- leaves us just with mutually recursive and/or mismatching bindings, --- which we then speculatively match by ordering them. It's by no means --- perfect, but gets the job done well enough. --- --- Only used in GHC.Core.Lint.lintAnnots -diffBinds :: Bool -> RnEnv2 -> [(Var, CoreExpr)] -> [(Var, CoreExpr)] - -> ([SDoc], RnEnv2) -diffBinds top env binds1 = go (length binds1) env binds1 - where go _ env [] [] - = ([], env) - go _fuel env [] binds2 - -- No binds remaining to compare on the left? Bail out early. - = (warn env [] binds2, env) - go _fuel env binds1 [] - -- No binds remaining to compare on the right? Bail out early. - = (warn env binds1 [], env) - go fuel env binds1@(bind1:_) binds2@(_:_) - -- Iterated over all binds without finding a match? Then - -- try speculatively matching binders by order. - | fuel == 0 - = if not $ env `inRnEnvL` fst bind1 - then let env' = uncurry (rnBndrs2 env) $ unzip $ - zip (sort $ map fst binds1) (sort $ map fst binds2) - in go (length binds1) env' binds1 binds2 - -- If we have already tried that, give up - else (warn env binds1 binds2, env) - go fuel env ((bndr1,expr1):binds1) binds2 - | let matchExpr (bndr,expr) = - (isTyVar bndr || not top || null (diffIdInfo env bndr bndr1)) && - null (diffExpr top (rnBndr2 env bndr1 bndr) expr1 expr) - - , (binds2l, (bndr2,_):binds2r) <- break matchExpr binds2 - = go (length binds1) (rnBndr2 env bndr1 bndr2) - binds1 (binds2l ++ binds2r) - | otherwise -- No match, so push back (FIXME O(n^2)) - = go (fuel-1) env (binds1++[(bndr1,expr1)]) binds2 - - -- We have tried everything, but couldn't find a good match. So - -- now we just return the comparison results when we pair up - -- the binds in a pseudo-random order. - warn env binds1 binds2 = - concatMap (uncurry (diffBind env)) (zip binds1' binds2') ++ - unmatched "unmatched left-hand:" (drop l binds1') ++ - unmatched "unmatched right-hand:" (drop l binds2') - where binds1' = sortBy (comparing fst) binds1 - binds2' = sortBy (comparing fst) binds2 - l = min (length binds1') (length binds2') - unmatched _ [] = [] - unmatched txt bs = [text txt $$ ppr (Rec bs)] - diffBind env (bndr1,expr1) (bndr2,expr2) - | ds@(_:_) <- diffExpr top env expr1 expr2 - = locBind "in binding" bndr1 bndr2 ds - -- Special case for TyVar, which we checked were bound to the same types in - -- diffExpr, but don't have any IdInfo we would panic if called diffIdInfo. - -- These let-bound types are created temporarily by the simplifier but inlined - -- immediately. - | isTyVar bndr1 && isTyVar bndr2 - = [] - | otherwise - = diffIdInfo env bndr1 bndr2 - --- | Finds differences between core expressions, modulo alpha and --- renaming. Setting @top@ means that the @IdInfo@ of bindings will be --- checked for differences as well. -diffExpr :: Bool -> RnEnv2 -> CoreExpr -> CoreExpr -> [SDoc] -diffExpr _ env (Var v1) (Var v2) | rnOccL env v1 == rnOccR env v2 = [] -diffExpr _ _ (Lit lit1) (Lit lit2) | lit1 == lit2 = [] -diffExpr _ env (Type t1) (Type t2) | eqTypeX env t1 t2 = [] -diffExpr _ env (Coercion co1) (Coercion co2) - | eqCoercionX env co1 co2 = [] -diffExpr top env (Cast e1 co1) (Cast e2 co2) - | eqCoercionX env co1 co2 = diffExpr top env e1 e2 -diffExpr top env (Tick n1 e1) e2 - | not (tickishIsCode n1) = diffExpr top env e1 e2 -diffExpr top env e1 (Tick n2 e2) - | not (tickishIsCode n2) = diffExpr top env e1 e2 -diffExpr top env (Tick n1 e1) (Tick n2 e2) - | eqTickish env n1 n2 = diffExpr top env e1 e2 - -- The error message of failed pattern matches will contain - -- generated names, which are allowed to differ. -diffExpr _ _ (App (App (Var absent) _) _) - (App (App (Var absent2) _) _) - | isDeadEndId absent && isDeadEndId absent2 = [] -diffExpr top env (App f1 a1) (App f2 a2) - = diffExpr top env f1 f2 ++ diffExpr top env a1 a2 -diffExpr top env (Lam b1 e1) (Lam b2 e2) - | eqTypeX env (varType b1) (varType b2) -- False for Id/TyVar combination - = diffExpr top (rnBndr2 env b1 b2) e1 e2 -diffExpr top env (Let bs1 e1) (Let bs2 e2) - = let (ds, env') = diffBinds top env (flattenBinds [bs1]) (flattenBinds [bs2]) - in ds ++ diffExpr top env' e1 e2 -diffExpr top env (Case e1 b1 t1 a1) (Case e2 b2 t2 a2) - | equalLength a1 a2 && not (null a1) || eqTypeX env t1 t2 - -- See Note [Empty case alternatives] in GHC.Data.TrieMap - = diffExpr top env e1 e2 ++ concat (zipWith diffAlt a1 a2) - where env' = rnBndr2 env b1 b2 - diffAlt (Alt c1 bs1 e1) (Alt c2 bs2 e2) - | c1 /= c2 = [text "alt-cons " <> ppr c1 <> text " /= " <> ppr c2] - | otherwise = diffExpr top (rnBndrs2 env' bs1 bs2) e1 e2 -diffExpr _ _ e1 e2 - = [fsep [ppr e1, text "/=", ppr e2]] - --- | Find differences in @IdInfo@. We will especially check whether --- the unfoldings match, if present (see @diffUnfold@). -diffIdInfo :: RnEnv2 -> Var -> Var -> [SDoc] -diffIdInfo env bndr1 bndr2 - | arityInfo info1 == arityInfo info2 - && cafInfo info1 == cafInfo info2 - && oneShotInfo info1 == oneShotInfo info2 - && inlinePragInfo info1 == inlinePragInfo info2 - && occInfo info1 == occInfo info2 - && demandInfo info1 == demandInfo info2 - && callArityInfo info1 == callArityInfo info2 - = locBind "in unfolding of" bndr1 bndr2 $ - diffUnfold env (realUnfoldingInfo info1) (realUnfoldingInfo info2) - | otherwise - = locBind "in Id info of" bndr1 bndr2 - [fsep [pprBndr LetBind bndr1, text "/=", pprBndr LetBind bndr2]] - where info1 = idInfo bndr1; info2 = idInfo bndr2 - --- | Find differences in unfoldings. Note that we will not check for --- differences of @IdInfo@ in unfoldings, as this is generally --- redundant, and can lead to an exponential blow-up in complexity. -diffUnfold :: RnEnv2 -> Unfolding -> Unfolding -> [SDoc] -diffUnfold _ NoUnfolding NoUnfolding = [] -diffUnfold _ BootUnfolding BootUnfolding = [] -diffUnfold _ (OtherCon cs1) (OtherCon cs2) | cs1 == cs2 = [] -diffUnfold env (DFunUnfolding bs1 c1 a1) - (DFunUnfolding bs2 c2 a2) - | c1 == c2 && equalLength bs1 bs2 - = concatMap (uncurry (diffExpr False env')) (zip a1 a2) - where env' = rnBndrs2 env bs1 bs2 -diffUnfold env (CoreUnfolding t1 _ _ c1 g1) - (CoreUnfolding t2 _ _ c2 g2) - | c1 == c2 && g1 == g2 - = diffExpr False env t1 t2 -diffUnfold _ uf1 uf2 - = [fsep [ppr uf1, text "/=", ppr uf2]] - --- | Add location information to diff messages -locBind :: String -> Var -> Var -> [SDoc] -> [SDoc] -locBind loc b1 b2 diffs = map addLoc diffs - where addLoc d = d $$ nest 2 (parens (text loc <+> bindLoc)) - bindLoc | b1 == b2 = ppr b1 - | otherwise = ppr b1 <> char '/' <> ppr b2 - - -{- ********************************************************************* -* * -\subsection{Determining non-updatable right-hand-sides} -* * -************************************************************************ - -Top-level constructor applications can usually be allocated -statically, but they can't if the constructor, or any of the -arguments, come from another DLL (because we can't refer to static -labels in other DLLs). - -If this happens we simply make the RHS into an updatable thunk, -and 'execute' it rather than allocating it statically. --} - -{- -************************************************************************ -* * -\subsection{Type utilities} -* * -************************************************************************ --} - --- | True if the type has no non-bottom elements, e.g. when it is an empty --- datatype, or a GADT with non-satisfiable type parameters, e.g. Int :~: Bool. --- See Note [Bottoming expressions] --- --- See Note [No alternatives lint check] for another use of this function. -isEmptyTy :: Type -> Bool -isEmptyTy ty - -- Data types where, given the particular type parameters, no data - -- constructor matches, are empty. - -- This includes data types with no constructors, e.g. Data.Void.Void. - | Just (tc, inst_tys) <- splitTyConApp_maybe ty - , Just dcs <- tyConDataCons_maybe tc - , all (dataConCannotMatch inst_tys) dcs - = True - | otherwise - = False - --- | 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. -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 - = Just (tc, tc_args, co) -normSplitTyConApp_maybe _ _ = Nothing - -{- -***************************************************** -* -* InScopeSet things -* -***************************************************** --} - - -extendInScopeSetBind :: InScopeSet -> CoreBind -> InScopeSet -extendInScopeSetBind (InScope in_scope) binds - = InScope $ foldBindersOfBindStrict extendVarSet in_scope binds - -extendInScopeSetBndrs :: InScopeSet -> [CoreBind] -> InScopeSet -extendInScopeSetBndrs (InScope in_scope) binds - = InScope $ foldBindersOfBindsStrict extendVarSet in_scope binds - -mkInScopeSetBndrs :: [CoreBind] -> InScopeSet -mkInScopeSetBndrs binds = foldBindersOfBindsStrict extendInScopeSet emptyInScopeSet binds - -{- -***************************************************** -* -* StaticPtr -* -***************************************************** --} - --- | @collectMakeStaticArgs (makeStatic t srcLoc e)@ yields --- @Just (makeStatic, t, srcLoc, e)@. --- --- Returns @Nothing@ for every other expression. -collectMakeStaticArgs - :: CoreExpr -> Maybe (CoreExpr, Type, CoreExpr, CoreExpr) -collectMakeStaticArgs e - | (fun@(Var b), [Type t, loc, arg], _) <- collectArgsTicks (const True) e - , idName b == makeStaticName = Just (fun, t, loc, arg) -collectMakeStaticArgs _ = Nothing - -{- -************************************************************************ -* * -\subsection{Join points} -* * -************************************************************************ --} - --- | Does this binding bind a join point (or a recursive group of join points)? -isJoinBind :: CoreBind -> Bool -isJoinBind (NonRec b _) = isJoinId b -isJoinBind (Rec ((b, _) : _)) = isJoinId b -isJoinBind _ = False - -dumpIdInfoOfProgram :: Bool -> (IdInfo -> SDoc) -> CoreProgram -> SDoc -dumpIdInfoOfProgram dump_locals ppr_id_info binds = vcat (map printId ids) - where - ids = sortBy (stableNameCmp `on` getName) (concatMap getIds binds) - getIds (NonRec i _) = [ i ] - getIds (Rec bs) = map fst bs - -- By default only include full info for exported ids, unless we run in the verbose - -- pprDebug mode. - printId id | isExportedId id || dump_locals = ppr id <> colon <+> (ppr_id_info (idInfo id)) - | otherwise = empty - -{- -************************************************************************ -* * -\subsection{Tag inference things} -* * -************************************************************************ --} - -{- Note [Call-by-value for worker args] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -If we unbox a constructor with strict fields we want to -preserve the information that some of the arguments came -out of strict fields and therefore should be already properly -tagged, however we can't express this directly in core. - -Instead what we do is generate a worker like this: - - data T = MkT A !B - - foo = case T of MkT a b -> $wfoo a b - - $wfoo a b = case b of b' -> rhs[b/b'] - -This makes the worker strict in b causing us to use a more efficient -calling convention for `b` where the caller needs to ensure `b` is -properly tagged and evaluated before it's passed to $wfoo. See Note [CBV Function Ids]. - -Usually the argument will be known to be properly tagged at the call site so there is -no additional work for the caller and the worker can be more efficient since it can -assume the presence of a tag. - -This is especially true for recursive functions like this: - -- myPred expect it's argument properly tagged - myPred !x = ... - - loop :: MyPair -> Int - loop (MyPair !x !y) = - case x of - A -> 1 - B -> 2 - _ -> loop (MyPair (myPred x) (myPred y)) - -Here we would ordinarily not be strict in y after unboxing. -However if we pass it as a regular argument then this means on -every iteration of loop we will incur an extra seq on y before -we can pass it to `myPred` which isn't great! That is in STG after -tag inference we get: - - Rec { - Find.$wloop [InlPrag=[2], Occ=LoopBreaker] - :: Find.MyEnum -> Find.MyEnum -> GHC.Prim.Int# - [GblId[StrictWorker([!, ~])], - Arity=2, - Str=<1L>, - Unf=OtherCon []] = - {} \r [x y] - case x of x' [Occ=Once1] { - __DEFAULT -> - case y of y' [Occ=Once1] { - __DEFAULT -> - case Find.$wmyPred y' of pred_y [Occ=Once1] { - __DEFAULT -> - case Find.$wmyPred x' of pred_x [Occ=Once1] { - __DEFAULT -> Find.$wloop pred_x pred_y; - }; - }; - Find.A -> 1#; - Find.B -> 2#; - }; - end Rec } - -Here comes the tricky part: If we make $wloop strict in both x/y and we get: - - Rec { - Find.$wloop [InlPrag=[2], Occ=LoopBreaker] - :: Find.MyEnum -> Find.MyEnum -> GHC.Prim.Int# - [GblId[StrictWorker([!, !])], - Arity=2, - Str=<1L>, - Unf=OtherCon []] = - {} \r [x y] - case y of y' [Occ=Once1] { __DEFAULT -> - case x of x' [Occ=Once1] { - __DEFAULT -> - case Find.$wmyPred y' of pred_y [Occ=Once1] { - __DEFAULT -> - case Find.$wmyPred x' of pred_x [Occ=Once1] { - __DEFAULT -> Find.$wloop pred_x pred_y; - }; - }; - Find.A -> 1#; - Find.B -> 2#; - }; - end Rec } - -Here both x and y are known to be tagged in the function body since we pass strict worker args using unlifted cbv. -This means the seqs on x and y both become no-ops and compared to the first version the seq on `y` disappears at runtime. - -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. -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 -it would be useless to insert an extra seq. ShouldStrictifyIdForCbv tries to identify these to avoid churn in the -simplifier. See Note [Which Ids should be strictified] for details on this. --} -mkStrictFieldSeqs :: [(Id,StrictnessMark)] -> CoreExpr -> (CoreExpr) -mkStrictFieldSeqs args rhs = - foldr addEval rhs args - where - case_ty = exprType rhs - addEval :: (Id,StrictnessMark) -> (CoreExpr) -> (CoreExpr) - addEval (arg_id,arg_cbv) (rhs) - -- Argument representing strict field. - | isMarkedStrict arg_cbv - , shouldStrictifyIdForCbv arg_id - -- Make sure to remove unfoldings here to avoid the simplifier dropping those for OtherCon[] unfoldings. - = Case (Var $! zapIdUnfolding arg_id) arg_id case_ty ([Alt DEFAULT [] rhs]) - -- Normal argument - | otherwise = do - rhs - -{- Note [Which Ids should be strictified] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -For some arguments we would like to convince GHC to pass them call by value. -One way to achieve this is described in see Note [Call-by-value for worker args]. - -We separate the concerns of "should we pass this argument using cbv" and -"should we do so by making the rhs strict in this argument". -This note deals with the second part. - -There are multiple reasons why we might not want to insert a seq in the rhs to -strictify a functions argument: - -1) The argument doesn't exist at runtime. - -For zero width types (like Types) there is no benefit as we don't operate on them -at runtime at all. This includes things like void#, coercions and state tokens. - -2) The argument is a unlifted type. - -If the argument is a unlifted type the calling convention already is explicitly -cbv. This means inserting a seq on this argument wouldn't do anything as the seq -would be a no-op *and* it wouldn't affect the calling convention. - -3) The argument is absent. - -If the argument is absent in the body there is no advantage to it being passed as -cbv to the function. The function won't ever look at it so we don't safe any work. - -This mostly happens for join point. For example we might have: - - data T = MkT ![Int] [Char] - f t = case t of MkT xs{strict} ys-> snd (xs,ys) - -and abstract the case alternative to: - - f t = join j1 = \xs ys -> snd (xs,ys) - in case t of MkT xs{strict} ys-> j1 xs xy - -While we "use" xs inside `j1` it's not used inside the function `snd` we pass it to. -In short a absent demand means neither our RHS, nor any function we pass the argument -to will inspect it. So there is no work to be saved by forcing `xs` early. - -NB: There is an edge case where if we rebox we *can* end up seqing an absent value. -Note [Absent fillers] has an example of this. However this is so rare it's not worth -caring about here. - -4) The argument is already strict. - -Consider this code: - - data T = MkT ![Int] - f t = case t of MkT xs{strict} -> reverse xs - -The `xs{strict}` indicates that `xs` is used strictly by the `reverse xs`. -If we do a w/w split, and add the extra eval on `xs`, we'll get - - $wf xs = - case xs of xs1 -> - let t = MkT xs1 in - case t of MkT xs2 -> reverse xs2 - -That's not wrong; but the w/w body will simplify to - - $wf xs = case xs of xs1 -> reverse xs1 - -and now we'll drop the `case xs` because `xs1` is used strictly in its scope. -Adding that eval was a waste of time. So don't add it for strictly-demanded Ids. - -5) Functions - -Functions are tricky (see Note [TagInfo of functions] in InferTags). -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. - --} --- | Do we expect there to be any benefit if we make this var strict --- in order for it to get treated as as cbv argument? --- See Note [Which Ids should be strictified] --- See Note [CBV Function Ids] for more background. -shouldStrictifyIdForCbv :: Var -> Bool -shouldStrictifyIdForCbv = wantCbvForId False - --- Like shouldStrictifyIdForCbv but also wants to use cbv for strict args. -shouldUseCbvForId :: Var -> Bool -shouldUseCbvForId = wantCbvForId True - --- 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 --- 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 -wantCbvForId cbv_for_strict v - -- Must be a runtime var. - -- See Note [Which Ids should be strictified] point 1) - | isId v - , not $ isZeroBitTy ty - -- Unlifted things don't need special measures to be treated as cbv - -- 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 [Which Ids should be strictified] point 5) - , not $ isFunTy ty - -- If the var is strict already a seq is redundant. - -- See Note [Which Ids should be strictified] point 4) - , not (isStrictDmd dmd) || cbv_for_strict - -- If the var is absent a seq is almost always useless. - -- See Note [Which Ids should be strictified] point 3) - , not (isAbsDmd dmd) - = True - | otherwise - = False - where - ty = idType v - dmd = idDemandInfo v - -{- ********************************************************************* -* * - unsafeEqualityProof -* * -********************************************************************* -} - -isUnsafeEqualityProof :: CoreExpr -> Bool --- 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 - | otherwise - = False + bindNonRec, needsCaseBinding, needsCaseBindingL, + mkAltExpr, mkDefaultCase, mkSingleAltCase, + + -- * Taking expressions apart + findDefault, addDefault, findAlt, isDefaultAlt, + mergeAlts, mergeCaseAlts, trimConArgs, + filterAlts, combineIdenticalAlts, refineDefaultAlt, + scaleAltsBy, + + -- * Properties of expressions + exprType, coreAltType, coreAltsType, + mkLamType, mkLamTypes, + mkFunctionType, + exprIsTrivial, getIdFromTrivialExpr, getIdFromTrivialExpr_maybe, + trivial_expr_fold, + exprIsDupable, exprIsCheap, exprIsExpandable, exprIsCheapX, CheapAppFun, + exprIsHNF, exprOkForSpeculation, exprOkToDiscard, exprOkForSpecEval, + exprIsWorkFree, exprIsConLike, + isCheapApp, isExpandableApp, isSaturatedConApp, + exprIsTickedString, exprIsTickedString_maybe, + exprIsTopLevelBindable, + exprIsUnaryClassFun, isUnaryClassId, + altsAreExhaustive, etaExpansionTick, + + -- * Equality + cheapEqExpr, cheapEqExpr', diffBinds, + + -- * Manipulating data constructors and types + exprToType, + applyTypeToArgs, + dataConRepInstPat, dataConRepFSInstPat, + isEmptyTy, normSplitTyConApp_maybe, + + -- * Working with ticks + stripTicksTop, stripTicksTopE, stripTicksTopT, + stripTicksE, stripTicksT, + + -- * InScopeSet things which work over CoreBinds + mkInScopeSetBndrs, extendInScopeSetBind, extendInScopeSetBndrs, + + -- * StaticPtr + collectMakeStaticArgs, + + -- * Join points + isJoinBind, + + -- * Tag inference + mkStrictFieldSeqs, shouldStrictifyIdForCbv, shouldUseCbvForId, + + -- * unsafeEqualityProof + isUnsafeEqualityCase, + + -- * Dumping stuff + dumpIdInfoOfProgram + ) where + +import GHC.Prelude +import GHC.Platform + +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 +import GHC.Core.Reduction +import GHC.Core.TyCon +import GHC.Core.Multiplicity + +import GHC.Builtin.Names ( makeStaticName, unsafeEqualityProofIdKey, unsafeReflDataConKey ) +import GHC.Builtin.PrimOps + +import GHC.Types.Var +import GHC.Types.SrcLoc +import GHC.Types.Var.Env +import GHC.Types.Var.Set +import GHC.Types.Name +import GHC.Types.Literal +import GHC.Types.Tickish +import GHC.Types.Id +import GHC.Types.Id.Info +import GHC.Types.Basic( Arity ) +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 +import GHC.Data.List.SetOps( minusList ) +import GHC.Data.OrdList + +import GHC.Utils.Constants (debugIsOn) +import GHC.Utils.Outputable +import GHC.Utils.Panic +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 + +{- +************************************************************************ +* * +\subsection{Find the type of a Core atom/expression} +* * +************************************************************************ +-} + +exprType :: HasDebugCallStack => CoreExpr -> Type +-- ^ Recover the type of a well-typed Core expression. Fails when +-- applied to the actual 'GHC.Core.Type' expression as it cannot +-- really be said to have a type +exprType (Var var) = idType var +exprType (Lit lit) = literalType lit +exprType (Coercion co) = coercionType co +exprType (Let bind body) + | NonRec tv rhs <- bind -- See Note [Type bindings] + , Type ty <- rhs = substTyWithUnchecked [tv] [ty] (exprType body) + | otherwise = exprType body +exprType (Case _ _ ty _) = ty +exprType (Cast _ co) = coercionRKind co +exprType (Tick _ e) = exprType e +exprType (Lam binder expr) = mkLamType binder (exprType expr) +exprType e@(App _ _) + = case collectArgs e of + (fun, args) -> applyTypeToArgs (exprType fun) args +exprType (Type ty) = pprPanic "exprType" (ppr ty) + +coreAltType :: CoreAlt -> Type +-- ^ Returns the type of the alternatives right hand side +coreAltType alt@(Alt _ bs rhs) + = case occCheckExpand bs rhs_ty of + -- Note [Existential variables and silly type synonyms] + Just ty -> ty + Nothing -> pprPanic "coreAltType" (pprCoreAlt alt $$ ppr rhs_ty) + where + rhs_ty = exprType rhs + +coreAltsType :: [CoreAlt] -> Type +-- ^ Returns the type of the first alternative, which should be the same as for all alternatives +coreAltsType (alt:_) = coreAltType alt +coreAltsType [] = panic "coreAltsType" + +mkLamType :: HasDebugCallStack => Var -> Type -> Type +-- ^ 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. +-- +mkLamTypes :: [Var] -> Type -> Type +-- ^ 'mkLamType' for multiple type or value arguments + +mkLamType v body_ty + | isTyVar v + = 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 + -- See Note [Unused coercion variable in ForAllTy] in GHC.Core.TyCo.Rep + = mkForAllTy (Bndr v coreTyLamForAllTyFlag) body_ty + + | otherwise + = mkFunctionType (idMult v) (idType v) body_ty + +mkLamTypes vs ty = foldr mkLamType ty vs + +{- +Note [Type bindings] +~~~~~~~~~~~~~~~~~~~~ +Core does allow type bindings, although such bindings are +not much used, except in the output of the desugarer. +Example: + let a = Int in (\x:a. x) +Given this, exprType must be careful to substitute 'a' in the +result type (#8522). + +Note [Existential variables and silly type synonyms] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + data T = forall a. T (Funny a) + type Funny a = Bool + f :: T -> Bool + f (T x) = x + +Now, the type of 'x' is (Funny a), where 'a' is existentially quantified. +That means that 'exprType' and 'coreAltsType' may give a result that *appears* +to mention an out-of-scope type variable. See #3409 for a more real-world +example. + +Various possibilities suggest themselves: + + - Ignore the problem, and make Lint not complain about such variables + + - Expand all type synonyms (or at least all those that discard arguments) + This is tricky, because at least for top-level things we want to + retain the type the user originally specified. + + - Expand synonyms on the fly, when the problem arises. That is what + we are doing here. It's not too expensive, I think. + +Note that there might be existentially quantified coercion variables, too. +-} + +applyTypeToArgs :: HasDebugCallStack => Type -> [CoreExpr] -> Type +-- ^ Determines the type resulting from applying an expression with given type +--- to given argument expressions. +applyTypeToArgs op_ty args + = go op_ty args + where + go op_ty [] = op_ty + go op_ty (Type ty : args) = go_ty_args op_ty [ty] args + go op_ty (Coercion co : args) = go_ty_args op_ty [mkCoercionTy co] args + go op_ty (_ : args) | Just (_, _, _, res_ty) <- splitFunTy_maybe op_ty + = go res_ty args + go _ args = pprPanic "applyTypeToArgs" (panic_msg args) + + -- go_ty_args: accumulate type arguments so we can + -- instantiate all at once with piResultTys + go_ty_args op_ty rev_tys (Type ty : args) + = go_ty_args op_ty (ty:rev_tys) args + go_ty_args op_ty rev_tys (Coercion co : args) + = go_ty_args op_ty (mkCoercionTy co : rev_tys) args + go_ty_args op_ty rev_tys args + = go (piResultTys op_ty (reverse rev_tys)) args + + panic_msg as = vcat [ text "Type:" <+> ppr op_ty + , text "Args:" <+> ppr args + , text "Args':" <+> ppr as ] + +mkCastMCo :: CoreExpr -> MCoercionR -> CoreExpr +mkCastMCo e MRefl = e +mkCastMCo e (MCo co) = Cast e co + -- We are careful to use (MCo co) only when co is not reflexive + -- Hence (Cast e co) rather than (mkCast e co) + +mkPiMCo :: Var -> MCoercionR -> MCoercionR +mkPiMCo _ MRefl = MRefl +mkPiMCo v (MCo co) = MCo (mkPiCo Representational v co) + + +{- ********************************************************************* +* * + Casts +* * +********************************************************************* -} + +-- | Wrap the given expression in the coercion safely, dropping +-- identity coercions and coalescing nested coercions +mkCast :: HasDebugCallStack => CoreExpr -> CoercionR -> CoreExpr + +mkCast expr co + = 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) $ + 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 +* * +********************************************************************* -} + +-- | Wraps the given expression in the source annotation, dropping the +-- annotation if possible. +mkTick :: CoreTickish -> CoreExpr -> CoreExpr +mkTick t orig_expr = mkTick' id id orig_expr + where + -- 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). + -- If we want to push the tick deeper, we pre-compose `top` with a function + -- adding the tick. + mkTick' :: (CoreExpr -> CoreExpr) -- apply after adding tick (float through) + -> (CoreExpr -> CoreExpr) -- apply before adding tick (float with) + -> 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. + Tick t2 e + | ProfNote{} <- t2, ProfNote{} <- t -> top $ Tick t $ rest expr + + -- Otherwise we assume that ticks of different placements float + -- through each other. + | tickishPlace t2 /= tickishPlace t -> mkTick' (top . Tick t2) rest e + + -- For annotations this is where we make sure to not introduce + -- redundant ticks. + | tickishContains t t2 -> mkTick' top rest e + | tickishContains t2 t -> orig_expr + | otherwise -> mkTick' top (rest . Tick t2) e + + -- Ticks don't care about types, so we just float all ticks + -- through them. Note that it's not enough to check for these + -- cases top-level. While mkTick will never produce Core with type + -- expressions below ticks, such constructs can be the result of + -- unfoldings. We therefore make an effort to put everything into + -- the right place no matter what we start with. + Cast e co -> mkTick' (top . flip Cast co) rest e + Coercion co -> Coercion co + + Lam x e + -- Always float through type lambdas. Even for non-type lambdas, + -- floating is allowed for all but the most strict placement rule. + | not (isRuntimeVar x) || tickishPlace t /= PlaceRuntime + -> mkTick' (top . Lam x) rest e + + -- If it is both counting and scoped, we split the tick into its + -- two components, often allowing us to keep the counting tick on + -- the outside of the lambda and push the scoped tick inside. + -- The point of this is that the counting tick can probably be + -- floated, and the lambda may then be in a position to be + -- beta-reduced. + | canSplit + -> top $ Tick (mkNoScope t) $ rest $ Lam x $ mkTick (mkNoCount t) e + + App f arg + -- Always float through type applications. + | not (isRuntimeArg arg) + -> mkTick' (top . flip App arg) rest f + + -- We can also float through constructor applications, placement + -- permitting. Again we can split. + | isSaturatedConApp expr && (tickishPlace t==PlaceCostCentre || canSplit) + -> if tickishPlace t == PlaceCostCentre + then top $ rest $ tickHNFArgs t expr + else top $ Tick (mkNoScope t) $ rest $ tickHNFArgs (mkNoCount t) expr + + Var x + | notFunction && tickishPlace t == PlaceCostCentre + -> orig_expr + | notFunction && canSplit + -> top $ Tick (mkNoScope t) $ rest expr + where + -- SCCs can be eliminated on variables provided the variable + -- is not a function. In these cases the SCC makes no difference: + -- the cost of evaluating the variable will be attributed to its + -- definition site. When the variable refers to a function, however, + -- an SCC annotation on the variable affects the cost-centre stack + -- when the function is called, so we must retain those. + notFunction = not (isFunTy (idType x)) + + Lit{} + | tickishPlace t == PlaceCostCentre + -> orig_expr + + -- Catch-all: Annotate where we stand + _any -> top $ Tick t $ rest expr + +mkTicks :: [CoreTickish] -> CoreExpr -> CoreExpr +mkTicks ticks expr = foldr mkTick expr ticks + +isSaturatedConApp :: CoreExpr -> Bool +isSaturatedConApp e = go e [] + where go (App f a) as = go f (a:as) + go (Var fun) args + = isConLikeId fun && idArity fun == valArgCount args + go (Cast f _) as = go f as + go _ _ = False + +mkTickNoHNF :: CoreTickish -> CoreExpr -> CoreExpr +mkTickNoHNF t e + | exprIsHNF e = tickHNFArgs t e + | otherwise = mkTick t e + +-- push a tick into the arguments of a HNF (call or constructor app) +tickHNFArgs :: CoreTickish -> CoreExpr -> CoreExpr +tickHNFArgs t e = push t e + where + push t (App f (Type u)) = App (push t f) (Type u) + push t (App f arg) = App (push t f) (mkTick t arg) + push _t e = e + +-- | Strip ticks satisfying a predicate from top of an expression +stripTicksTop :: (CoreTickish -> Bool) -> Expr b -> ([CoreTickish], Expr b) +stripTicksTop p = go [] + where go ts (Tick t e) | p t = go (t:ts) e + go ts other = (reverse ts, other) + +-- | Strip ticks satisfying a predicate from top of an expression, +-- returning the remaining expression +stripTicksTopE :: (CoreTickish -> Bool) -> Expr b -> Expr b +stripTicksTopE p = go + where go (Tick t e) | p t = go e + go other = other + +-- | Strip ticks satisfying a predicate from top of an expression, +-- returning the ticks +stripTicksTopT :: (CoreTickish -> Bool) -> Expr b -> [CoreTickish] +stripTicksTopT p = go [] + where go ts (Tick t e) | p t = go (t:ts) e + go ts _ = ts + +-- | Completely strip ticks satisfying a predicate from an +-- expression. Note this is O(n) in the size of the expression! +stripTicksE :: (CoreTickish -> Bool) -> Expr b -> Expr b +stripTicksE p expr = go expr + where go (App e a) = App (go e) (go a) + go (Lam b e) = Lam b (go e) + go (Let b e) = Let (go_bs b) (go e) + go (Case e b t as) = Case (go e) b t (map go_a as) + go (Cast e c) = Cast (go e) c + go (Tick t e) + | p t = go e + | otherwise = Tick t (go e) + go other = other + go_bs (NonRec b e) = NonRec b (go e) + go_bs (Rec bs) = Rec (map go_b bs) + go_b (b, e) = (b, go e) + go_a (Alt c bs e) = Alt c bs (go e) + +stripTicksT :: (CoreTickish -> Bool) -> Expr b -> [CoreTickish] +stripTicksT p expr = fromOL $ go expr + where go (App e a) = go e `appOL` go a + go (Lam _ e) = go e + go (Let b e) = go_bs b `appOL` go e + go (Case e _ _ as) = go e `appOL` concatOL (map go_a as) + go (Cast e _) = go e + go (Tick t e) + | p t = t `consOL` go e + | otherwise = go e + go _ = nilOL + go_bs (NonRec _ e) = go e + go_bs (Rec bs) = concatOL (map go_b bs) + go_b (_, e) = go e + go_a (Alt _ _ e) = go e + +{- +************************************************************************ +* * +\subsection{Other expression construction} +* * +************************************************************************ +-} + +bindNonRec :: HasDebugCallStack => Id -> CoreExpr -> CoreExpr -> CoreExpr +-- ^ @bindNonRec x r b@ produces either: +-- +-- > let x = r in b +-- +-- or: +-- +-- > case r of x { _DEFAULT_ -> b } +-- +-- depending on whether we have to use a @case@ or @let@ +-- binding for the expression (see 'needsCaseBinding'). +-- It's used by the desugarer to avoid building bindings +-- that give Core Lint a heart attack, although actually +-- the simplifier deals with them perfectly well. See +-- also 'GHC.Core.Make.mkCoreLet' +bindNonRec bndr rhs body + | isTyVar bndr = let_bind + | isCoVar bndr = if isCoArg rhs then let_bind + {- See Note [Binding coercions] -} else case_bind + | isJoinId bndr = let_bind + | needsCaseBinding (idType bndr) rhs = case_bind + | otherwise = let_bind + where + case_bind = mkDefaultCase rhs bndr body + let_bind = Let (NonRec bndr rhs) body + +-- | `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 + -> CoreExpr +-- ^ This guy constructs the value that the scrutinee must have +-- given that you are in one particular branch of a case +mkAltExpr (DataAlt con) args inst_tys + = mkConApp con (map Type inst_tys ++ varsToCoreExprs args) +mkAltExpr (LitAlt lit) [] [] + = Lit lit +mkAltExpr (LitAlt _) _ _ = panic "mkAltExpr LitAlt" +mkAltExpr DEFAULT _ _ = panic "mkAltExpr DEFAULT" + +mkDefaultCase :: CoreExpr -> Id -> CoreExpr -> CoreExpr +-- Make (case x of y { DEFAULT -> e } +mkDefaultCase scrut case_bndr body + = Case scrut case_bndr (exprType body) [Alt DEFAULT [] body] + +mkSingleAltCase :: CoreExpr -> Id -> AltCon -> [Var] -> CoreExpr -> CoreExpr +-- Use this function if possible, when building a case, +-- because it ensures that the type on the Case itself +-- doesn't mention variables bound by the case +-- See Note [Care with the type of a case expression] +mkSingleAltCase scrut case_bndr con bndrs body + = Case scrut case_bndr case_ty [Alt con bndrs body] + where + body_ty = exprType body + + case_ty -- See Note [Care with the type of a case expression] + | Just body_ty' <- occCheckExpand bndrs body_ty + = body_ty' + + | otherwise + = pprPanic "mkSingleAltCase" (ppr scrut $$ ppr bndrs $$ ppr body_ty) + +{- Note [Care with the type of a case expression] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider a phantom type synonym + type S a = Int +and we want to form the case expression + case x of K (a::*) -> (e :: S a) + +We must not make the type field of the case-expression (S a) because +'a' isn't in scope. Hence the call to occCheckExpand. This caused +issue #17056. + +NB: this situation can only arise with type synonyms, which can +falsely "mention" type variables that aren't "really there", and which +can be eliminated by expanding the synonym. + +Note [Binding coercions] +~~~~~~~~~~~~~~~~~~~~~~~~ +Consider binding a CoVar, c = e. Then, we must satisfy +Note [Core type and coercion invariant] in GHC.Core, +which allows only (Coercion co) on the RHS. + +************************************************************************ +* * + Operations over case alternatives +* * +************************************************************************ + +The default alternative must be first, if it exists at all. +This makes it easy to find, though it makes matching marginally harder. +-} + +-- | Extract the default case alternative +findDefault :: [Alt b] -> ([Alt b], Maybe (Expr b)) +findDefault (Alt DEFAULT args rhs : alts) = assert (null args) (alts, Just rhs) +findDefault alts = (alts, Nothing) + +addDefault :: [Alt b] -> Maybe (Expr b) -> [Alt b] +addDefault alts Nothing = alts +addDefault alts (Just rhs) = Alt DEFAULT [] rhs : alts + +isDefaultAlt :: Alt b -> Bool +isDefaultAlt (Alt DEFAULT _ _) = True +isDefaultAlt _ = False + +-- | Find the case alternative corresponding to a particular +-- constructor: panics if no such constructor exists +findAlt :: AltCon -> [Alt b] -> Maybe (Alt b) + -- A "Nothing" result *is* legitimate + -- See Note [Unreachable code] +findAlt con alts + = case alts of + (deflt@(Alt DEFAULT _ _):alts) -> go alts (Just deflt) + _ -> go alts Nothing + where + go [] deflt = deflt + go (alt@(Alt con1 _ _) : alts) deflt + = case con `cmpAltCon` con1 of + LT -> deflt -- Missed it already; the alts are in increasing order + EQ -> Just alt + GT -> assert (not (con1 == DEFAULT)) $ go alts deflt + +{- Note [Unreachable code] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +It is possible (although unusual) for GHC to find a case expression +that cannot match. For example: + + data Col = Red | Green | Blue + x = Red + f v = case x of + Red -> ... + _ -> ...(case x of { Green -> e1; Blue -> e2 })... + +Suppose that for some silly reason, x isn't substituted in the case +expression. (Perhaps there's a NOINLINE on it, or profiling SCC stuff +gets in the way; cf #3118.) Then the full-laziness pass might produce +this + + x = Red + lvl = case x of { Green -> e1; Blue -> e2 }) + f v = case x of + Red -> ... + _ -> ...lvl... + +Now if x gets inlined, we won't be able to find a matching alternative +for 'Red'. That's because 'lvl' is unreachable. So rather than crashing +we generate (error "Inaccessible alternative"). + +Similar things can happen (augmented by GADTs) when the Simplifier +filters down the matching alternatives in GHC.Core.Opt.Simplify.rebuildCase. +-} + +--------------------------------- +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 +mergeAlts [] as2 = as2 +mergeAlts as1 [] = as1 +mergeAlts (a1:as1) (a2:as2) + = case a1 `cmpAlt` a2 of + LT -> a1 : mergeAlts as1 (a2:as2) + EQ -> a1 : mergeAlts as1 as2 -- Discard a2 + GT -> a2 : mergeAlts (a1:as1) as2 + + +--------------------------------- +trimConArgs :: AltCon -> [CoreArg] -> [CoreArg] +-- ^ Given: +-- +-- > case (C a b x y) of +-- > C b x y -> ... +-- +-- We want to drop the leading type argument of the scrutinee +-- leaving the arguments to match against the pattern + +trimConArgs DEFAULT args = assert (null args) [] +trimConArgs (LitAlt _) args = assert (null args) [] +trimConArgs (DataAlt dc) args = dropList (dataConUnivTyVars dc) args + +filterAlts :: TyCon -- ^ Type constructor of scrutinee's type (used to prune possibilities) + -> [Type] -- ^ And its type arguments + -> [AltCon] -- ^ 'imposs_cons': constructors known to be impossible due to the form of the scrutinee + -> [Alt b] -- ^ Alternatives + -> ([AltCon], [Alt b]) + -- Returns: + -- 1. Constructors that will never be encountered by the + -- *default* case (if any). A superset of imposs_cons + -- 2. The new alternatives, trimmed by + -- a) remove imposs_cons + -- b) remove constructors which can't match because of GADTs + -- + -- NB: the final list of alternatives may be empty: + -- This is a tricky corner case. If the data type has no constructors, + -- which GHC allows, or if the imposs_cons covers all constructors (after taking + -- account of GADTs), then no alternatives can match. + -- + -- If callers need to preserve the invariant that there is always at least one branch + -- in a "case" statement then they will need to manually add a dummy case branch that just + -- calls "error" or similar. +filterAlts _tycon inst_tys imposs_cons alts + = imposs_deflt_cons `seqList` + (imposs_deflt_cons, addDefault trimmed_alts maybe_deflt) + -- Very important to force `imposs_deflt_cons` as that forces `alt_cons`, which + -- is essentially as retaining `alts_wo_default` or any `Alt b` for that matter + -- leads to a huge space leak (see #22102 and !8896) + where + (alts_wo_default, maybe_deflt) = findDefault alts + alt_cons = [con | Alt con _ _ <- alts_wo_default] + + trimmed_alts = filterOut (impossible_alt inst_tys) alts_wo_default + + imposs_cons_set = Set.fromList imposs_cons + imposs_deflt_cons = + imposs_cons ++ filterOut (`Set.member` imposs_cons_set) alt_cons + -- "imposs_deflt_cons" are handled + -- EITHER by the context, + -- OR by a non-DEFAULT branch in this case expression. + + impossible_alt :: [Type] -> Alt b -> Bool + impossible_alt _ (Alt con _ _) | con `Set.member` imposs_cons_set = True + impossible_alt inst_tys (Alt (DataAlt con) _ _) = dataConCannotMatch inst_tys con + impossible_alt _ _ = False + +-- | Refine the default alternative to a 'DataAlt', if there is a unique way to do so. +-- See Note [Refine DEFAULT case alternatives] +refineDefaultAlt :: [Unique] -- ^ Uniques for constructing new binders + -> Mult -- ^ Multiplicity annotation of the case expression + -> TyCon -- ^ Type constructor of scrutinee's type + -> [Type] -- ^ Type arguments of scrutinee's type + -> [AltCon] -- ^ Constructors that cannot match the DEFAULT (if any) + -> [CoreAlt] + -> (Bool, [CoreAlt]) -- ^ 'True', if a default alt was replaced with a 'DataAlt' +refineDefaultAlt us mult tycon tys imposs_deflt_cons all_alts + | Alt DEFAULT _ rhs : rest_alts <- all_alts + , isAlgTyCon tycon -- It's a data type, tuple, or unboxed tuples. + , not (isNewTyCon tycon) -- Exception 1 in Note [Refine DEFAULT case alternatives] + , not (isTypeDataTyCon tycon) -- Exception 2 in Note [Refine DEFAULT case alternatives] + , Just all_cons <- tyConDataCons_maybe tycon + , let imposs_data_cons = mkUniqSet [con | DataAlt con <- imposs_deflt_cons] + -- We now know it's a data type, so we can use + -- UniqSet rather than Set (more efficient) + impossible con = con `elementOfUniqSet` imposs_data_cons + || dataConCannotMatch tys con + = case filterOut impossible all_cons of + -- Eliminate the default alternative + -- altogether if it can't match: + [] -> (False, rest_alts) + + -- It matches exactly one constructor, so fill it in: + [con] -> (True, mergeAlts rest_alts [Alt (DataAlt con) (ex_tvs ++ arg_ids) rhs]) + -- We need the mergeAlts to keep the alternatives in the right order + where + (ex_tvs, arg_ids) = dataConRepInstPat us mult con tys + + -- It matches more than one, so do nothing + _ -> (False, all_alts) + + | debugIsOn, isAlgTyCon tycon, null (tyConDataCons tycon) + , not (isFamilyTyCon tycon || isAbstractTyCon tycon) + -- Check for no data constructors + -- This can legitimately happen for abstract types and type families, + -- so don't report that + = (False, all_alts) + + | otherwise -- The common case + = (False, all_alts) + +{- 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. + +The simplest example being + foo :: () -> () + foo x = case x of !_ -> () +which rewrites to + foo :: () -> () + foo x = case x of () -> () + +There are two reasons in general why replacing a DEFAULT alternative +with a specific constructor is desirable. + +1. We can simplify inner expressions. For example + + data Foo = Foo1 () + + test :: Foo -> () + test x = case x of + DEFAULT -> mid (case x of + Foo1 x1 -> x1) + + refineDefaultAlt fills in the DEFAULT here with `Foo ip1` and then + x becomes bound to `Foo ip1` so is inlined into the other case + which causes the KnownBranch optimisation to kick in. If we don't + refine DEFAULT to `Foo ip1`, we are left with both case expressions. + +2. combineIdenticalAlts does a better job. For example (Simon Jacobi) + data D = C0 | C1 | C2 + + case e of + DEFAULT -> e0 + C0 -> e1 + C1 -> e1 + + When we apply combineIdenticalAlts to this expression, it can't + combine the alts for C0 and C1, as we already have a default case. + But if we apply refineDefaultAlt first, we get + case e of + C0 -> e1 + C1 -> e1 + C2 -> e0 + and combineIdenticalAlts can turn that into + case e of + DEFAULT -> e1 + C2 -> e0 + + It isn't obvious that refineDefaultAlt does this but if you look + at its one call site in GHC.Core.Opt.Simplify.Utils then the + `imposs_deflt_cons` argument is populated with constructors which + are matched elsewhere. + +There are two exceptions where we avoid refining a DEFAULT case: + +* Exception 1: Newtypes + + We can have a newtype, if we are just doing an eval: + + case x of { DEFAULT -> e } + + And we don't want to fill in a default for them! + +* Exception 2: `type data` declarations + + The data constructors for a `type data` declaration (see + Note [Type data declarations] in GHC.Rename.Module) do not exist at the + value level. Nevertheless, it is possible to strictly evaluate a value + whose type is a `type data` declaration. Test case + type-data/should_compile/T2294b.hs contains an example: + + type data T a where + A :: T Int + + f :: T a -> () + f !x = () + + We want to generate the following Core for f: + + f = \(@a) (x :: T a) -> + case x of + __DEFAULT -> () + + Namely, we do _not_ want to match on `A`, as it doesn't exist at the value + level! See wrinkle (W2b) in Note [Type data declarations] in GHC.Rename.Module + + +Note [Combine identical alternatives] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If several alternatives are identical, merge them into a single +DEFAULT alternative. I've occasionally seen this making a big +difference: + + case e of =====> case e of + C _ -> f x D v -> ....v.... + D v -> ....v.... DEFAULT -> f x + DEFAULT -> f x + +The point is that we merge common RHSs, at least for the DEFAULT case. +[One could do something more elaborate but I've never seen it needed.] +To avoid an expensive test, we just merge branches equal to the *first* +alternative; this picks up the common cases + a) all branches equal + b) some branches equal to the DEFAULT (which occurs first) + +The case where Combine Identical Alternatives transformation showed up +was like this (base/Foreign/C/Err/Error.hs): + + x | p `is` 1 -> e1 + | p `is` 2 -> e2 + ...etc... + +where @is@ was something like + + p `is` n = p /= (-1) && p == n + +This gave rise to a horrible sequence of cases + + case p of + (-1) -> $j p + 1 -> e1 + DEFAULT -> $j p + +and similarly in cascade for all the join points! + +Note [Combine identical alternatives: wrinkles] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +* It's important that we try to combine alternatives *before* + simplifying them, rather than after. Reason: because + Simplify.simplAlt may zap the occurrence info on the binders in the + alternatives, which in turn defeats combineIdenticalAlts use of + isDeadBinder (see #7360). + + You can see this in the call to combineIdenticalAlts in + GHC.Core.Opt.Simplify.Utils.prepareAlts. Here the alternatives have type InAlt + (the "In" meaning input) rather than OutAlt. + +* combineIdenticalAlts does not work well for nullary constructors + case x of y + [] -> f [] + (_:_) -> f y + Here we won't see that [] and y are the same. Sigh! This problem + is solved in CSE, in GHC.Core.Opt.CSE.combineAlts, which does a better version + of combineIdenticalAlts. But sadly it doesn't have the occurrence info we have + here. + See Note [Combine case alts: awkward corner] in GHC.Core.Opt.CSE). + +Note [Care with impossible-constructors when combining alternatives] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we have (#10538) + data T = A | B | C | D + + case x::T of (Imposs-default-cons {A,B}) + DEFAULT -> e1 + A -> e2 + B -> e1 + +When calling combineIdentialAlts, we'll have computed that the +"impossible constructors" for the DEFAULT alt is {A,B}, since if x is +A or B we'll take the other alternatives. But suppose we combine B +into the DEFAULT, to get + + case x::T of (Imposs-default-cons {A}) + DEFAULT -> e1 + A -> e2 + +Then we must be careful to trim the impossible constructors to just {A}, +else we risk compiling 'e1' wrong! + +Not only that, but we take care when there is no DEFAULT beforehand, +because we are introducing one. Consider + + case x of (Imposs-default-cons {A,B,C}) + A -> e1 + B -> e2 + C -> e1 + +Then when combining the A and C alternatives we get + + case x of (Imposs-default-cons {B}) + DEFAULT -> e1 + B -> e2 + +Note that we have a new DEFAULT branch that we didn't have before. So +we need delete from the "impossible-default-constructors" all the +known-con alternatives that we have eliminated. (In #11172 we +missed the first one.) + +-} + +combineIdenticalAlts :: [AltCon] -- Constructors that cannot match DEFAULT + -> [CoreAlt] + -> (Bool, -- True <=> something happened + [AltCon], -- New constructors that cannot match DEFAULT + [CoreAlt]) -- New alternatives +-- See Note [Combine identical alternatives] +-- True <=> we did some combining, result is a single DEFAULT alternative +combineIdenticalAlts imposs_deflt_cons (Alt con1 bndrs1 rhs1 : rest_alts) + | all isDeadBinder bndrs1 -- Remember the default + , not (null elim_rest) -- alternative comes first + = (True, imposs_deflt_cons', deflt_alt : filtered_rest) + where + (elim_rest, filtered_rest) = partition identical_to_alt1 rest_alts + deflt_alt = Alt DEFAULT [] (mkTicks (concat tickss) rhs1) + + -- See Note [Care with impossible-constructors when combining alternatives] + imposs_deflt_cons' = imposs_deflt_cons `minusList` elim_cons + elim_cons = elim_con1 ++ map (\(Alt con _ _) -> con) elim_rest + elim_con1 = case con1 of -- Don't forget con1! + DEFAULT -> [] + _ -> [con1] + + cheapEqTicked e1 e2 = cheapEqExpr' tickishFloatable e1 e2 + identical_to_alt1 (Alt _con bndrs rhs) + = all isDeadBinder bndrs && rhs `cheapEqTicked` rhs1 + tickss = map (\(Alt _ _ rhs) -> stripTicksT tickishFloatable rhs) elim_rest + +combineIdenticalAlts imposs_cons alts + = (False, imposs_cons, alts) + +-- Scales the multiplicity of the binders of a list of case alternatives. That +-- is, in [C x1…xn -> u], the multiplicity of x1…xn is scaled. +scaleAltsBy :: Mult -> [CoreAlt] -> [CoreAlt] +scaleAltsBy w alts = map scaleAlt alts + where + scaleAlt :: CoreAlt -> CoreAlt + scaleAlt (Alt con bndrs rhs) = Alt con (map scaleBndr bndrs) rhs + + scaleBndr :: CoreBndr -> CoreBndr + scaleBndr b = scaleVarBy w b + + +{- ********************************************************************* +* * + exprIsTrivial +* * +************************************************************************ + +Note [exprIsTrivial] +~~~~~~~~~~~~~~~~~~~~ +@exprIsTrivial@ is true of expressions we are unconditionally happy to + duplicate; simple variables and constants, and type + applications. Note that primop Ids aren't considered + trivial unless + +Note [Variables are trivial] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +There used to be a gruesome test for (hasNoBinding v) in the +Var case: + exprIsTrivial (Var v) | hasNoBinding v = idArity v == 0 +The idea here is that a constructor worker, like \$wJust, is +really short for (\x -> \$wJust x), because \$wJust has no binding. +So it should be treated like a lambda. Ditto unsaturated primops. +But now constructor workers are not "have-no-binding" Ids. And +completely un-applied primops and foreign-call Ids are sufficiently +rare that I plan to allow them to be duplicated and put up with +saturating them. + +Note [Tick trivial] +~~~~~~~~~~~~~~~~~~~ +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. At least if `x` is not a function. + +Note [Empty case is trivial] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The expression (case (x::Int) Bool of {}) is just a type-changing +case used when we are sure that 'x' will not return. See +Note [Empty case alternatives] in GHC.Core. + +If the scrutinee is trivial, then so is the whole expression; and the +CoreToSTG pass in fact drops the case expression leaving only the +scrutinee. + +Having more trivial expressions is good. Moreover, if we don't treat +it as trivial we may land up with let-bindings like + let v = case x of {} in ... +and after CoreToSTG that gives + let v = x in ... +and that confuses the code generator (#11155). So best to kill +it off at source. +-} + +{-# INLINE trivial_expr_fold #-} +trivial_expr_fold :: (Id -> r) -> (Literal -> r) -> r -> r -> CoreExpr -> r +-- ^ The worker function for Note [exprIsTrivial] and Note [getIdFromTrivialExpr] +-- This is meant to have the code of both functions in one place and make it +-- easy to derive custom predicates. +-- +-- (trivial_expr_fold k_id k_triv k_not_triv e) +-- * returns (k_id x) if `e` is a variable `x` (with trivial wrapping) +-- * returns (k_lit x) if `e` is a trivial literal `l` (with trivial wrapping) +-- * returns k_triv if `e` is a literal, type, or coercion (with trivial wrapping) +-- * returns k_not_triv otherwise +-- +-- where "trivial wrapping" is +-- * Type application or abstraction +-- * Ticks other than `tickishIsCode` +-- * `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 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 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 +exprIsTrivial e = trivial_expr_fold (const True) (const True) True False e + +{- +Note [getIdFromTrivialExpr] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When substituting in a breakpoint we need to strip away the type cruft +from a trivial expression and get back to the Id. The invariant is +that the expression we're substituting was originally trivial +according to exprIsTrivial, AND the expression is not a literal. +See Note [substTickish] for how breakpoint substitution preserves +this extra invariant. + +We also need this functionality in CorePrep to extract out Id of a +function which we are saturating. However, in this case we don't know +if the variable actually refers to a literal; thus we use +'getIdFromTrivialExpr_maybe' to handle this case. See test +T12076lit for an example where this matters. +-} + +getIdFromTrivialExpr :: HasDebugCallStack => CoreExpr -> Id +-- See Note [getIdFromTrivialExpr] +getIdFromTrivialExpr e = trivial_expr_fold id (const panic) panic panic e + where + panic = pprPanic "getIdFromTrivialExpr" (ppr e) + +getIdFromTrivialExpr_maybe :: CoreExpr -> Maybe Id +getIdFromTrivialExpr_maybe e = trivial_expr_fold Just (const Nothing) Nothing Nothing e + +{- ********************************************************************* +* * + exprIsDupable +* * +************************************************************************ + +Note [exprIsDupable] +~~~~~~~~~~~~~~~~~~~~ +@exprIsDupable@ is true of expressions that can be duplicated at a modest + cost in code size. This will only happen in different case + branches, so there's no issue about duplicating work. + + That is, exprIsDupable returns True of (f x) even if + f is very very expensive to call. + + Its only purpose is to avoid fruitless let-binding + and then inlining of case join points +-} + +exprIsDupable :: Platform -> CoreExpr -> Bool +exprIsDupable platform e + = isJust (go dupAppSize e) + where + go :: Int -> CoreExpr -> Maybe Int + go n (Type {}) = Just n + go n (Coercion {}) = Just n + go n (Var {}) = decrement n + go n (Tick _ e) = go n e + go n (Cast e _) = go n e + go n (App f a) | Just n' <- go n a = go n' f + go n (Lit lit) | litIsDupable platform lit = decrement n + go _ _ = Nothing + + decrement :: Int -> Maybe Int + decrement 0 = Nothing + decrement n = Just (n-1) + +dupAppSize :: Int +dupAppSize = 8 -- Size of term we are prepared to duplicate + -- This is *just* big enough to make test MethSharing + -- inline enough join points. Really it should be + -- smaller, and could be if we fixed #4960. + +{- +************************************************************************ +* * + exprIsCheap, exprIsExpandable +* * +************************************************************************ + +Note [exprIsWorkFree] +~~~~~~~~~~~~~~~~~~~~~ +exprIsWorkFree is used when deciding whether to inline something; we +don't inline it if doing so might duplicate work, by peeling off a +complete copy of the expression. Here we do not want even to +duplicate a primop (#5623): + eg let x = a #+ b in x +# x + we do not want to inline/duplicate x + +Previously we were a bit more liberal, which led to the primop-duplicating +problem. However, being more conservative did lead to a big regression in +one nofib benchmark, wheel-sieve1. The situation looks like this: + + let noFactor_sZ3 :: GHC.Types.Int -> GHC.Types.Bool + noFactor_sZ3 = case s_adJ of _ { GHC.Types.I# x_aRs -> + case GHC.Prim.<=# x_aRs 2 of _ { + GHC.Types.False -> notDivBy ps_adM qs_adN; + GHC.Types.True -> lvl_r2Eb }} + go = \x. ...(noFactor (I# y))....(go x')... + +The function 'noFactor' is heap-allocated and then called. Turns out +that 'notDivBy' is strict in its THIRD arg, but that is invisible to +the caller of noFactor, which therefore cannot do w/w and +heap-allocates noFactor's argument. At the moment (May 12) we are just +going to put up with this, because the previous more aggressive inlining +(which treated 'noFactor' as work-free) was duplicating primops, which +in turn was making inner loops of array calculations runs slow (#5623) + +Note [Case expressions are work-free] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Are case-expressions work-free? Consider + let v = case x of (p,q) -> p + go = \y -> ...case v of ... +Should we inline 'v' at its use site inside the loop? At the moment +we do. I experimented with saying that case are *not* work-free, but +that increased allocation slightly. It's a fairly small effect, and at +the moment we go for the slightly more aggressive version which treats +(case x of ....) as work-free if the alternatives are. + +Moreover it improves arities of overloaded functions where +there is only dictionary selection (no construction) involved + +Note [exprIsCheap] +~~~~~~~~~~~~~~~~~~ +See also Note [Interaction of exprIsWorkFree and lone variables] in GHC.Core.Unfold + +@exprIsCheap@ looks at a Core expression and returns \tr{True} if +it is obviously in weak head normal form, or is cheap to get to WHNF. +Note that that's not the same as exprIsDupable; an expression might be +big, and hence not dupable, but still cheap. + +By ``cheap'' we mean a computation we're willing to: + push inside a lambda, or + inline at more than one place +That might mean it gets evaluated more than once, instead of being +shared. The main examples of things which aren't WHNF but are +``cheap'' are: + + * case e of + pi -> ei + (where e, and all the ei are cheap) + + * let x = e in b + (where e and b are cheap) + + * op x1 ... xn + (where op is a cheap primitive operator) + + * error "foo" + (because we are happy to substitute it inside a lambda) + +Notice that a variable is considered 'cheap': we can push it inside a lambda, +because sharing will make sure it is only evaluated once. + +Note [exprIsCheap and exprIsHNF] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Note that exprIsHNF does not imply exprIsCheap. Eg + let x = fac 20 in Just x +This responds True to exprIsHNF (you can discard a seq), but +False to exprIsCheap. + +Note [Arguments and let-bindings exprIsCheapX] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +What predicate should we apply to the argument of an application, or the +RHS of a let-binding? + +We used to say "exprIsTrivial arg" due to concerns about duplicating +nested constructor applications, but see #4978. So now we just recursively +use exprIsCheapX. + +We definitely want to treat let and app the same. The principle here is +that + let x = blah in f x +should behave equivalently to + f blah + +This in turn means that the 'letrec g' does not prevent eta expansion +in this (which it previously was): + f = \x. let v = case x of + True -> letrec g = \w. blah + in g + False -> \x. x + in \w. v True +-} + +------------------------------------- +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 -> Bool -> CoreExpr -> Bool +{-# INLINE exprIsCheapX #-} +-- allow specialization of exprIsCheap, exprIsWorkFree and exprIsExpandable +-- instead of having an unknown call to ok_app +-- 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 + + -- n is the number of value arguments + go n (Var v) = ok_app v n + go _ (Lit {}) = True + go _ (Type {}) = True + go _ (Coercion {}) = True + go n (Cast e _) = go n e + 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 + 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 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] + +-------------------- +exprIsWorkFree :: CoreExpr -> Bool +-- See Note [exprIsWorkFree] +exprIsWorkFree e = exprIsCheapX isWorkFreeApp False e + +-------------------- +exprIsCheap :: CoreExpr -> Bool +-- See Note [exprIsCheap] +exprIsCheap e = exprIsCheapX isCheapApp False e + +-------------------- +exprIsExpandable :: CoreExpr -> Bool +-- See Note [exprIsExpandable] +exprIsExpandable e = exprIsCheapX isExpandableApp True e + +isWorkFreeApp :: CheapAppFun +isWorkFreeApp fn n_val_args + | n_val_args == 0 -- No value args + = True + | n_val_args < idArity fn -- Partial application + = True + | otherwise + = case idDetails fn of + DataConWorkId {} -> True + PrimOpId op _ -> primOpIsWorkFree op + _ -> False + +isCheapApp :: CheapAppFun +isCheapApp fn n_val_args + | isWorkFreeApp fn n_val_args = True + | isDeadEndId fn = True -- See Note [isCheapApp: bottoming functions] + | otherwise + = case idDetails fn of + -- DataConWorkId {} -> _ -- Handled by isWorkFreeApp + RecSelId {} -> n_val_args == 1 -- See Note [Record selection] + ClassOpId {} -> n_val_args == 1 + PrimOpId op _ -> primOpIsCheap op + _ -> False + -- In principle we should worry about primops + -- that return a type variable, since the result + -- might be applied to something, but I'm not going + -- to bother to check the number of args + +isExpandableApp :: CheapAppFun +isExpandableApp fn n_val_args + | 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 + _ | isDeadEndId fn -> False + -- See Note [isExpandableApp: bottoming functions] + | isConLikeId fn -> True + | all_args_are_preds -> True + | otherwise -> False + + where + -- See if all the arguments are PredTys (implicit params or classes) + -- If so we'll regard it as expandable; see Note [Expandable overloadings] + all_args_are_preds = all_pred_args n_val_args (idType fn) + + all_pred_args n_val_args ty + | n_val_args == 0 + = True + + | Just (bndr, ty) <- splitPiTy_maybe ty + = case bndr of + Named {} -> all_pred_args n_val_args ty + Anon _ af -> isInvisibleFunArg af && all_pred_args (n_val_args-1) ty + + | otherwise + = False + +{- Note [isCheapApp: bottoming functions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +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 +functions. Recall undefined :: HasCallStack => a +Suppose isExpandableApp responded True to (undefined d), and we had: + + x = undefined + +Then Simplify.prepareRhs would ANF the RHS: + + d = + x = undefined d + +This is already bad: we gain nothing from having x bound to (undefined +var), unlike the case for data constructors. Worse, we get the +simplifier loop described in OccurAnal Note [Cascading inlines]. +Suppose x occurs just once; OccurAnal.occAnalNonRecRhs decides x will +certainly_inline; so we end up inlining d right back into x; but in +the end x doesn't inline because it is bottom (preInlineUnconditionally); +so the process repeats.. We could elaborate the certainly_inline logic +some more, but it's better just to treat bottoming bindings as +non-expandable, because ANFing them is a bad idea in the first place. + +Note [Record selection] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +I'm experimenting with making record selection +look cheap, so we will substitute it inside a +lambda. Particularly for dictionary field selection. + +BUT: Take care with (sel d x)! The (sel d) might be cheap, but +there's no guarantee that (sel d x) will be too. Hence (n_val_args == 1) + +Note [Expandable overloadings] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose the user wrote this + {-# RULE forall x. foo (negate x) = h x #-} + f x = ....(foo (negate x)).... +They'd expect the rule to fire. But since negate is overloaded, we might +get this: + f = \d -> let n = negate d in \x -> ...foo (n x)... +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 +* * +********************************************************************* -} + +----------------------------- +-- | 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, and +-- +-- * Safe /not/ to evaluate even if normal order would do so +-- +-- 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). +-- +-- 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 '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') +-- +-- But in fact both functions are a bit more conservative than the above, +-- in at least the following ways: +-- +-- * 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# } +-- > in E +-- +-- being translated to: +-- +-- > case y# +# 1# of { r# -> +-- > let x = I# r# +-- > in E +-- > } +-- +-- 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, exprOkToDiscard :: CoreExpr -> Bool +exprOkForSpeculation = expr_ok fun_always_ok primOpOkForSpeculation +exprOkToDiscard = expr_ok fun_always_ok primOpOkToDiscard + +fun_always_ok :: Id -> Bool +fun_always_ok _ = True + +-- | A special version of 'exprOkForSpeculation' used during +-- Note [Speculative evaluation]. When the predicate arg `fun_ok` returns False +-- for `b`, then `b` is never considered ok-for-spec. +exprOkForSpecEval :: (Id -> Bool) -> CoreExpr -> Bool +exprOkForSpecEval fun_ok = expr_ok fun_ok primOpOkForSpeculation + +expr_ok :: (Id -> Bool) -> (PrimOp -> Bool) -> CoreExpr -> Bool +expr_ok _ _ (Lit _) = True +expr_ok _ _ (Type _) = True +expr_ok _ _ (Coercion _) = True + +expr_ok fun_ok primop_ok (Var v) = app_ok fun_ok primop_ok v [] +expr_ok fun_ok primop_ok (Cast e _) = expr_ok fun_ok primop_ok e +expr_ok fun_ok primop_ok (Lam b e) + | isTyVar b = expr_ok fun_ok primop_ok e + | otherwise = True + +-- Tick annotations that *tick* cannot be speculated, because these +-- are meant to identify whether or not (and how often) the particular +-- source expression was evaluated at runtime. +expr_ok fun_ok primop_ok (Tick tickish e) + | tickishCounts tickish = False + | otherwise = expr_ok fun_ok primop_ok e + +expr_ok _ _ (Let {}) = False +-- See W3 in the Haddock comment for exprOkForSpeculation + +expr_ok fun_ok primop_ok (Case scrut bndr _ alts) + = -- See Note [exprOkForSpeculation: case expressions] + expr_ok fun_ok primop_ok scrut + && isUnliftedType (idType bndr) + -- OK to call isUnliftedType: binders always have a fixed RuntimeRep + && all (\(Alt _ _ rhs) -> expr_ok fun_ok primop_ok rhs) alts + && altsAreExhaustive alts + +expr_ok fun_ok primop_ok other_expr + | (expr, args) <- collectArgs other_expr + = case stripTicksTopE (not . tickishCounts) expr of + Var f -> + app_ok fun_ok primop_ok f args + + -- 'LitRubbish' is the only literal that can occur in the head of an + -- application and will not be matched by the above case (Var /= Lit). + -- See Note [How a rubbish literal can be the head of an application] + -- in GHC.Types.Literal + Lit lit | debugIsOn, not (isLitRubbish lit) + -> pprPanic "Non-rubbish lit in app head" (ppr lit) + | otherwise + -> True + + _ -> False + +----------------------------- +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 unary_class -> not unary_class + -- DFuns terminate, unless the dict is implemented + -- by a no-op in which case they may not + -- See (UCM3) in Note [Unary class magic] in GHC.Core.TyCon + + DataConWorkId dc + | isLazyDataConRep dc + -> args_ok + | otherwise + -> fields_ok (dataConRepStrictness dc) + + ClassOpId _ is_terminating_result + | is_terminating_result -- See Note [exprOkForSpeculation and type classes] + -> assertPpr (n_val_args == 1) (ppr fun $$ ppr args) $ + True + -- assert: terminating result type => can't be applied; + -- c.f the _other case below + + PrimOpId op _ + | primOpIsDiv op + , 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) (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 + -- if the divisor is definitely non-zero. + -- Often there is a literal divisor, and this + -- can get rid of a thunk in an inner loop + + | otherwise -> primop_ok op && args_ok + + _other -- Unlifted and terminating types; + -- Also c.f. the Var case of exprIsHNF + | isTerminatingType fun_ty -- See Note [exprOkForSpeculation and type classes] + || definitelyUnliftedType fun_ty + -> assertPpr (n_val_args == 0) (ppr fun $$ ppr args) + True -- Both terminating types (e.g. Eq a), and unlifted types (e.g. Int#) + -- are non-functions and so will have no value args. The assert is + -- just to check this. + -- (If we added unlifted function types this would change, + -- and we'd need to actually test n_val_args == 0.) + + -- Functions that terminate fast without raising exceptions etc + -- See (U12) of Note [Implementing unsafeCoerce] + | fun `hasKey` unsafeEqualityProofIdKey -> True + + | otherwise -> False + -- NB: even in the nullary case, do /not/ check + -- for evaluated-ness of the fun; + -- see Note [exprOkForSpeculation and evaluated variables] + where + fun_ty = idType fun + n_val_args = valArgCount args + (arg_tys, _) = splitPiTys fun_ty + + -- 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 -- 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 [] + = True -- The scrutinee never returns; see Note [Empty case alternatives] in GHC.Core +altsAreExhaustive (Alt con1 _ _ : alts) + = case con1 of + DEFAULT -> True + LitAlt {} -> False + DataAlt c -> alts `lengthIs` (tyConFamilySize (dataConTyCon c) - 1) + -- It is possible to have an exhaustive case that does not + -- enumerate all constructors, notably in a GADT match, but + -- we behave conservatively here -- I don't think it's important + -- enough to deserve special treatment + +-- | Should we look past this tick when eta-expanding the given function? +-- +-- See Note [Ticks and mandatory eta expansion] +-- Takes the function we are applying as argument. +etaExpansionTick :: Id -> GenTickish pass -> Bool +etaExpansionTick id t + = hasNoBinding id && + ( tickishFloatable t || isProfTick t ) + +{- Note [exprOkForSpeculation and type classes] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider (#22745, #15205) + + \(d :: C a b). case eq_sel (sc_sel d) of + (co :: t1 ~# t2) [Dead] -> blah + +We know that +* eq_sel's argument (sc_sel d) has dictionary type, so it definitely terminates + (again Note [NON-BOTTOM-DICTS invariant] in GHC.Core) +* eq_sel is simply a superclass selector, and hence is fast +* The field that eq_sel picks is of unlifted type, and hence can't be bottom + (remember the dictionary argument itself is non-bottom) + +So we can treat (eq_sel (sc_sel d)) as ok-for-speculation. We must check + +a) That the function is a class-op, with IdDetails of ClassOpId + +b) That the result type of the class-op is terminating or unlifted. E.g. for + class C a => D a where ... + class C a where { op :: a -> a } + Since C is represented by a newtype, (sc_sel (d :: D a)) might + not be terminating. + +Rather than repeatedly test if the result of the class-op is a +terminating/unlifted type, we cache it as a field of ClassOpId. See +GHC.Types.Id.Make.mkDictSelId for where this field is initialised. + +Note [exprOkForSpeculation: case expressions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +exprOkForSpeculation accepts very special case expressions. +Reason: (a ==# b) is ok-for-speculation, but the litEq rules +in GHC.Core.Opt.ConstantFold convert it (a ==# 3#) to + case a of { DEFAULT -> 0#; 3# -> 1# } +for excellent reasons described in + GHC.Core.Opt.ConstantFold Note [The litEq rule: converting equality to case]. +So, annoyingly, we want that case expression to be +ok-for-speculation too. Bother. + +But we restrict it sharply: + +* We restrict it to unlifted scrutinees. Consider this: + case x of y { + DEFAULT -> ... (let v::Int# = case y of { True -> e1 + ; False -> e2 } + in ...) ... + + Does the RHS of v satisfy the let-can-float invariant? Previously we said + yes, on the grounds that y is evaluated. But the binder-swap done + by GHC.Core.Opt.SetLevels would transform the inner alternative to + DEFAULT -> ... (let v::Int# = case x of { ... } + in ...) .... + which does /not/ satisfy the let-can-float invariant, because x is + not evaluated. See Note [Binder-swap during float-out] + in GHC.Core.Opt.SetLevels. To avoid this awkwardness it seems simpler + to stick to unlifted scrutinees where the issue does not + arise. + +* We restrict it to exhaustive alternatives. A non-exhaustive + case manifestly isn't ok-for-speculation. for example, + this is a valid program (albeit a slightly dodgy one) + let v = case x of { B -> ...; C -> ... } + in case x of + A -> ... + _ -> ...v...v.... + Should v be considered ok-for-speculation? Its scrutinee may be + evaluated, but the alternatives are incomplete so we should not + evaluate it strictly. + + Now, all this is for lifted types, but it'd be the same for any + finite unlifted type. We don't have many of them, but we might + add unlifted algebraic types in due course. + + +----- Historical note: #15696: -------- + Previously GHC.Core.Opt.SetLevels used exprOkForSpeculation to guide + floating of single-alternative cases; it now uses exprIsHNF + Note [Floating single-alternative cases]. + + But in those days, consider + case e of x { DEAFULT -> + ...(case x of y + A -> ... + _ -> ...(case (case x of { B -> p; C -> p }) of + I# r -> blah)... + If GHC.Core.Opt.SetLevels considers the inner nested case as + ok-for-speculation it can do case-floating (in GHC.Core.Opt.SetLevels). + So we'd float to: + case e of x { DEAFULT -> + case (case x of { B -> p; C -> p }) of I# r -> + ...(case x of y + A -> ... + _ -> ...blah...)... + which is utterly bogus (seg fault); see #5453. + +----- Historical note: #3717: -------- + foo :: Int -> Int + foo 0 = 0 + foo n = (if n < 5 then 1 else 2) `seq` foo (n-1) + +In earlier GHCs, we got this: + T.$wfoo = + \ (ww :: GHC.Prim.Int#) -> + case ww of ds { + __DEFAULT -> case (case <# ds 5 of _ { + GHC.Types.False -> lvl1; + GHC.Types.True -> lvl}) + of _ { __DEFAULT -> + T.$wfoo (GHC.Prim.-# ds_XkE 1) }; + 0 -> 0 } + +Before join-points etc we could only get rid of two cases (which are +redundant) by recognising that the (case <# ds 5 of { ... }) is +ok-for-speculation, even though it has /lifted/ type. But now join +points do the job nicely. +------- End of historical note ------------ + + +Note [exprOkForSpeculation and evaluated variables] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider these examples: + * case x of y { DEFAULT -> ....y.... } + Should 'y' (alone) be considered ok-for-speculation? + + * 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 = dataToTagLarge# x... } + +And now the expression does not obey the let-can-float invariant! Yikes! +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 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. + +************************************************************************ +* * + exprIsHNF, exprIsConLike +* * +************************************************************************ +-} + +-- Note [exprIsHNF] See also Note [exprIsCheap and exprIsHNF] +-- ~~~~~~~~~~~~~~~~ +-- | exprIsHNF returns true for expressions that are certainly /already/ +-- evaluated to /head/ normal form. This is used to decide whether it's ok +-- to perform case-to-let for lifted expressions, which changes: +-- +-- > case x of x' { _ -> e } +-- +-- into: +-- +-- > let x' = x in e +-- +-- 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: +-- +-- > (:) (f x) (map f xs) +-- > map (...redex...) +-- +-- because 'seq' on such things completes immediately. +-- +-- For unlifted argument types, we have to be careful: +-- +-- > C (f x :: Int#) +-- +-- Suppose @f x@ diverges; then @C (f x)@ is not a value. +-- We check for this using needsCaseBinding below +exprIsHNF :: CoreExpr -> Bool -- True => Value-lambda, constructor, PAP +exprIsHNF = exprIsHNFlike isDataConWorkId isEvaldUnfolding + +-- | Similar to 'exprIsHNF' but includes CONLIKE functions as well as +-- data constructors. Conlike arguments are considered interesting by the +-- inliner. +exprIsConLike :: CoreExpr -> Bool -- True => lambda, conlike, PAP +exprIsConLike = exprIsHNFlike isConLikeId isConLikeUnfolding + +-- | Returns true for values or value-like expressions. These are lambdas, +-- constructors / CONLIKE functions (as determined by the function argument) +-- or PAPs. +-- +exprIsHNFlike :: HasDebugCallStack => (Var -> Bool) -> (Unfolding -> Bool) -> CoreExpr -> Bool +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 [] -- 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) + -- Contrast with Note [exprOkForSpeculation and evaluated variables] + -- We don't look through loop breakers here, which is a bit conservative + -- but otherwise I worry that if an Id's unfolding is just itself, + -- we could get an infinite loop + + || definitelyUnliftedType (idType v) + -- Unlifted binders are always evaluated (#20140) + + is_hnf_like (Lit l) = not (isLitRubbish l) + -- Regarding a LitRubbish as ConLike leads to unproductive inlining in + -- WWRec, see #20035 + is_hnf_like (Type _) = True -- Types are honorary Values; + -- we don't mind copying them + is_hnf_like (Coercion _) = True -- Same for coercions + is_hnf_like (Lam b e) = isRuntimeVar b || is_hnf_like e + is_hnf_like (Tick tickish e) = not (tickishCounts tickish) + && is_hnf_like e + -- 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 [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 + + -- 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 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] +~~~~~~~~~~~~~~~~~~~~~ +We can discard source annotations on HNFs as long as they aren't +tick-like: + + scc c (\x . e) => \x . e + scc c (C x1..xn) => C x1..xn + +So we regard these as HNFs. Tick annotations that tick are not +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? +exprIsTopLevelBindable :: CoreExpr -> Type -> Bool +-- See Note [Core top-level string literals] +-- Precondition: exprType expr = ty +-- Top-level literal strings can't even be wrapped in ticks +-- see Note [Core top-level string literals] in "GHC.Core" +exprIsTopLevelBindable expr ty + = not (mightBeUnliftedType ty) + -- Note that 'expr' may not have a fixed runtime representation here, + -- consequently we must use 'mightBeUnliftedType' rather than 'isUnliftedType', + -- as the latter would panic. + || exprIsTickedString expr + +-- | Check if the expression is zero or more Ticks wrapped around a literal +-- string. +exprIsTickedString :: CoreExpr -> Bool +exprIsTickedString = isJust . exprIsTickedString_maybe + +-- | Extract a literal string from an expression that is zero or more Ticks +-- wrapped around a literal string. Returns Nothing if the expression has a +-- different shape. +-- Used to "look through" Ticks in places that need to handle literal strings. +exprIsTickedString_maybe :: CoreExpr -> Maybe ByteString +exprIsTickedString_maybe (Lit (LitString bs)) = Just bs +exprIsTickedString_maybe (Tick t e) + -- we don't tick literals with CostCentre ticks, compare to mkTick + | tickishPlace t == PlaceCostCentre = Nothing + | otherwise = exprIsTickedString_maybe e +exprIsTickedString_maybe _ = Nothing + +{- +************************************************************************ +* * + Instantiating data constructors +* * +************************************************************************ + +These InstPat functions go here to avoid circularity between DataCon and Id +-} + +dataConRepInstPat :: [Unique] -> Mult -> DataCon -> [Type] -> ([TyCoVar], [Id]) +dataConRepFSInstPat :: [FastString] -> [Unique] -> Mult -> DataCon -> [Type] -> ([TyCoVar], [Id]) + +dataConRepInstPat = dataConInstPat (repeat ((fsLit "ipv"))) +dataConRepFSInstPat = dataConInstPat + +dataConInstPat :: [FastString] -- A long enough list of FSs to use for names + -> [Unique] -- An equally long list of uniques, at least one for each binder + -> Mult -- The multiplicity annotation of the case expression: scales the multiplicity of variables + -> DataCon + -> [Type] -- Types to instantiate the universally quantified tyvars + -> ([TyCoVar], [Id]) -- Return instantiated variables +-- dataConInstPat arg_fun fss us mult con inst_tys returns a tuple +-- (ex_tvs, arg_ids), +-- +-- ex_tvs are intended to be used as binders for existential type args +-- +-- arg_ids are intended to be used as binders for value arguments, +-- and their types have been instantiated with inst_tys and ex_tys +-- The arg_ids include both evidence and +-- programmer-specified arguments (both after rep-ing) +-- +-- Example. +-- The following constructor T1 +-- +-- data T a where +-- T1 :: forall b. Int -> b -> T(a,b) +-- ... +-- +-- has representation type +-- forall a. forall a1. forall b. (a ~ (a1,b)) => +-- Int -> b -> T a +-- +-- dataConInstPat fss us T1 (a1',b') will return +-- +-- ([a1'', b''], [c :: (a1', b')~(a1'', b''), x :: Int, y :: b'']) +-- +-- where the double-primed variables are created with the FastStrings and +-- Uniques given as fss and us +dataConInstPat fss uniqs mult con inst_tys + = assert (univ_tvs `equalLength` inst_tys) $ + (ex_bndrs, arg_ids) + where + univ_tvs = dataConUnivTyVars con + ex_tvs = dataConExTyCoVars con + arg_tys = dataConRepArgTys con + arg_strs = dataConRepStrictness con -- 1-1 with arg_tys + n_ex = length ex_tvs + + -- split the Uniques and FastStrings + (ex_uniqs, id_uniqs) = splitAt n_ex uniqs + (ex_fss, id_fss) = splitAt n_ex fss + + -- Make the instantiating substitution for universals + univ_subst = zipTvSubst univ_tvs inst_tys + + -- Make existential type variables, applying and extending the substitution + (full_subst, ex_bndrs) = mapAccumL mk_ex_var univ_subst + (zip3 ex_tvs ex_fss ex_uniqs) + + mk_ex_var :: Subst -> (TyCoVar, FastString, Unique) -> (Subst, TyCoVar) + mk_ex_var subst (tv, fs, uniq) = (Type.extendTCvSubstWithClone subst tv + new_tv + , new_tv) + where + new_tv | isTyVar tv + = mkTyVar (mkSysTvName uniq fs) kind + | otherwise + = mkCoVar (mkSystemVarName uniq fs) kind + kind = Type.substTyUnchecked subst (varType tv) + + -- Make value vars, instantiating types + arg_ids = zipWith4 mk_id_var id_uniqs id_fss arg_tys arg_strs + mk_id_var uniq fs (Scaled m ty) str + = setCaseBndrEvald str $ -- See Note [Mark evaluated arguments] + mkUserLocalOrCoVar (mkVarOccFS fs) uniq + (mult `mkMultMul` m) (Type.substTy full_subst ty) noSrcSpan + +{- +Note [Mark evaluated arguments] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When pattern matching on a constructor with strict fields, the binder +can have an 'evaldUnfolding'. Moreover, it *should* have one, so that +when loading an interface file unfolding like: + data T = MkT !Int + f x = case x of { MkT y -> let v::Int# = case y of I# n -> n+1 + in ... } +we don't want Lint to complain. The 'y' is evaluated, so the +case in the RHS of the binding for 'v' is fine. But only if we +*know* that 'y' is evaluated. + +c.f. add_evals in GHC.Core.Opt.Simplify.simplAlt + +************************************************************************ +* * + Equality +* * +************************************************************************ +-} + +-- | A cheap equality test which bales out fast! +-- If it returns @True@ the arguments are definitely equal, +-- otherwise, they may or may not be equal. +cheapEqExpr :: Expr b -> Expr b -> Bool +cheapEqExpr = cheapEqExpr' (const False) + +-- | Cheap expression equality test, can ignore ticks by type. +cheapEqExpr' :: (CoreTickish -> Bool) -> Expr b -> Expr b -> Bool +{-# INLINE cheapEqExpr' #-} +cheapEqExpr' ignoreTick e1 e2 + = go e1 e2 + where + go (Var v1) (Var v2) = v1 == v2 + go (Lit lit1) (Lit lit2) = lit1 == lit2 + go (Type t1) (Type t2) = t1 `eqType` t2 + go (Coercion c1) (Coercion c2) = c1 `eqCoercion` c2 + go (App f1 a1) (App f2 a2) = f1 `go` f2 && a1 `go` a2 + go (Cast e1 t1) (Cast e2 t2) = e1 `go` e2 && t1 `eqCoercion` t2 + + go (Tick t1 e1) e2 | ignoreTick t1 = go e1 e2 + go e1 (Tick t2 e2) | ignoreTick t2 = go e1 e2 + go (Tick t1 e1) (Tick t2 e2) = t1 == t2 && e1 `go` e2 + + go _ _ = False + + + +-- Used by diffBinds, which is itself only used in GHC.Core.Lint.lintAnnots +eqTickish :: RnEnv2 -> CoreTickish -> CoreTickish -> Bool +eqTickish env (Breakpoint lext lid lids) (Breakpoint rext rid rids) + = lid == rid && + map (rnOccL env) lids == map (rnOccR env) rids && + lext == rext +eqTickish _ l r = l == r + +-- | Finds differences between core bindings, see @diffExpr@. +-- +-- The main problem here is that while we expect the binds to have the +-- same order in both lists, this is not guaranteed. To do this +-- properly we'd either have to do some sort of unification or check +-- all possible mappings, which would be seriously expensive. So +-- instead we simply match single bindings as far as we can. This +-- leaves us just with mutually recursive and/or mismatching bindings, +-- which we then speculatively match by ordering them. It's by no means +-- perfect, but gets the job done well enough. +-- +-- Only used in GHC.Core.Lint.lintAnnots +diffBinds :: Bool -> RnEnv2 -> [(Var, CoreExpr)] -> [(Var, CoreExpr)] + -> ([SDoc], RnEnv2) +diffBinds top env binds1 = go (length binds1) env binds1 + where go _ env [] [] + = ([], env) + go _fuel env [] binds2 + -- No binds remaining to compare on the left? Bail out early. + = (warn env [] binds2, env) + go _fuel env binds1 [] + -- No binds remaining to compare on the right? Bail out early. + = (warn env binds1 [], env) + go fuel env binds1@(bind1:_) binds2@(_:_) + -- Iterated over all binds without finding a match? Then + -- try speculatively matching binders by order. + | fuel == 0 + = if not $ env `inRnEnvL` fst bind1 + then let env' = uncurry (rnBndrs2 env) $ unzip $ + zip (sort $ map fst binds1) (sort $ map fst binds2) + in go (length binds1) env' binds1 binds2 + -- If we have already tried that, give up + else (warn env binds1 binds2, env) + go fuel env ((bndr1,expr1):binds1) binds2 + | let matchExpr (bndr,expr) = + (isTyVar bndr || not top || null (diffIdInfo env bndr bndr1)) && + null (diffExpr top (rnBndr2 env bndr1 bndr) expr1 expr) + + , (binds2l, (bndr2,_):binds2r) <- break matchExpr binds2 + = go (length binds1) (rnBndr2 env bndr1 bndr2) + binds1 (binds2l ++ binds2r) + | otherwise -- No match, so push back (FIXME O(n^2)) + = go (fuel-1) env (binds1++[(bndr1,expr1)]) binds2 + + -- We have tried everything, but couldn't find a good match. So + -- now we just return the comparison results when we pair up + -- the binds in a pseudo-random order. + warn env binds1 binds2 = + concatMap (uncurry (diffBind env)) (zip binds1' binds2') ++ + unmatched "unmatched left-hand:" (drop l binds1') ++ + unmatched "unmatched right-hand:" (drop l binds2') + where binds1' = sortBy (comparing fst) binds1 + binds2' = sortBy (comparing fst) binds2 + l = min (length binds1') (length binds2') + unmatched _ [] = [] + unmatched txt bs = [text txt $$ ppr (Rec bs)] + diffBind env (bndr1,expr1) (bndr2,expr2) + | ds@(_:_) <- diffExpr top env expr1 expr2 + = locBind "in binding" bndr1 bndr2 ds + -- Special case for TyVar, which we checked were bound to the same types in + -- diffExpr, but don't have any IdInfo we would panic if called diffIdInfo. + -- These let-bound types are created temporarily by the simplifier but inlined + -- immediately. + | isTyVar bndr1 && isTyVar bndr2 + = [] + | otherwise + = diffIdInfo env bndr1 bndr2 + +-- | Finds differences between core expressions, modulo alpha and +-- renaming. Setting @top@ means that the @IdInfo@ of bindings will be +-- checked for differences as well. +diffExpr :: Bool -> RnEnv2 -> CoreExpr -> CoreExpr -> [SDoc] +diffExpr _ env (Var v1) (Var v2) | rnOccL env v1 == rnOccR env v2 = [] +diffExpr _ _ (Lit lit1) (Lit lit2) | lit1 == lit2 = [] +diffExpr _ env (Type t1) (Type t2) | eqTypeX env t1 t2 = [] +diffExpr _ env (Coercion co1) (Coercion co2) + | eqCoercionX env co1 co2 = [] +diffExpr top env (Cast e1 co1) (Cast e2 co2) + | eqCoercionX env co1 co2 = diffExpr top env e1 e2 +diffExpr top env (Tick n1 e1) e2 + | not (tickishIsCode n1) = diffExpr top env e1 e2 +diffExpr top env e1 (Tick n2 e2) + | not (tickishIsCode n2) = diffExpr top env e1 e2 +diffExpr top env (Tick n1 e1) (Tick n2 e2) + | eqTickish env n1 n2 = diffExpr top env e1 e2 + -- The error message of failed pattern matches will contain + -- generated names, which are allowed to differ. +diffExpr _ _ (App (App (Var absent) _) _) + (App (App (Var absent2) _) _) + | isDeadEndId absent && isDeadEndId absent2 = [] +diffExpr top env (App f1 a1) (App f2 a2) + = diffExpr top env f1 f2 ++ diffExpr top env a1 a2 +diffExpr top env (Lam b1 e1) (Lam b2 e2) + | eqTypeX env (varType b1) (varType b2) -- False for Id/TyVar combination + = diffExpr top (rnBndr2 env b1 b2) e1 e2 +diffExpr top env (Let bs1 e1) (Let bs2 e2) + = let (ds, env') = diffBinds top env (flattenBinds [bs1]) (flattenBinds [bs2]) + in ds ++ diffExpr top env' e1 e2 +diffExpr top env (Case e1 b1 t1 a1) (Case e2 b2 t2 a2) + | equalLength a1 a2 && not (null a1) || eqTypeX env t1 t2 + -- See Note [Empty case alternatives] in GHC.Data.TrieMap + = diffExpr top env e1 e2 ++ concat (zipWith diffAlt a1 a2) + where env' = rnBndr2 env b1 b2 + diffAlt (Alt c1 bs1 e1) (Alt c2 bs2 e2) + | c1 /= c2 = [text "alt-cons " <> ppr c1 <> text " /= " <> ppr c2] + | otherwise = diffExpr top (rnBndrs2 env' bs1 bs2) e1 e2 +diffExpr _ _ e1 e2 + = [fsep [ppr e1, text "/=", ppr e2]] + +-- | Find differences in @IdInfo@. We will especially check whether +-- the unfoldings match, if present (see @diffUnfold@). +diffIdInfo :: RnEnv2 -> Var -> Var -> [SDoc] +diffIdInfo env bndr1 bndr2 + | arityInfo info1 == arityInfo info2 + && cafInfo info1 == cafInfo info2 + && oneShotInfo info1 == oneShotInfo info2 + && inlinePragInfo info1 == inlinePragInfo info2 + && occInfo info1 == occInfo info2 + && demandInfo info1 == demandInfo info2 + && callArityInfo info1 == callArityInfo info2 + = locBind "in unfolding of" bndr1 bndr2 $ + diffUnfold env (realUnfoldingInfo info1) (realUnfoldingInfo info2) + | otherwise + = locBind "in Id info of" bndr1 bndr2 + [fsep [pprBndr LetBind bndr1, text "/=", pprBndr LetBind bndr2]] + where info1 = idInfo bndr1; info2 = idInfo bndr2 + +-- | Find differences in unfoldings. Note that we will not check for +-- differences of @IdInfo@ in unfoldings, as this is generally +-- redundant, and can lead to an exponential blow-up in complexity. +diffUnfold :: RnEnv2 -> Unfolding -> Unfolding -> [SDoc] +diffUnfold _ NoUnfolding NoUnfolding = [] +diffUnfold _ BootUnfolding BootUnfolding = [] +diffUnfold _ (OtherCon cs1) (OtherCon cs2) | cs1 == cs2 = [] +diffUnfold env (DFunUnfolding bs1 c1 a1) + (DFunUnfolding bs2 c2 a2) + | c1 == c2 && equalLength bs1 bs2 + = concatMap (uncurry (diffExpr False env')) (zip a1 a2) + where env' = rnBndrs2 env bs1 bs2 +diffUnfold env (CoreUnfolding t1 _ _ c1 g1) + (CoreUnfolding t2 _ _ c2 g2) + | c1 == c2 && g1 == g2 + = diffExpr False env t1 t2 +diffUnfold _ uf1 uf2 + = [fsep [ppr uf1, text "/=", ppr uf2]] + +-- | Add location information to diff messages +locBind :: String -> Var -> Var -> [SDoc] -> [SDoc] +locBind loc b1 b2 diffs = map addLoc diffs + where addLoc d = d $$ nest 2 (parens (text loc <+> bindLoc)) + bindLoc | b1 == b2 = ppr b1 + | otherwise = ppr b1 <> char '/' <> ppr b2 + + +{- ********************************************************************* +* * +\subsection{Determining non-updatable right-hand-sides} +* * +************************************************************************ + +Top-level constructor applications can usually be allocated +statically, but they can't if the constructor, or any of the +arguments, come from another DLL (because we can't refer to static +labels in other DLLs). + +If this happens we simply make the RHS into an updatable thunk, +and 'execute' it rather than allocating it statically. +-} + +{- +************************************************************************ +* * +\subsection{Type utilities} +* * +************************************************************************ +-} + +-- | True if the type has no non-bottom elements, e.g. when it is an empty +-- datatype, or a GADT with non-satisfiable type parameters, e.g. Int :~: Bool. +-- See Note [Bottoming expressions] +-- +-- See Note [No alternatives lint check] for another use of this function. +isEmptyTy :: Type -> Bool +isEmptyTy ty + -- Data types where, given the particular type parameters, no data + -- constructor matches, are empty. + -- This includes data types with no constructors, e.g. Data.Void.Void. + | Just (tc, inst_tys) <- splitTyConApp_maybe ty + , Just dcs <- tyConDataCons_maybe tc + , all (dataConCannotMatch inst_tys) dcs + = True + | otherwise + = False + +-- | 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 + +{- +***************************************************** +* +* InScopeSet things +* +***************************************************** +-} + + +extendInScopeSetBind :: InScopeSet -> CoreBind -> InScopeSet +extendInScopeSetBind (InScope in_scope) binds + = InScope $ foldBindersOfBindStrict extendVarSet in_scope binds + +extendInScopeSetBndrs :: InScopeSet -> [CoreBind] -> InScopeSet +extendInScopeSetBndrs (InScope in_scope) binds + = InScope $ foldBindersOfBindsStrict extendVarSet in_scope binds + +mkInScopeSetBndrs :: [CoreBind] -> InScopeSet +mkInScopeSetBndrs binds = foldBindersOfBindsStrict extendInScopeSet emptyInScopeSet binds + +{- +***************************************************** +* +* StaticPtr +* +***************************************************** +-} + +-- | @collectMakeStaticArgs (makeStatic t srcLoc e)@ yields +-- @Just (makeStatic, t, srcLoc, e)@. +-- +-- Returns @Nothing@ for every other expression. +collectMakeStaticArgs + :: CoreExpr -> Maybe (CoreExpr, Type, CoreExpr, CoreExpr) +collectMakeStaticArgs e + | (fun@(Var b), [Type t, loc, arg], _) <- collectArgsTicks (const True) e + , idName b == makeStaticName = Just (fun, t, loc, arg) +collectMakeStaticArgs _ = Nothing + +{- +************************************************************************ +* * +\subsection{Join points} +* * +************************************************************************ +-} + +-- | Does this binding bind a join point (or a recursive group of join points)? +isJoinBind :: CoreBind -> Bool +isJoinBind (NonRec b _) = isJoinId b +isJoinBind (Rec ((b, _) : _)) = isJoinId b +isJoinBind _ = False + +dumpIdInfoOfProgram :: Bool -> (IdInfo -> SDoc) -> CoreProgram -> SDoc +dumpIdInfoOfProgram dump_locals ppr_id_info binds = vcat (map printId ids) + where + ids = sortBy (stableNameCmp `on` getName) (concatMap getIds binds) + getIds (NonRec i _) = [ i ] + getIds (Rec bs) = map fst bs + -- By default only include full info for exported ids, unless we run in the verbose + -- pprDebug mode. + printId id | isExportedId id || dump_locals = ppr id <> colon <+> (ppr_id_info (idInfo id)) + | otherwise = empty + +{- +************************************************************************ +* * +\subsection{Tag inference things} +* * +************************************************************************ +-} + +{- Note [Call-by-value for worker args] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If we unbox a constructor with strict fields we want to +preserve the information that some of the arguments came +out of strict fields and therefore should be already properly +tagged, however we can't express this directly in core. + +Instead what we do is generate a worker like this: + + data T = MkT A !B + + foo = case T of MkT a b -> $wfoo a b + + $wfoo a b = case b of b' -> rhs[b/b'] + +This makes the worker strict in b causing us to use a more efficient +calling convention for `b` where the caller needs to ensure `b` is +properly tagged and evaluated before it's passed to $wfoo. See Note [CBV Function Ids]. + +Usually the argument will be known to be properly tagged at the call site so there is +no additional work for the caller and the worker can be more efficient since it can +assume the presence of a tag. + +This is especially true for recursive functions like this: + -- myPred expect it's argument properly tagged + myPred !x = ... + + loop :: MyPair -> Int + loop (MyPair !x !y) = + case x of + A -> 1 + B -> 2 + _ -> loop (MyPair (myPred x) (myPred y)) + +Here we would ordinarily not be strict in y after unboxing. +However if we pass it as a regular argument then this means on +every iteration of loop we will incur an extra seq on y before +we can pass it to `myPred` which isn't great! That is in STG after +tag inference we get: + + Rec { + Find.$wloop [InlPrag=[2], Occ=LoopBreaker] + :: Find.MyEnum -> Find.MyEnum -> GHC.Prim.Int# + [GblId[StrictWorker([!, ~])], + Arity=2, + Str=<1L>, + Unf=OtherCon []] = + {} \r [x y] + case x of x' [Occ=Once1] { + __DEFAULT -> + case y of y' [Occ=Once1] { + __DEFAULT -> + case Find.$wmyPred y' of pred_y [Occ=Once1] { + __DEFAULT -> + case Find.$wmyPred x' of pred_x [Occ=Once1] { + __DEFAULT -> Find.$wloop pred_x pred_y; + }; + }; + Find.A -> 1#; + Find.B -> 2#; + }; + end Rec } + +Here comes the tricky part: If we make $wloop strict in both x/y and we get: + + Rec { + Find.$wloop [InlPrag=[2], Occ=LoopBreaker] + :: Find.MyEnum -> Find.MyEnum -> GHC.Prim.Int# + [GblId[StrictWorker([!, !])], + Arity=2, + Str=<1L>, + Unf=OtherCon []] = + {} \r [x y] + case y of y' [Occ=Once1] { __DEFAULT -> + case x of x' [Occ=Once1] { + __DEFAULT -> + case Find.$wmyPred y' of pred_y [Occ=Once1] { + __DEFAULT -> + case Find.$wmyPred x' of pred_x [Occ=Once1] { + __DEFAULT -> Find.$wloop pred_x pred_y; + }; + }; + Find.A -> 1#; + Find.B -> 2#; + }; + end Rec } + +Here both x and y are known to be tagged in the function body since we pass strict worker args using unlifted cbv. +This means the seqs on x and y both become no-ops and compared to the first version the seq on `y` disappears at runtime. + +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 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 +it would be useless to insert an extra seq. ShouldStrictifyIdForCbv tries to identify these to avoid churn in the +simplifier. See Note [Which Ids should be strictified] for details on this. +-} +mkStrictFieldSeqs :: [(Id,StrictnessMark)] -> CoreExpr -> (CoreExpr) +mkStrictFieldSeqs args rhs = + foldr addEval rhs args + where + case_ty = exprType rhs + addEval :: (Id,StrictnessMark) -> (CoreExpr) -> (CoreExpr) + addEval (arg_id,arg_cbv) (rhs) + -- Argument representing strict field. + | isMarkedStrict arg_cbv + , shouldStrictifyIdForCbv arg_id + -- Make sure to remove unfoldings here to avoid the simplifier dropping those for OtherCon[] unfoldings. + = Case (Var $! zapIdUnfolding arg_id) arg_id case_ty ([Alt DEFAULT [] rhs]) + -- Normal argument + | otherwise = do + rhs + +{- Note [Which Ids should be strictified] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +For some arguments we would like to convince GHC to pass them call by value. +One way to achieve this is described in see Note [Call-by-value for worker args]. + +We separate the concerns of "should we pass this argument using cbv" and +"should we do so by making the rhs strict in this argument". +This note deals with the second part. + +There are multiple reasons why we might not want to insert a seq in the rhs to +strictify a functions argument: + +1) The argument doesn't exist at runtime. + +For zero width types (like Types) there is no benefit as we don't operate on them +at runtime at all. This includes things like void#, coercions and state tokens. + +2) The argument is a unlifted type. + +If the argument is a unlifted type the calling convention already is explicitly +cbv. This means inserting a seq on this argument wouldn't do anything as the seq +would be a no-op *and* it wouldn't affect the calling convention. + +3) The argument is absent. + +If the argument is absent in the body there is no advantage to it being passed as +cbv to the function. The function won't ever look at it so we don't safe any work. + +This mostly happens for join point. For example we might have: + + data T = MkT ![Int] [Char] + f t = case t of MkT xs{strict} ys-> snd (xs,ys) + +and abstract the case alternative to: + + f t = join j1 = \xs ys -> snd (xs,ys) + in case t of MkT xs{strict} ys-> j1 xs xy + +While we "use" xs inside `j1` it's not used inside the function `snd` we pass it to. +In short a absent demand means neither our RHS, nor any function we pass the argument +to will inspect it. So there is no work to be saved by forcing `xs` early. + +NB: There is an edge case where if we rebox we *can* end up seqing an absent value. +Note [Absent fillers] has an example of this. However this is so rare it's not worth +caring about here. + +4) The argument is already strict. + +Consider this code: + + data T = MkT ![Int] + f t = case t of MkT xs{strict} -> reverse xs + +The `xs{strict}` indicates that `xs` is used strictly by the `reverse xs`. +If we do a w/w split, and add the extra eval on `xs`, we'll get + + $wf xs = + case xs of xs1 -> + let t = MkT xs1 in + case t of MkT xs2 -> reverse xs2 + +That's not wrong; but the w/w body will simplify to + + $wf xs = case xs of xs1 -> reverse xs1 + +and now we'll drop the `case xs` because `xs1` is used strictly in its scope. +Adding that eval was a waste of time. So don't add it for strictly-demanded Ids. + +5) Functions + +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. + +-} +-- | Do we expect there to be any benefit if we make this var strict +-- in order for it to get treated as as cbv argument? +-- See Note [Which Ids should be strictified] +-- See Note [CBV Function Ids] for more background. +shouldStrictifyIdForCbv :: Var -> Bool +shouldStrictifyIdForCbv = wantCbvForId False + +-- Like shouldStrictifyIdForCbv but also wants to use cbv for strict args. +shouldUseCbvForId :: Var -> Bool +shouldUseCbvForId = wantCbvForId True + +-- 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 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 +wantCbvForId cbv_for_strict v + -- Must be a runtime var. + -- See Note [Which Ids should be strictified] point 1) + | isId v + , not $ isZeroBitTy ty + -- Unlifted things don't need special measures to be treated as cbv + -- 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 EnforceEpt. + -- See Note [Which Ids should be strictified] point 5) + , not $ isFunTy ty + -- If the var is strict already a seq is redundant. + -- See Note [Which Ids should be strictified] point 4) + , not (isStrictDmd dmd) || cbv_for_strict + -- If the var is absent a seq is almost always useless. + -- See Note [Which Ids should be strictified] point 3) + , not (isAbsDmd dmd) + = True + | otherwise + = False + where + ty = idType v + dmd = idDemandInfo v + +{- ********************************************************************* +* * + unsafeEqualityProof +* * +********************************************************************* -} + +isUnsafeEqualityCase :: CoreExpr -> Id -> [CoreAlt] -> Maybe CoreExpr +-- See (U3) and (U4) in +-- Note [Implementing unsafeCoerce] in base:Unsafe.Coerce +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 + = Nothing diff --git a/GHC/CoreToIface.hs b/GHC/CoreToIface.hs --- a/GHC/CoreToIface.hs +++ b/GHC/CoreToIface.hs @@ -43,18 +43,13 @@ , toIfaceVar -- * Other stuff , toIfaceLFInfo - -- * CgBreakInfo - , dehydrateCgBreakInfo + , toIfaceBooleanFormula ) where import GHC.Prelude -import Data.Word - import GHC.StgToCmm.Types -import GHC.ByteCode.Types - import GHC.Core import GHC.Core.TyCon hiding ( pprPromotionQuote ) import GHC.Core.Coercion.Axiom @@ -64,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 @@ -84,11 +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.Misc +import GHC.Hs.Extension (GhcRn) + import Data.Maybe ( isNothing, catMaybes ) {- Note [Avoiding space leaks in toIface*] @@ -123,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) ) @@ -135,7 +134,7 @@ toIfaceIdBndrX :: VarSet -> CoVar -> IfaceIdBndr toIfaceIdBndrX fr covar = ( toIfaceType (idMult covar) - , occNameFS (getOccName covar) + , mkIfLclName (occNameFS (getOccName covar)) , toIfaceTypeX fr (varType covar) ) @@ -178,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 {}) = @@ -220,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 @@ -266,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 ---------------- @@ -285,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) @@ -310,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 @@ -359,12 +360,8 @@ ts' = go (extendTCvSubst env tv t) res ts go env (FunTy { ft_af = af, ft_res = res }) (t:ts) - = IA_Arg (toIfaceTypeX fr t) argf (go env res ts) - where - argf | isVisibleFunArg af = Required - | otherwise = Inferred - -- It's rare for a kind to have a constraint argument, but it - -- can happen. See Note [AnonTCB with constraint arg] in GHC.Core.TyCon. + = assert (isVisibleFunArg af) + IA_Arg (toIfaceTypeX fr t) Required (go env res ts) go env ty ts@(t1:ts1) | not (isEmptyTCvSubst env) @@ -437,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 @@ -448,21 +445,22 @@ 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 toIfaceIdDetails :: IdDetails -> IfaceIdDetails toIfaceIdDetails VanillaId = IfVanillaId -toIfaceIdDetails (WorkerLikeId dmds) = IfWorkerLikeId dmds +toIfaceIdDetails (WorkerLikeId dmds) = IfWorkerLikeId dmds toIfaceIdDetails (DFunId {}) = IfDFunId toIfaceIdDetails (RecSelId { sel_naughty = n - , sel_tycon = tc }) = - let iface = case tc of - RecSelData ty_con -> Left (toIfaceTyCon ty_con) - RecSelPatSyn pat_syn -> Right (patSynToIfaceDecl pat_syn) - in IfRecSelId iface n + , sel_tycon = tc + , sel_fieldLabel = fl }) = + let (iface, first_con) = case tc of + RecSelData ty_con -> ( Left (toIfaceTyCon ty_con), dataConName $ head $ tyConDataCons ty_con) + RecSelPatSyn pat_syn -> ( Right (patSynToIfaceDecl pat_syn), patSynName pat_syn) + in IfRecSelId iface first_con n fl -- The remaining cases are all "implicit Ids" which don't -- appear in interface files at all @@ -506,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 @@ -544,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 + {- ************************************************************************ * * @@ -562,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 @@ -577,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 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 @@ -608,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 @@ -619,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 @@ -627,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 @@ -664,7 +664,7 @@ -- Foreign calls have special syntax | isExternalName name = IfaceExt name - | otherwise = IfaceLcl (getOccFS name) + | otherwise = IfaceLcl (mkIfLclName (occNameFS $ nameOccName name)) where name = idName v ty = idType v @@ -698,16 +698,7 @@ LFLetNoEscape -> panic "toIfaceLFInfo: LFLetNoEscape" --- Dehydrating CgBreakInfo -dehydrateCgBreakInfo :: [TyVar] -> [Maybe (Id, Word16)] -> 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): @@ -780,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 @@ -794,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 -- 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') } - 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) - | not (null bndrs) - = -- The list of arguments is non-empty, so not CAF - ( StgRhsClosure noExtFieldSilent - dontCareCCS - ReEntrant - bndrs rhs - , 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, ccs ) - - -- Otherwise it's a CAF, see Note [Cost-centre initialization plan]. - | opt_AutoSccsOnIndividualCafs - = ( StgRhsClosure noExtFieldSilent - caf_ccs - upd_flag [] rhs - , collectCC caf_cc caf_ccs ccs ) - - | otherwise - = ( StgRhsClosure noExtFieldSilent - all_cafs_ccs - upd_flag [] rhs - , 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) - | not (null bndrs) - = StgRhsClosure noExtFieldSilent - currentCCS - ReEntrant - bndrs rhs - - -- 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 - - | StgConApp con mn args _ <- unticked_rhs - = StgRhsCon currentCCS con mn ticks args - - | otherwise - = StgRhsClosure noExtFieldSilent - currentCCS - upd_flag [] rhs - 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,2362 +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 $ - 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. - -However, 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. -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 [Controlling Speculative Evaluation] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -Most of the time, speculative evaluation has a positive effect on performance, -but we have found a case where speculative evaluation of dictionary functions -leads to a performance regression #25284. - -Therefore we have some flags to control it. See the optimization section in -the User's Guide for the description of these flags and when to use them. - --} - -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 - 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) - -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. - - , 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_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 -> if isTyVar tcv - then return (subst_tv_bndr env tcv) - else return (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,19 +7,20 @@ -} {-# LANGUAGE ScopedTypeVariables, DeriveTraversable, TypeFamilies #-} +{-# OPTIONS_GHC -Wno-unrecognised-warning-flags -Wno-x-data-list-nonempty-unzip #-} module GHC.Data.Bag ( Bag, -- abstract type emptyBag, unitBag, unionBags, unionManyBags, - mapBag, + 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, unzipBag, - mapBagM, mapBagM_, + concatMapBag, concatMapBagPair, mapMaybeBag, mapMaybeBagM, unzipBag, + mapBagM, mapBagM_, lookupBag, flatMapBagM, flatMapBagPairM, mapAndUnzipBagM, mapAccumBagLM, anyBagM, filterBagM @@ -38,6 +39,7 @@ import Data.List.NonEmpty ( NonEmpty(..) ) import qualified Data.List.NonEmpty as NE import qualified Data.Semigroup ( (<>) ) +import Control.Applicative( Alternative( (<|>) ) ) import Control.DeepSeq infixr 3 `consBag` @@ -121,7 +123,19 @@ filterBagM pred (ListBag vs) = do sat <- filterM pred (toList vs) return (listToBag sat) +{-# INLINEABLE filterBagM #-} +lookupBag :: Eq a => a -> Bag (a,b) -> Maybe b +lookupBag _ EmptyBag = Nothing +lookupBag k (UnitBag kv) = lookup_one k kv +lookupBag k (TwoBags b1 b2) = lookupBag k b1 <|> lookupBag k b2 +lookupBag k (ListBag xs) = foldr ((<|>) . lookup_one k) Nothing xs +{-# INLINEABLE lookupBag #-} + +lookup_one :: Eq a => a -> (a,b) -> Maybe b +lookup_one k (k',v) | k==k' = Just v + | otherwise = Nothing + allBag :: (a -> Bool) -> Bag a -> Bool allBag _ EmptyBag = True allBag p (UnitBag v) = p v @@ -141,6 +155,7 @@ if flag then return True else anyBagM p b2 anyBagM p (ListBag xs) = anyM p xs +{-# INLINEABLE anyBagM #-} concatBag :: Bag (Bag a) -> Bag a concatBag = foldr unionBags emptyBag @@ -179,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 @@ -228,6 +229,17 @@ mapMaybeBag f (TwoBags b1 b2) = unionBags (mapMaybeBag f b1) (mapMaybeBag f b2) mapMaybeBag f (ListBag xs) = listToBag $ mapMaybe f (toList xs) +mapMaybeBagM :: Monad m => (a -> m (Maybe b)) -> Bag a -> m (Bag b) +mapMaybeBagM _ EmptyBag = return EmptyBag +mapMaybeBagM f (UnitBag x) = do r <- f x + return $ case r of + Nothing -> EmptyBag + Just y -> UnitBag y +mapMaybeBagM f (TwoBags b1 b2) = do r1 <- mapMaybeBagM f b1 + r2 <- mapMaybeBagM f b2 + return $ unionBags r1 r2 +mapMaybeBagM f (ListBag xs) = listToBag <$> mapMaybeM f (toList xs) + mapBagM :: Monad m => (a -> m b) -> Bag a -> m (Bag b) mapBagM _ EmptyBag = return EmptyBag mapBagM f (UnitBag x) = do r <- f x @@ -237,12 +249,14 @@ return (TwoBags r1 r2) mapBagM f (ListBag xs) = do rs <- mapM f xs return (ListBag rs) +{-# INLINEABLE mapBagM #-} mapBagM_ :: Monad m => (a -> m b) -> Bag a -> m () mapBagM_ _ EmptyBag = return () mapBagM_ f (UnitBag x) = f x >> return () mapBagM_ f (TwoBags b1 b2) = mapBagM_ f b1 >> mapBagM_ f b2 mapBagM_ f (ListBag xs) = mapM_ f xs +{-# INLINEABLE mapBagM_ #-} flatMapBagM :: Monad m => (a -> m (Bag b)) -> Bag a -> m (Bag b) flatMapBagM _ EmptyBag = return EmptyBag @@ -253,6 +267,7 @@ flatMapBagM f (ListBag xs) = foldrM k EmptyBag xs where k x b2 = do { b1 <- f x; return (b1 `unionBags` b2) } +{-# INLINEABLE flatMapBagM #-} flatMapBagPairM :: Monad m => (a -> m (Bag b, Bag c)) -> Bag a -> m (Bag b, Bag c) flatMapBagPairM _ EmptyBag = return (EmptyBag, EmptyBag) @@ -264,6 +279,7 @@ where k x (r2,s2) = do { (r1,s1) <- f x ; return (r1 `unionBags` r2, s1 `unionBags` s2) } +{-# INLINEABLE flatMapBagPairM #-} mapAndUnzipBagM :: Monad m => (a -> m (b,c)) -> Bag a -> m (Bag b, Bag c) mapAndUnzipBagM _ EmptyBag = return (EmptyBag, EmptyBag) @@ -275,6 +291,7 @@ mapAndUnzipBagM f (ListBag xs) = do ts <- mapM f xs let (rs,ss) = NE.unzip ts return (ListBag rs, ListBag ss) +{-# INLINEABLE mapAndUnzipBagM #-} mapAccumBagL ::(acc -> x -> (acc, y)) -- ^ combining function -> acc -- ^ initial state @@ -300,6 +317,7 @@ ; return (s2, TwoBags b1' b2') } mapAccumBagLM f s (ListBag xs) = do { (s', xs') <- mapAccumLM f s xs ; return (s', ListBag xs') } +{-# INLINEABLE mapAccumBagLM #-} listToBag :: [a] -> Bag a listToBag [] = EmptyBag @@ -331,7 +349,10 @@ headMaybe (ListBag (v:|_)) = Just v instance (Outputable a) => Outputable (Bag a) where - ppr bag = braces (pprWithCommas ppr (bagToList bag)) + ppr = pprBag + +pprBag :: Outputable a => Bag a -> SDoc +pprBag bag = braces (pprWithCommas ppr (bagToList bag)) instance Data a => Data (Bag a) where gfoldl k z b = z listToBag `k` bagToList b -- traverse abstract type abstractly 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,76 +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.Utils.Binary -import GHC.Parser.Annotation ( LocatedL, noLocA ) -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] ~~~~~~~~~~~~~~~~~~~~~~ @@ -116,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 @@ -132,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' @@ -156,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 ---------------------------------------------------------------------- @@ -200,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 @@ -231,34 +227,14 @@ 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) go (Parens x) = parens (go $ unLoc x) - - ----------------------------------------------------------------------- --- Binary ----------------------------------------------------------------------- - -instance Binary a => Binary (BooleanFormula a) where - put_ bh (Var x) = putByte bh 0 >> put_ bh x - put_ bh (And xs) = putByte bh 1 >> put_ bh (unLoc <$> xs) - put_ bh (Or xs) = putByte bh 2 >> put_ bh (unLoc <$> xs) - put_ bh (Parens x) = putByte bh 3 >> put_ bh (unLoc x) - - get bh = do - h <- getByte bh - case h of - 0 -> Var <$> get bh - 1 -> And . fmap noLocA <$> get bh - 2 -> Or . fmap noLocA <$> get bh - _ -> Parens . noLocA <$> get bh 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: @@ -52,6 +57,9 @@ fastStringToShortByteString, mkFastStringShortByteString, + -- * ShortText + fastStringToShortText, + -- * FastZString FastZString, hPutFZS, @@ -127,9 +135,7 @@ 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 import Data.Data @@ -138,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 @@ -159,6 +160,9 @@ fastStringToShortByteString :: FastString -> ShortByteString fastStringToShortByteString = fs_sbs +fastStringToShortText :: FastString -> ShortText +fastStringToShortText = ShortText . fs_sbs + fastZStringToByteString :: FastZString -> ByteString fastZStringToByteString (FastZString bs) = bs @@ -197,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 @@ -282,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 @@ -303,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 @@ -387,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 {- @@ -412,7 +424,8 @@ be looked up /by the plugin/. let rdrName = mkModuleName "GHC.NT.Type" `mkRdrQual` mkTcOcc "NT" - putMsgS $ showSDoc dflags $ ppr $ lookupGRE_RdrName rdrName $ mg_rdr_env guts + putMsgS $ showSDoc dflags $ ppr $ + lookupGRE (mg_rdr_env guts) (LookupRdrName rdrName AllRelevantGREs) `mkTcOcc` involves the lookup (or creation) of a FastString. Since the plugin's FastString.string_table is empty, constructing the RdrName also @@ -501,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 = @@ -575,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#) @@ -690,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 @@ -18,7 +18,8 @@ filterFsEnv, plusFsEnv, plusFsEnv_C, alterFsEnv, lookupFsEnv, lookupFsEnv_NF, delFromFsEnv, delListFromFsEnv, - elemFsEnv, mapFsEnv, + elemFsEnv, mapFsEnv, strictMapFsEnv, mapMaybeFsEnv, + nonDetFoldFsEnv, -- * Deterministic FastString environments (maps) DFastStringEnv, @@ -60,6 +61,7 @@ lookupFsEnv_NF :: FastStringEnv a -> FastString -> a filterFsEnv :: (elt -> Bool) -> FastStringEnv elt -> FastStringEnv elt mapFsEnv :: (elt1 -> elt2) -> FastStringEnv elt1 -> FastStringEnv elt2 +mapMaybeFsEnv :: (elt1 -> Maybe elt2) -> FastStringEnv elt1 -> FastStringEnv elt2 emptyFsEnv = emptyUFM unitFsEnv x y = unitUFM x y @@ -78,8 +80,19 @@ delFromFsEnv x y = delFromUFM x y delListFromFsEnv x y = delListFromUFM x y 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 + +-- | Fold over a 'FastStringEnv'. +-- +-- Non-deterministic, unless the folding function is commutative +-- (i.e. @a1 `f` ( a2 `f` b ) == a2 `f` ( a1 `f` b )@ for all @a1@, @a2@, @b@). +nonDetFoldFsEnv :: (a -> b -> b) -> b -> FastStringEnv a -> b +nonDetFoldFsEnv = nonDetFoldUFM -- Deterministic FastStringEnv -- See Note [Deterministic UniqFM] in GHC.Types.Unique.DFM for explanation why we need 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 @@ -4,16 +4,18 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE DeriveFunctor #-} 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, @@ -42,7 +44,6 @@ -- removed them since they were not used anywhere in GHC. ------------------------------------------------------------------------------ - import GHC.Prelude import GHC.Utils.Misc ( sortWith, count ) @@ -59,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 + {- ************************************************************************ * * @@ -85,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 @@ -108,7 +101,7 @@ node_payload :: payload, -- ^ User data node_key :: key, -- ^ User defined node id node_dependencies :: [key] -- ^ Dependencies/successors of the node - } + } deriving Functor instance (Outputable a, Outputable b) => Outputable (Node a b) where @@ -356,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) @@ -409,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 @@ -618,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,19 +22,19 @@ IOEnvFailure(..), -- Getting at the environment - getEnv, setEnv, updEnv, + getEnv, setEnv, updEnv, updEnvIO, runIOEnv, unsafeInterleaveM, uninterruptibleMaskM_, tryM, tryAllM, tryMostM, fixM, -- I/O operations - IORef, newMutVar, readMutVar, writeMutVar, updMutVar, updMutVarM, + IORef, newMutVar, readMutVar, writeMutVar, updMutVar, atomicUpdMutVar, atomicUpdMutVar' ) where import GHC.Prelude -import GHC.Driver.Session +import GHC.Driver.DynFlags import {-# SOURCE #-} GHC.Driver.Hooks import GHC.IO (catchException) import GHC.Utils.Exception @@ -227,12 +227,6 @@ updMutVar :: IORef a -> (a -> a) -> IOEnv env () updMutVar var upd = liftIO (modifyIORef var upd) -updMutVarM :: IORef a -> (a -> IOEnv env a) -> IOEnv env () -updMutVarM ref upd - = do { contents <- liftIO $ readIORef ref - ; new_contents <- upd contents - ; liftIO $ writeIORef ref new_contents } - -- | Atomically update the reference. Does not force the evaluation of the -- new variable contents. For strict update, use 'atomicUpdMutVar''. atomicUpdMutVar :: IORef a -> (a -> (a, b)) -> IOEnv env b @@ -259,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/List/SetOps.hs b/GHC/Data/List/SetOps.hs --- a/GHC/Data/List/SetOps.hs +++ b/GHC/Data/List/SetOps.hs @@ -18,7 +18,7 @@ Assoc, assoc, assocMaybe, assocUsing, assocDefault, assocDefaultUsing, -- Duplicate handling - hasNoDups, removeDups, nubOrdBy, findDupsEq, + hasNoDups, removeDups, removeDupsOn, nubOrdBy, findDupsEq, equivClasses, -- Indexing @@ -37,6 +37,7 @@ import qualified Data.List as L import qualified Data.List.NonEmpty as NE import Data.List.NonEmpty (NonEmpty(..)) +import Data.Ord (comparing) import qualified Data.Set as S getNth :: Outputable a => [a] -> Int -> a @@ -192,6 +193,9 @@ collect_dups :: [NonEmpty a] -> NonEmpty a -> ([NonEmpty a], a) collect_dups dups_so_far (x :| []) = (dups_so_far, x) collect_dups dups_so_far dups@(x :| _) = (dups:dups_so_far, x) + +removeDupsOn :: Ord b => (a -> b) -> [a] -> ([a], [NonEmpty a]) +removeDupsOn f x = removeDups (comparing f) x -- | Remove the duplicates from a list using the provided -- comparison function. diff --git a/GHC/Data/Maybe.hs b/GHC/Data/Maybe.hs --- a/GHC/Data/Maybe.hs +++ b/GHC/Data/Maybe.hs @@ -34,7 +34,10 @@ import Data.Maybe import Data.Foldable ( foldlM, for_ ) import GHC.Utils.Misc (HasCallStack) +import GHC.Utils.Panic +import GHC.Utils.Outputable import Data.List.NonEmpty ( NonEmpty ) +import Control.Applicative( Alternative( (<|>) ) ) infixr 4 `orElse` @@ -47,7 +50,7 @@ -} firstJust :: Maybe a -> Maybe a -> Maybe a -firstJust a b = firstJusts [a, b] +firstJust = (<|>) -- | Takes a list of @Maybes@ and returns the first @Just@ if there is one, or -- @Nothing@ otherwise. @@ -65,10 +68,14 @@ go Nothing action = action go result@(Just _) _action = return result -expectJust :: HasCallStack => 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,13 +1,6 @@ {-# LANGUAGE CPP #-} -#if !defined(TESTING) && defined(__GLASGOW_HASKELL__) -{-# LANGUAGE Safe #-} -#endif -#ifdef __GLASGOW_HASKELL__ {-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MonoLocalBinds #-} -#endif - ----------------------------------------------------------------------------- -- | 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,15 +1,5 @@ -{-# 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 #-} @@ -312,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 @@ -490,7 +478,6 @@ rnf (Tip _ v) = rnf v rnf (Bin _ _ l r) = rnf l `seq` rnf r -#if __GLASGOW_HASKELL__ {-------------------------------------------------------------------- A Data instance @@ -514,7 +501,6 @@ intMapDataType :: DataType intMapDataType = mkDataType "Data.Word64Map.Internal.Word64Map" [fromListConstr] -#endif {-------------------------------------------------------------------- Query @@ -2403,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. -- @@ -2423,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) = @@ -2433,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)@ @@ -3102,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. @@ -3136,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 @@ -3168,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. @@ -3358,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 @@ -3384,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,9 +1,4 @@ -{-# LANGUAGE CPP #-} -#if !defined(TESTING) && defined(__GLASGOW_HASKELL__) -{-# LANGUAGE Safe #-} -#endif - ----------------------------------------------------------------------------- -- | -- Module : Data.Word64Map.Lazy @@ -66,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,7 +1,3 @@ -{-# LANGUAGE CPP #-} -#if !defined(TESTING) && defined(__GLASGOW_HASKELL__) -{-# LANGUAGE Trustworthy #-} -#endif ----------------------------------------------------------------------------- -- | @@ -83,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 @@ -251,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,6 +1,3 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE PatternGuards #-} {-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-} @@ -84,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 @@ -825,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. -- @@ -845,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. @@ -873,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,7 +1,3 @@ -{-# LANGUAGE CPP #-} -#if !defined(TESTING) && defined(__GLASGOW_HASKELL__) -{-# LANGUAGE Safe #-} -#endif ----------------------------------------------------------------------------- -- | @@ -63,11 +59,7 @@ -- $strictness -- * Set type -#if !defined(TESTING) Word64Set -- instance Eq,Show -#else - Word64Set(..) -- instance Eq,Show -#endif , Key -- * Construction @@ -153,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,14 +1,5 @@ -{-# 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 #-} @@ -203,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 -} @@ -277,7 +263,6 @@ (<>) = union stimes = stimesIdempotentMonoid -#if __GLASGOW_HASKELL__ {-------------------------------------------------------------------- A Data instance @@ -300,7 +285,6 @@ intSetDataType :: DataType intSetDataType = mkDataType "Data.Word64Set.Internal.Word64Set" [fromListConstr] -#endif {-------------------------------------------------------------------- Query @@ -511,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 #-} @@ -527,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 @@ -1137,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] @@ -1161,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 @@ -1187,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 @@ -1311,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 @@ -1545,7 +1514,6 @@ {-# INLINE foldr'Bits #-} {-# INLINE takeWhileAntitoneBits #-} -#if defined(__GLASGOW_HASKELL__) indexOfTheOnlyBit :: Nat -> Word64 {-# INLINE indexOfTheOnlyBit #-} indexOfTheOnlyBit bitmask = fromIntegral $ countTrailingZeros bitmask @@ -1612,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 @@ -1,4 +1,4 @@ -{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE MultiWayIf, LambdaCase #-} {-| Module : GHC.Driver.Backend @@ -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) @@ -87,15 +85,13 @@ , backendUnregisterisedAbiOnly , backendGeneratesHc , backendSptIsDynamic - , backendWantsBreakpointTicks + , backendSupportsBreakpoints , backendForcesOptimization0 , backendNeedsFullWays , backendSpecialModuleSource , 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,19 +513,16 @@ 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). True for the interpreter, and --- also true for "no backend", which is used by Haddock. --- (After typechecking a module, Haddock wants access to --- the module's `GlobalRdrEnv`.) +-- of the original source). Only true for the interpreter. backendWantsGlobalBindings :: Backend -> Bool backendWantsGlobalBindings (Named NCG) = False backendWantsGlobalBindings (Named LLVM) = False backendWantsGlobalBindings (Named ViaC) = False backendWantsGlobalBindings (Named JavaScript) = False +backendWantsGlobalBindings (Named NoBackend) = False backendWantsGlobalBindings (Named Interpreter) = True -backendWantsGlobalBindings (Named NoBackend) = True -- | The back end targets a technology that implements -- `switch` natively. (For example, LLVM or C.) Therefore @@ -595,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] @@ -691,16 +652,16 @@ backendSptIsDynamic (Named Interpreter) = True backendSptIsDynamic (Named NoBackend) = False --- | If this flag is set, then "GHC.HsToCore.Ticks" --- inserts `Breakpoint` ticks. Used only for the --- interpreter. -backendWantsBreakpointTicks :: Backend -> Bool -backendWantsBreakpointTicks (Named NCG) = False -backendWantsBreakpointTicks (Named LLVM) = False -backendWantsBreakpointTicks (Named ViaC) = False -backendWantsBreakpointTicks (Named JavaScript) = False -backendWantsBreakpointTicks (Named Interpreter) = True -backendWantsBreakpointTicks (Named NoBackend) = False +-- | If this flag is unset, then the driver ignores the flag @-fbreak-points@, +-- since backends other than the interpreter tend to panic on breakpoints. +backendSupportsBreakpoints :: Backend -> Bool +backendSupportsBreakpoints = \case + Named NCG -> False + Named LLVM -> False + Named ViaC -> False + Named JavaScript -> False + Named Interpreter -> True + Named NoBackend -> False -- | If this flag is set, then the driver forces the -- optimization level to 0, issuing a warning message if @@ -769,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 @@ -90,6 +89,10 @@ import Data.Map (Map) 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 () @@ -98,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. @@ -108,7 +112,7 @@ liftIO $ checkProcessArgsResult unhandled_flags let print_config = initPrintConfig dflags liftIO $ printOrThrowDiagnostics logger print_config (initDiagOpts dflags) (GhcPsMessage <$> p_warns) - liftIO $ handleFlagWarnings logger print_config (initDiagOpts dflags) warns + liftIO $ printOrThrowDiagnostics logger print_config (initDiagOpts dflags) (GhcDriverMessage <$> warns) -- TODO: Preprocessing not implemented buf <- liftIO $ hGetStringBuffer src_filename @@ -139,9 +143,9 @@ where cid = hsComponentId (unLoc (hsunitName unit)) reqs = uniqDSetToList (unionManyUniqDSets (map (get_reqs . unLoc) (hsunitBody unit))) - get_reqs (DeclD HsigFile (L _ modname) _) = unitUniqDSet modname get_reqs (DeclD HsSrcFile _ _) = emptyUniqDSet get_reqs (DeclD HsBootFile _ _) = emptyUniqDSet + get_reqs (DeclD HsigFile (L _ modname) _) = unitUniqDSet modname get_reqs (IncludeD (IncludeDecl (L _ hsuid) _ _)) = unitFreeModuleHoles (convertHsComponentId hsuid) @@ -329,10 +333,10 @@ mod_graph <- hsunitModuleGraph False (unLoc lunit) msg <- mkBackpackMsg - ok <- load' noIfaceCache LoadAllTargets (Just msg) mod_graph + 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 @@ -340,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) @@ -418,7 +424,7 @@ withBkpExeSession deps_w_rns $ do mod_graph <- hsunitModuleGraph True (unLoc lunit) msg <- mkBackpackMsg - ok <- load' noIfaceCache LoadAllTargets (Just msg) mod_graph + ok <- load' noIfaceCache LoadAllTargets mkUnknownDiagnostic (Just msg) mod_graph when (failed ok) (liftIO $ exitWith (ExitFailure 1)) -- | Register a new virtual unit database containing a single unit @@ -441,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 } @@ -579,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 @@ -588,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 @@ -740,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 @@ -771,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) @@ -780,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 @@ -794,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 }, @@ -815,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 @@ -853,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) @@ -871,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, @@ -902,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, @@ -929,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 @@ -17,7 +17,7 @@ Flag(..), defFlag, defGhcFlag, defGhciFlag, defHiddenFlag, hoistFlag, errorsToGhcException, - Err(..), Warn(..), WarnReason(..), + Err(..), Warn, warnsToMessages, EwM, runEwM, addErr, addWarn, addFlagWarn, getArg, getCurLoc, liftEwM ) where @@ -25,14 +25,14 @@ import GHC.Prelude import GHC.Utils.Misc -import GHC.Utils.Outputable import GHC.Utils.Panic -import GHC.Utils.Panic.Plain import GHC.Data.Bag import GHC.Types.SrcLoc -import GHC.Utils.Json - -import GHC.Types.Error ( DiagnosticReason(..) ) +import GHC.Types.Error +import GHC.Utils.Error +import GHC.Driver.Errors.Types +import GHC.Driver.Errors.Ppr () -- instance Diagnostic DriverMessage +import GHC.Utils.Outputable (text) import Data.Function import Data.List (sortBy, intercalate, stripPrefix) @@ -108,32 +108,16 @@ -- The EwM monad -------------------------------------------------------- --- | Used when filtering warnings: if a reason is given --- it can be filtered out when displaying. -data WarnReason - = NoReason - | ReasonDeprecatedFlag - | ReasonUnrecognisedFlag - deriving (Eq, Show) - -instance Outputable WarnReason where - ppr = text . show - -instance ToJson WarnReason where - json NoReason = JSNull - json reason = JSString $ show reason - -- | A command-line error message newtype Err = Err { errMsg :: Located String } -- | A command-line warning message and the reason it arose -data Warn = Warn - { warnReason :: DiagnosticReason, - warnMsg :: Located String - } +-- +-- This used to be own type, but now it's just @'MsgEnvelope' 'DriverMessage'@. +type Warn = Located DriverMessage type Errs = Bag Err -type Warns = Bag Warn +type Warns = [Warn] -- EwM ("errors and warnings monad") is a monad -- transformer for m that adds an (err, warn) state @@ -153,7 +137,7 @@ liftIO = liftEwM . liftIO runEwM :: EwM m a -> m (Errs, Warns, a) -runEwM action = unEwM action (panic "processArgs: no arg yet") emptyBag emptyBag +runEwM action = unEwM action (panic "processArgs: no arg yet") emptyBag mempty setArg :: Located String -> EwM m () -> EwM m () setArg l (EwM f) = EwM (\_ es ws -> f l es ws) @@ -162,11 +146,12 @@ addErr e = EwM (\(L loc _) es ws -> return (es `snocBag` Err (L loc e), ws, ())) addWarn :: Monad m => String -> EwM m () -addWarn = addFlagWarn WarningWithoutFlag +addWarn msg = addFlagWarn $ DriverUnknownMessage $ mkSimpleUnknownDiagnostic $ + mkPlainDiagnostic WarningWithoutFlag noHints $ text msg -addFlagWarn :: Monad m => DiagnosticReason -> String -> EwM m () -addFlagWarn reason msg = EwM $ - (\(L loc _) es ws -> return (es, ws `snocBag` Warn reason (L loc msg), ())) +addFlagWarn :: Monad m => DriverMessage -> EwM m () +addFlagWarn msg = EwM + (\(L loc _) es ws -> return (es, L loc msg : ws, ())) getArg :: Monad m => EwM m String getArg = EwM (\(L _ arg) es ws -> return (es, ws, arg)) @@ -177,6 +162,10 @@ liftEwM :: Monad m => m a -> EwM m a liftEwM action = EwM (\_ es ws -> do { r <- action; return (es, ws, r) }) +warnsToMessages :: DiagOpts -> [Warn] -> Messages DriverMessage +warnsToMessages diag_opts = foldr + (\(L loc w) ws -> addMessage (mkPlainMsgEnvelope diag_opts loc w) ws) + emptyMessages -------------------------------------------------------- -- Processing arguments @@ -188,10 +177,10 @@ -> (FilePath -> EwM m [Located String]) -- ^ response file handler -> m ( [Located String], -- spare args [Err], -- errors - [Warn] ) -- warnings + Warns ) -- warnings processArgs spec args handleRespFile = do (errs, warns, spare) <- runEwM action - return (spare, bagToList errs, bagToList warns) + return (spare, bagToList errs, warns) where action = process args [] diff --git a/GHC/Driver/CodeOutput.hs b/GHC/Driver/CodeOutput.hs --- a/GHC/Driver/CodeOutput.hs +++ b/GHC/Driver/CodeOutput.hs @@ -27,7 +27,9 @@ import GHC.Cmm import GHC.Cmm.CLabel -import GHC.Driver.Session +import GHC.StgToCmm.CgUtils (CgStream) + +import GHC.Driver.DynFlags import GHC.Driver.Config.Finder ( initFinderOpts ) import GHC.Driver.Config.CmmToAsm ( initNCGConfig ) import GHC.Driver.Config.CmmToLlvm ( initLlvmCgConfig ) @@ -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 @@ -105,7 +110,7 @@ (const ()) $ do { case cmmLint (targetPlatform dflags) cmm of Just err -> do { logMsg logger - MCDump + MCInfo -- See Note [MCInfo for Lint] in "GHC.Core.Lint" noSrcSpan $ withPprStyle defaultDumpStyle err ; ghcExit logger 1 @@ -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 @@ -2,22 +2,18 @@ module GHC.Driver.Config ( initOptCoercionOpts , initSimpleOpts - , initBCOOpts , initEvalOpts + , EvalStep(..) ) where import GHC.Prelude -import GHC.Driver.Session +import GHC.Driver.DynFlags import GHC.Core.SimpleOpt import GHC.Core.Coercion.Opt -import GHC.Runtime.Interpreter (BCOOpts(..)) import GHCi.Message (EvalOpts(..)) -import GHC.Conc (getNumProcessors) -import Control.Monad.IO.Class - -- | Initialise coercion optimiser configuration from DynFlags initOptCoercionOpts :: DynFlags -> OptCoercionOpts initOptCoercionOpts dflags = OptCoercionOpts @@ -30,25 +26,32 @@ { so_uf_opts = unfoldingOpts dflags , so_co_opts = initOptCoercionOpts dflags , so_eta_red = gopt Opt_DoEtaReduction dflags + , so_inline = True } --- | Extract BCO options from DynFlags -initBCOOpts :: DynFlags -> IO BCOOpts -initBCOOpts dflags = do - -- Serializing ResolvedBCO is expensive, so if we're in parallel mode - -- (-j) parallelise the serialization. - n_jobs <- case parMakeCount dflags of - Nothing -> liftIO getNumProcessors - Just n -> return n - return $ BCOOpts n_jobs +-- | 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 @@ -4,7 +4,7 @@ import GHC.Cmm.Config -import GHC.Driver.Session +import GHC.Driver.DynFlags import GHC.Driver.Backend import GHC.Platform @@ -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/Cmm/Parser.hs b/GHC/Driver/Config/Cmm/Parser.hs --- a/GHC/Driver/Config/Cmm/Parser.hs +++ b/GHC/Driver/Config/Cmm/Parser.hs @@ -6,7 +6,7 @@ import GHC.Driver.Config.Parser import GHC.Driver.Config.StgToCmm -import GHC.Driver.Session +import GHC.Driver.DynFlags import GHC.Utils.Panic 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 @@ -5,7 +5,7 @@ import GHC.Prelude -import GHC.Driver.Session +import GHC.Driver.DynFlags import GHC.Platform import GHC.Unit.Types (Module) @@ -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 @@ -66,8 +69,8 @@ , ncgDwarfSourceNotes = osElfTarget (platformOS (targetPlatform dflags)) && debugLevel dflags > 2 -- We produce GHC-specific source-note DIEs only with -g3 , ncgExposeInternalSymbols = gopt Opt_ExposeInternalSymbols dflags , ncgCmmStaticPred = gopt Opt_CmmStaticPred dflags - -- Disabled due to https://gitlab.haskell.org/ghc/ghc/-/issues/24507 - , ncgEnableShortcutting = False -- gopt Opt_AsmShortcutting 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 @@ -4,7 +4,7 @@ where import GHC.Prelude -import GHC.Driver.Session +import GHC.Driver.DynFlags import GHC.Driver.LlvmConfigCache import GHC.Platform import GHC.CmmToLlvm.Config @@ -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 @@ -12,7 +12,7 @@ import qualified GHC.LanguageExtensions as LangExt import GHC.Driver.Env -import GHC.Driver.Session +import GHC.Driver.DynFlags import GHC.Driver.Config.Diagnostic import GHC.Core @@ -77,17 +77,17 @@ coreDumpFlag :: CoreToDo -> Maybe DumpFlag coreDumpFlag (CoreDoSimplify {}) = Just Opt_D_verbose_core2core coreDumpFlag (CoreDoPluginPass {}) = Just Opt_D_verbose_core2core -coreDumpFlag CoreDoFloatInwards = Just Opt_D_verbose_core2core -coreDumpFlag (CoreDoFloatOutwards {}) = Just Opt_D_verbose_core2core -coreDumpFlag CoreLiberateCase = Just Opt_D_verbose_core2core -coreDumpFlag CoreDoStaticArgs = Just Opt_D_verbose_core2core +coreDumpFlag CoreDoFloatInwards = Just Opt_D_dump_float_in +coreDumpFlag (CoreDoFloatOutwards {}) = Just Opt_D_dump_float_out +coreDumpFlag CoreLiberateCase = Just Opt_D_dump_liberate_case +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 -coreDumpFlag CoreDoSpecConstr = Just Opt_D_dump_spec +coreDumpFlag CoreDoSpecConstr = Just Opt_D_dump_spec_constr coreDumpFlag CoreCSE = Just Opt_D_dump_cse coreDumpFlag CoreDesugar = Just Opt_D_dump_ds_preopt coreDumpFlag CoreDesugarOpt = Just Opt_D_dump_ds @@ -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/Lint/Interactive.hs b/GHC/Driver/Config/Core/Lint/Interactive.hs --- a/GHC/Driver/Config/Core/Lint/Interactive.hs +++ b/GHC/Driver/Config/Core/Lint/Interactive.hs @@ -5,7 +5,7 @@ import GHC.Prelude import GHC.Driver.Env -import GHC.Driver.Session +import GHC.Driver.DynFlags import GHC.Driver.Config.Core.Lint import GHC.Core diff --git a/GHC/Driver/Config/Core/Opt/Arity.hs b/GHC/Driver/Config/Core/Opt/Arity.hs --- a/GHC/Driver/Config/Core/Opt/Arity.hs +++ b/GHC/Driver/Config/Core/Opt/Arity.hs @@ -4,7 +4,7 @@ import GHC.Prelude () -import GHC.Driver.Session +import GHC.Driver.DynFlags import GHC.Core.Opt.Arity 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 @@ -2,11 +2,11 @@ ( initLiberateCaseOpts ) where -import GHC.Driver.Session +import GHC.Driver.DynFlags 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/Opt/Simplify.hs b/GHC/Driver/Config/Core/Opt/Simplify.hs --- a/GHC/Driver/Config/Core/Opt/Simplify.hs +++ b/GHC/Driver/Config/Core/Opt/Simplify.hs @@ -17,7 +17,7 @@ import GHC.Driver.Config.Core.Lint ( initLintPassResultConfig ) import GHC.Driver.Config.Core.Rules ( initRuleOpts ) import GHC.Driver.Config.Core.Opt.Arity ( initArityOpts ) -import GHC.Driver.Session ( DynFlags(..), GeneralFlag(..), gopt ) +import GHC.Driver.DynFlags ( DynFlags(..), GeneralFlag(..), gopt ) import GHC.Runtime.Context ( InteractiveContext(..) ) diff --git a/GHC/Driver/Config/Core/Opt/WorkWrap.hs b/GHC/Driver/Config/Core/Opt/WorkWrap.hs --- a/GHC/Driver/Config/Core/Opt/WorkWrap.hs +++ b/GHC/Driver/Config/Core/Opt/WorkWrap.hs @@ -5,7 +5,7 @@ import GHC.Prelude () import GHC.Driver.Config (initSimpleOpts) -import GHC.Driver.Session +import GHC.Driver.DynFlags import GHC.Core.FamInstEnv import GHC.Core.Opt.WorkWrap 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.Session ( 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.hs b/GHC/Driver/Config/CoreToStg.hs --- a/GHC/Driver/Config/CoreToStg.hs +++ b/GHC/Driver/Config/CoreToStg.hs @@ -1,7 +1,7 @@ module GHC.Driver.Config.CoreToStg where import GHC.Driver.Config.Stg.Debug -import GHC.Driver.Session +import GHC.Driver.DynFlags import GHC.CoreToStg 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,16 +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_specEval = gopt Opt_SpecEval $ hsc_dflags hsc_env - , cp_specEvalDFun = gopt Opt_SpecEvalDictFun $ hsc_dflags hsc_env + { 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 @@ -8,20 +8,22 @@ , initDsMessageOpts , initTcMessageOpts , initDriverMessageOpts + , initIfaceMessageOpts ) where import GHC.Driver.Flags -import GHC.Driver.Session +import GHC.Driver.DynFlags +import GHC.Prelude import GHC.Utils.Outputable import GHC.Utils.Error (DiagOpts (..)) -import GHC.Driver.Errors.Types (GhcMessage, GhcMessageOpts (..), PsMessage, DriverMessage, DriverMessageOpts (..)) -import GHC.Driver.Errors.Ppr () +import GHC.Driver.Errors.Types (GhcMessage, GhcMessageOpts (..), PsMessage, DriverMessage, DriverMessageOpts (..), checkBuildingCabalPackage) +import GHC.Driver.Errors.Ppr () -- Diagnostic instances import GHC.Tc.Errors.Types import GHC.HsToCore.Errors.Types import GHC.Types.Error -import GHC.Tc.Errors.Ppr +import GHC.Iface.Errors.Types -- | Initialise the general configuration for printing diagnostic messages -- For example, this configuration controls things like whether warnings are @@ -30,6 +32,8 @@ initDiagOpts dflags = DiagOpts { diag_warning_flags = warningFlags dflags , diag_fatal_warning_flags = fatalWarningFlags dflags + , diag_custom_warning_categories = customWarningCategories dflags + , diag_fatal_custom_warning_categories = fatalCustomWarningCategories dflags , diag_warn_is_error = gopt Opt_WarnIsError dflags , diag_reverse_errors = reverseErrors dflags , diag_max_errors = maxErrors dflags @@ -48,11 +52,18 @@ initPsMessageOpts _ = NoDiagnosticOpts initTcMessageOpts :: DynFlags -> DiagnosticOpts TcRnMessage -initTcMessageOpts dflags = TcRnMessageOpts { tcOptsShowContext = gopt Opt_ShowErrorContext dflags } +initTcMessageOpts dflags = + TcRnMessageOpts { tcOptsShowContext = gopt Opt_ShowErrorContext dflags + , tcOptsIfaceOpts = initIfaceMessageOpts dflags } initDsMessageOpts :: DynFlags -> DiagnosticOpts DsMessage initDsMessageOpts _ = NoDiagnosticOpts +initIfaceMessageOpts :: DynFlags -> DiagnosticOpts IfaceMessage +initIfaceMessageOpts dflags = + IfaceMessageOpts { ifaceShowTriedFiles = verbosity dflags >= 3 + , ifaceBuildingCabalPackage = checkBuildingCabalPackage dflags } + initDriverMessageOpts :: DynFlags -> DiagnosticOpts DriverMessage -initDriverMessageOpts dflags = DriverMessageOpts (initPsMessageOpts dflags) +initDriverMessageOpts dflags = DriverMessageOpts (initPsMessageOpts dflags) (initIfaceMessageOpts dflags) 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 @@ -5,30 +5,31 @@ import GHC.Prelude -import GHC.Driver.Session +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 @@ -4,7 +4,7 @@ where import GHC.Types.Id.Make -import GHC.Driver.Session +import GHC.Driver.DynFlags import qualified GHC.LanguageExtensions as LangExt initBangOpts :: DynFlags -> BangOpts @@ -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/HsToCore/Ticks.hs b/GHC/Driver/Config/HsToCore/Ticks.hs --- a/GHC/Driver/Config/HsToCore/Ticks.hs +++ b/GHC/Driver/Config/HsToCore/Ticks.hs @@ -1,5 +1,6 @@ module GHC.Driver.Config.HsToCore.Ticks ( initTicksConfig + , breakpointsAllowed ) where @@ -18,9 +19,14 @@ , ticks_countEntries = gopt Opt_ProfCountEntries dflags } +breakpointsAllowed :: DynFlags -> Bool +breakpointsAllowed dflags = + gopt Opt_InsertBreakpoints dflags && + backendSupportsBreakpoints (backend dflags) + coveragePasses :: DynFlags -> [TickishType] coveragePasses dflags = catMaybes - [ ifA Breakpoints $ backendWantsBreakpointTicks $ backend dflags + [ ifA Breakpoints $ breakpointsAllowed dflags , ifA HpcTicks $ gopt Opt_Hpc dflags , ifA ProfNotes $ sccProfilingEnabled dflags && profAuto dflags /= NoProfAuto , ifA SourceNotes $ needSourceNotes 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 @@ -5,7 +5,7 @@ import GHC.Prelude -import GHC.Driver.Session +import GHC.Driver.DynFlags import GHC.Utils.Logger (LogFlags (..)) import GHC.Utils.Outputable @@ -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/Debug.hs b/GHC/Driver/Config/Stg/Debug.hs --- a/GHC/Driver/Config/Stg/Debug.hs +++ b/GHC/Driver/Config/Stg/Debug.hs @@ -4,7 +4,7 @@ import GHC.Stg.Debug -import GHC.Driver.Session +import GHC.Driver.DynFlags -- | Initialize STG pretty-printing options from DynFlags initStgDebugOpts :: DynFlags -> StgDebugOpts diff --git a/GHC/Driver/Config/Stg/Lift.hs b/GHC/Driver/Config/Stg/Lift.hs --- a/GHC/Driver/Config/Stg/Lift.hs +++ b/GHC/Driver/Config/Stg/Lift.hs @@ -4,7 +4,7 @@ import GHC.Stg.Lift.Config -import GHC.Driver.Session +import GHC.Driver.DynFlags initStgLiftConfig :: DynFlags -> StgLiftConfig initStgLiftConfig dflags = StgLiftConfig 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,23 +7,28 @@ import Control.Monad (guard) import GHC.Stg.Pipeline +import GHC.Stg.Utils import GHC.Driver.Config.Diagnostic import GHC.Driver.Config.Stg.Lift import GHC.Driver.Config.Stg.Ppr -import GHC.Driver.Session +import GHC.Driver.DynFlags -- | 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 @@ -1,3 +1,6 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiWayIf #-} + module GHC.Driver.Config.StgToCmm ( initStgToCmmConfig ) where @@ -6,10 +9,12 @@ import GHC.StgToCmm.Config +import GHC.Cmm.MachOp ( FMASign(..)) import GHC.Driver.Backend 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 @@ -33,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 @@ -47,27 +52,58 @@ , 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 - , stgToCmmAllowIntMul2Instr = (ncg && x86ish) || llvm + , stgToCmmAllowFMAInstr = + if + | not (isFmaEnabled dflags) + || not (ncg || llvm) + -- If we're not using the native code generator or LLVM, + -- fall back to the generic implementation. + || platformArch platform == ArchWasm32 + -- WASM doesn't support native FMA instructions (at the time of writing). + -> const False + + -- FNMSub and FNMAdd have different semantics on PowerPC, + -- so we avoid using them. + | ppc + -> \ case { FMAdd -> True; FMSub -> True; _ -> False } + + | otherwise + -> const True + + , 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.Session +import GHC.Driver.DynFlags +import GHC.Driver.Config.Linker + import GHC.Platform.Ways import GHC.Utils.Outputable @@ -20,6 +24,7 @@ , csInlineLoadRegs = False , csInlineEnter = False , csInlineAlloc = False + , csPrettyRender = gopt Opt_DisableJsMinifier dflags , csTraceRts = False , csAssertRts = False , csBoundsCheck = gopt Opt_DoBoundsChecking dflags @@ -29,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 @@ -12,16 +12,13 @@ import GHC.Iface.Tidy import GHC.Iface.Tidy.StaticPtrTable -import GHC.Driver.Session +import GHC.Driver.DynFlags import GHC.Driver.Env import GHC.Driver.Backend import GHC.Core.Make (getMkStringIds) -import GHC.Data.Maybe -import GHC.Utils.Panic -import GHC.Utils.Outputable import GHC.Builtin.Names -import GHC.Tc.Utils.Env (lookupGlobal_maybe) +import GHC.Tc.Utils.Env (lookupGlobal) import GHC.Types.TyThing import GHC.Platform.Ways @@ -39,23 +36,21 @@ , 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 initStaticPtrOpts hsc_env = do let dflags = hsc_dflags hsc_env - let lookupM n = lookupGlobal_maybe hsc_env n >>= \case - Succeeded r -> pure r - Failed err -> pprPanic "initStaticPtrOpts: couldn't find" (ppr (err,n)) - - mk_string <- getMkStringIds (fmap tyThingId . lookupM) - static_ptr_info_datacon <- tyThingDataCon <$> lookupM staticPtrInfoDataConName - static_ptr_datacon <- tyThingDataCon <$> lookupM staticPtrDataConName + mk_string <- getMkStringIds (fmap tyThingId . lookupGlobal hsc_env ) + static_ptr_info_datacon <- tyThingDataCon <$> lookupGlobal hsc_env staticPtrInfoDataConName + static_ptr_datacon <- tyThingDataCon <$> lookupGlobal hsc_env staticPtrDataConName pure $ StaticPtrOpts { opt_platform = targetPlatform dflags 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 new file mode 100644 --- /dev/null +++ b/GHC/Driver/DynFlags.hs @@ -0,0 +1,1581 @@ +{-# LANGUAGE LambdaCase #-} +module GHC.Driver.DynFlags ( + -- * Dynamic flags and associated configuration types + DumpFlag(..), + GeneralFlag(..), + WarningFlag(..), DiagnosticReason(..), + Language(..), + FatalMessager, FlushOut(..), + ProfAuto(..), + hasPprDebug, hasNoDebugOutput, hasNoStateHack, hasNoOptCoercion, + dopt, dopt_set, dopt_unset, + gopt, gopt_set, gopt_unset, + wopt, wopt_set, wopt_unset, + wopt_fatal, wopt_set_fatal, wopt_unset_fatal, + wopt_set_all_custom, wopt_unset_all_custom, + wopt_set_all_fatal_custom, wopt_unset_all_fatal_custom, + wopt_set_custom, wopt_unset_custom, + wopt_set_fatal_custom, wopt_unset_fatal_custom, + wopt_any_custom, + xopt, xopt_set, xopt_unset, + xopt_set_unlessExplSpec, + xopt_DuplicateRecordFields, + xopt_FieldSelectors, + lang_set, + DynamicTooState(..), dynamicTooState, setDynamicNow, + OnOff(..), + DynFlags(..), + ParMakeCount(..), + ways, + HasDynFlags(..), ContainsDynFlags(..), + RtsOptsEnabled(..), + GhcMode(..), isOneShot, + GhcLink(..), isNoLink, + PackageFlag(..), PackageArg(..), ModRenaming(..), + packageFlagsChanged, + IgnorePackageFlag(..), TrustFlag(..), + PackageDBFlag(..), PkgDbRef(..), + Option(..), showOpt, + DynLibLoader(..), + positionIndependent, + optimisationFlags, + + targetProfile, + + ReexportedModule(..), + + -- ** Manipulating DynFlags + defaultDynFlags, -- Settings -> DynFlags + initDynFlags, -- DynFlags -> IO DynFlags + defaultFatalMessager, + defaultFlushOut, + optLevelFlags, + languageExtensions, + + TurnOnFlag, + turnOn, + turnOff, + + -- ** System tool settings and locations + programName, projectVersion, + ghcUsagePath, ghciUsagePath, topDir, toolDir, + versionedAppDir, versionedFilePath, + extraGccViaCFlags, globalPackageDatabasePath, + + -- + baseUnitId, + + + -- * Include specifications + IncludeSpecs(..), addGlobalInclude, addQuoteInclude, flattenIncludes, + addImplicitQuoteInclude, + + -- * 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 + +import GHC.Platform +import GHC.Platform.Ways +import GHC.Platform.Profile + +import GHC.CmmToAsm.CFG.Weight +import GHC.Core.Unfold +import GHC.Data.Bool +import GHC.Data.EnumSet (EnumSet) +import GHC.Data.Maybe +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 +import GHC.Settings.Constants +import GHC.Types.Basic ( IntWithInf, treatZeroAsInf ) +import GHC.Types.Error (DiagnosticReason(..)) +import GHC.Types.ProfAuto +import GHC.Types.SafeHaskell +import GHC.Types.SrcLoc +import GHC.Unit.Module +import GHC.Unit.Module.Warnings +import GHC.Utils.CliOption +import GHC.SysTools.Terminal ( stderrSupportsAnsiColors ) +import GHC.UniqueSubdir (uniqueSubdir) +import GHC.Utils.Outputable +import GHC.Utils.Panic +import GHC.Utils.TmpFs + +import qualified GHC.Types.FieldLabel as FieldLabel +import qualified GHC.Utils.Ppr.Colour as Col +import qualified GHC.Data.EnumSet as EnumSet + +import GHC.Core.Opt.CallerCC.Types + +import Control.Monad (msum, (<=<)) +import Control.Monad.Trans.Class (lift) +import Control.Monad.Trans.Except (ExceptT) +import Control.Monad.Trans.Reader (ReaderT) +import Control.Monad.Trans.Writer (WriterT) +import Data.Word +import System.IO +import System.IO.Error (catchIOError) +import System.Environment (lookupEnv) +import System.FilePath (normalise, ()) +import System.Directory +import GHC.Foreign (withCString, peekCString) + +import qualified Data.Set as Set + +import qualified GHC.LanguageExtensions as LangExt + +-- ----------------------------------------------------------------------------- +-- DynFlags + +-- | Contains not only a collection of 'GeneralFlag's but also a plethora of +-- information relating to the compilation of a single file or GHC session +data DynFlags = DynFlags { + ghcMode :: GhcMode, + ghcLink :: GhcLink, + backend :: !Backend, + -- ^ The backend to use (if any). + -- + -- Whenever you change the backend, also make sure to set 'ghcLink' to + -- something sensible. + -- + -- 'NoBackend' can be used to avoid generating any output, however, note that: + -- + -- * If a program uses Template Haskell the typechecker may need to run code + -- from an imported module. To facilitate this, code generation is enabled + -- for modules imported by modules that use template haskell, using the + -- default backend for the platform. + -- See Note [-fno-code mode]. + + + -- formerly Settings + ghcNameVersion :: {-# UNPACK #-} !GhcNameVersion, + fileSettings :: {-# UNPACK #-} !FileSettings, + unitSettings :: {-# UNPACK #-} !UnitSettings, + + targetPlatform :: Platform, -- Filled in by SysTools + toolSettings :: {-# UNPACK #-} !ToolSettings, + platformMisc :: {-# UNPACK #-} !PlatformMisc, + rawSettings :: [(String, String)], + tmpDir :: TempDir, + + llvmOptLevel :: Int, -- ^ LLVM optimisation level + verbosity :: Int, -- ^ Verbosity level: see Note [Verbosity levels] + debugLevel :: Int, -- ^ How much debug information to produce + simplPhases :: Int, -- ^ Number of simplifier phases + maxSimplIterations :: Int, -- ^ Max simplifier iterations + ruleCheck :: Maybe String, + strictnessBefore :: [Int], -- ^ Additional demand analysis + + parMakeCount :: Maybe ParMakeCount, + -- ^ The number of modules to compile in parallel + -- If unspecified, compile with a single job. + + enableTimeStats :: Bool, -- ^ Enable RTS timing statistics? + ghcHeapSize :: Maybe Int, -- ^ The heap size to set. + + maxRelevantBinds :: Maybe Int, -- ^ Maximum number of bindings from the type envt + -- to show in type error messages + maxValidHoleFits :: Maybe Int, -- ^ Maximum number of hole fits to show + -- in typed hole error messages + maxRefHoleFits :: Maybe Int, -- ^ Maximum number of refinement hole + -- fits to show in typed hole error + -- messages + refLevelHoleFits :: Maybe Int, -- ^ Maximum level of refinement for + -- refinement hole fits in typed hole + -- error messages + maxUncoveredPatterns :: Int, -- ^ Maximum number of unmatched patterns to show + -- in non-exhaustiveness warnings + maxPmCheckModels :: Int, -- ^ Soft limit on the number of models + -- the pattern match checker checks + -- a pattern against. A safe guard + -- against exponential blow-up. + simplTickFactor :: Int, -- ^ Multiplier for simplifier ticks + 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 + -- Not optional; otherwise ForceSpecConstr can diverge. + binBlobThreshold :: Maybe Word, -- ^ Binary literals (e.g. strings) whose size is above + -- this threshold will be dumped in a binary file + -- by the assembler code generator. 0 and Nothing disables + -- this feature. See 'GHC.StgToCmm.Config'. + liberateCaseThreshold :: Maybe Int, -- ^ Threshold for LiberateCase + floatLamArgs :: Maybe Int, -- ^ Arg count for lambda floating + -- See 'GHC.Core.Opt.Monad.FloatOutSwitches' + + liftLamsRecArgs :: Maybe Int, -- ^ Maximum number of arguments after lambda lifting a + -- recursive function. + liftLamsNonRecArgs :: Maybe Int, -- ^ Maximum number of arguments after lambda lifting a + -- non-recursive function. + liftLamsKnown :: Bool, -- ^ Lambda lift even when this turns a known call + -- into an unknown call. + + cmmProcAlignment :: Maybe Int, -- ^ Align Cmm functions at this boundary or use default. + + historySize :: Int, -- ^ Simplification history size + + importPaths :: [FilePath], + mainModuleNameIs :: ModuleName, + mainFunIs :: Maybe String, + reductionDepth :: IntWithInf, -- ^ Typechecker maximum stack depth + solverIterations :: IntWithInf, -- ^ Number of iterations in the constraints solver + -- Typically only 1 is needed + givensFuel :: Int, -- ^ Number of layers of superclass expansion for givens + -- Should be < solverIterations + -- See Note [Expanding Recursive Superclasses and ExpansionFuel] + wantedsFuel :: Int, -- ^ Number of layers of superclass expansion for wanteds + -- Should be < givensFuel + -- See Note [Expanding Recursive Superclasses and ExpansionFuel] + qcsFuel :: Int, -- ^ Number of layers of superclass expansion for quantified constraints + -- Should be < givensFuel + -- See Note [Expanding Recursive Superclasses and ExpansionFuel] + homeUnitId_ :: UnitId, -- ^ Target home unit-id + homeUnitInstanceOf_ :: Maybe UnitId, -- ^ Id of the unit to instantiate + homeUnitInstantiations_ :: [(ModuleName, Module)], -- ^ Module instantiations + + -- Note [Filepaths and Multiple Home Units] + workingDirectory :: Maybe FilePath, + thisPackageName :: Maybe String, -- ^ What the package is called, use with multiple home units + hiddenModules :: Set.Set ModuleName, + reexportedModules :: [ReexportedModule], + + -- ways + targetWays_ :: Ways, -- ^ Target way flags from the command line + + -- For object splitting + splitInfo :: Maybe (String,Int), + + -- paths etc. + objectDir :: Maybe String, + dylibInstallName :: Maybe String, + hiDir :: Maybe String, + hieDir :: Maybe String, + stubDir :: Maybe String, + dumpDir :: Maybe String, + + objectSuf_ :: String, + hcSuf :: String, + hiSuf_ :: String, + hieSuf :: String, + + dynObjectSuf_ :: String, + dynHiSuf_ :: String, + + outputFile_ :: Maybe String, + dynOutputFile_ :: Maybe String, + outputHi :: Maybe String, + dynOutputHi :: Maybe String, + dynLibLoader :: DynLibLoader, + + dynamicNow :: !Bool, -- ^ Indicate if we are now generating dynamic output + -- because of -dynamic-too. This predicate is + -- used to query the appropriate fields + -- (outputFile/dynOutputFile, ways, etc.) + + -- | This defaults to 'non-module'. It can be set by + -- 'GHC.Driver.Pipeline.setDumpPrefix' or 'ghc.GHCi.UI.runStmt' based on + -- where its output is going. + dumpPrefix :: FilePath, + + -- | Override the 'dumpPrefix' set by 'GHC.Driver.Pipeline.setDumpPrefix' + -- or 'ghc.GHCi.UI.runStmt'. + -- Set by @-ddump-file-prefix@ + dumpPrefixForce :: Maybe FilePath, + + ldInputs :: [Option], + + includePaths :: IncludeSpecs, + libraryPaths :: [String], + frameworkPaths :: [String], -- used on darwin only + cmdlineFrameworks :: [String], -- ditto + + rtsOpts :: Maybe String, + rtsOptsEnabled :: RtsOptsEnabled, + rtsOptsSuggestions :: Bool, + + hpcDir :: String, -- ^ Path to store the .mix files + + -- Plugins + pluginModNames :: [ModuleName], + -- ^ the @-fplugin@ flags given on the command line, in *reverse* + -- order that they're specified on the command line. + pluginModNameOpts :: [(ModuleName,String)], + frontendPluginOpts :: [String], + -- ^ the @-ffrontend-opt@ flags given on the command line, in *reverse* + -- order that they're specified on the command line. + + externalPluginSpecs :: [ExternalPluginSpec], + -- ^ External plugins loaded from shared libraries + + -- For ghc -M + depMakefile :: FilePath, + depIncludePkgDeps :: Bool, + depIncludeCppDeps :: Bool, + depExcludeMods :: [ModuleName], + depSuffixes :: [String], + + -- Package flags + packageDBFlags :: [PackageDBFlag], + -- ^ The @-package-db@ flags given on the command line, In + -- *reverse* order that they're specified on the command line. + -- This is intended to be applied with the list of "initial" + -- package databases derived from @GHC_PACKAGE_PATH@; see + -- 'getUnitDbRefs'. + + ignorePackageFlags :: [IgnorePackageFlag], + -- ^ The @-ignore-package@ flags from the command line. + -- In *reverse* order that they're specified on the command line. + packageFlags :: [PackageFlag], + -- ^ The @-package@ and @-hide-package@ flags from the command-line. + -- In *reverse* order that they're specified on the command line. + pluginPackageFlags :: [PackageFlag], + -- ^ The @-plugin-package-id@ flags from command line. + -- In *reverse* order that they're specified on the command line. + trustFlags :: [TrustFlag], + -- ^ The @-trust@ and @-distrust@ flags. + -- In *reverse* order that they're specified on the command line. + packageEnv :: Maybe FilePath, + -- ^ Filepath to the package environment file (if overriding default) + + + -- hsc dynamic flags + dumpFlags :: EnumSet DumpFlag, + generalFlags :: EnumSet GeneralFlag, + warningFlags :: EnumSet WarningFlag, + fatalWarningFlags :: EnumSet WarningFlag, + customWarningCategories :: WarningCategorySet, -- See Note [Warning categories] + fatalCustomWarningCategories :: WarningCategorySet, -- in GHC.Unit.Module.Warnings + -- Don't change this without updating extensionFlags: + language :: Maybe Language, + -- | Safe Haskell mode + safeHaskell :: SafeHaskellMode, + safeInfer :: Bool, + safeInferred :: Bool, + -- We store the location of where some extension and flags were turned on so + -- we can produce accurate error messages when Safe Haskell fails due to + -- them. + thOnLoc :: SrcSpan, + newDerivOnLoc :: SrcSpan, + deriveViaOnLoc :: SrcSpan, + overlapInstLoc :: SrcSpan, + incoherentOnLoc :: SrcSpan, + pkgTrustOnLoc :: SrcSpan, + warnSafeOnLoc :: SrcSpan, + warnUnsafeOnLoc :: SrcSpan, + trustworthyOnLoc :: SrcSpan, + -- Don't change this without updating extensionFlags: + -- Here we collect the settings of the language extensions + -- from the command line, the ghci config file and + -- from interactive :set / :seti commands. + extensions :: [OnOff LangExt.Extension], + -- extensionFlags should always be equal to + -- flattenExtensionFlags language extensions + -- LangExt.Extension is defined in libraries/ghc-boot so that it can be used + -- by template-haskell + extensionFlags :: EnumSet LangExt.Extension, + + -- | Unfolding control + -- See Note [Discounts and thresholds] in GHC.Core.Unfold + 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, + haddockOptions :: Maybe String, + + -- | GHCi scripts specified by -ghci-script, in reverse order + ghciScripts :: [String], + + -- Output style options + pprUserLength :: Int, + pprCols :: Int, + + useUnicode :: Bool, + useColor :: OverridingBool, + canUseColor :: Bool, + useErrorLinks :: OverridingBool, + canUseErrorLinks :: Bool, + colScheme :: Col.Scheme, + + -- | what kind of {-# SCC #-} to add automatically + profAuto :: ProfAuto, + callerCcFilters :: [CallerCcFilter], + + interactivePrint :: Maybe String, + + -- | Machine dependent flags (-m\ stuff) + sseVersion :: Maybe SseVersion, + bmiVersion :: Maybe BmiVersion, + avx :: Bool, + avx2 :: Bool, + avx512cd :: Bool, -- Enable AVX-512 Conflict Detection Instructions. + avx512er :: Bool, -- Enable AVX-512 Exponential and Reciprocal Instructions. + avx512f :: Bool, -- Enable AVX-512 instructions. + avx512pf :: Bool, -- Enable AVX-512 PreFetch Instructions. + fma :: Bool, -- ^ Enable FMA instructions. + + -- Constants used to control the amount of optimization done. + + -- | Max size, in bytes, of inline array allocations. + maxInlineAllocSize :: Int, + + -- | Only inline memcpy if it generates no more than this many + -- pseudo (roughly: Cmm) instructions. + maxInlineMemcpyInsns :: Int, + + -- | Only inline memset if it generates no more than this many + -- pseudo (roughly: Cmm) instructions. + maxInlineMemsetInsns :: Int, + + -- | Reverse the order of error messages in GHC/GHCi + reverseErrors :: Bool, + + -- | Limit the maximum number of errors to show + maxErrors :: Maybe Int, + + -- | Unique supply configuration for testing build determinism + initialUnique :: Word64, + uniqueIncrement :: Int, + -- 'Int' because it can be used to test uniques in decreasing order. + + -- | Temporary: CFG Edge weights for fast iterations + cfgWeights :: Weights +} + +class HasDynFlags m where + getDynFlags :: m DynFlags + +{- It would be desirable to have the more generalised + + instance (MonadTrans t, Monad m, HasDynFlags m) => HasDynFlags (t m) where + getDynFlags = lift getDynFlags + +instance definition. However, that definition would overlap with the +`HasDynFlags (GhcT m)` instance. Instead we define instances for a +couple of common Monad transformers explicitly. -} + +instance (Monoid a, Monad m, HasDynFlags m) => HasDynFlags (WriterT a m) where + getDynFlags = lift getDynFlags + +instance (Monad m, HasDynFlags m) => HasDynFlags (ReaderT a m) where + getDynFlags = lift getDynFlags + +instance (Monad m, HasDynFlags m) => HasDynFlags (MaybeT m) where + getDynFlags = lift getDynFlags + +instance (Monad m, HasDynFlags m) => HasDynFlags (ExceptT e m) where + getDynFlags = lift getDynFlags + +class ContainsDynFlags t where + extractDynFlags :: t -> DynFlags + +----------------------------------------------------------------------------- + +-- | Used by 'GHC.runGhc' to partially initialize a new 'DynFlags' value +initDynFlags :: DynFlags -> IO DynFlags +initDynFlags dflags = do + let + -- 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 -> + do str' <- peekCString enc cstr + return (str == str')) + `catchIOError` \_ -> return False + ghcNoUnicodeEnv <- lookupEnv "GHC_NO_UNICODE" + let useUnicode' = isNothing ghcNoUnicodeEnv && canUseUnicode + maybeGhcColorsEnv <- lookupEnv "GHC_COLORS" + maybeGhcColoursEnv <- lookupEnv "GHC_COLOURS" + let adjustCols (Just env) = Col.parseScheme env + adjustCols Nothing = id + let (useColor', colScheme') = + (adjustCols maybeGhcColoursEnv . adjustCols maybeGhcColorsEnv) + (useColor dflags, colScheme dflags) + tmp_dir <- normalise <$> getTemporaryDirectory + return dflags{ + useUnicode = useUnicode', + useColor = useColor', + canUseColor = stderrSupportsAnsiColors, + -- if the terminal supports color, we assume it supports links as well + canUseErrorLinks = stderrSupportsAnsiColors, + colScheme = colScheme', + tmpDir = TempDir tmp_dir + } + +-- | The normal 'DynFlags'. Note that they are not suitable for use in this form +-- and must be fully initialized by 'GHC.runGhc' first. +defaultDynFlags :: Settings -> DynFlags +defaultDynFlags mySettings = +-- See Note [Updating flag description in the User's Guide] + DynFlags { + ghcMode = CompManager, + ghcLink = LinkBinary, + backend = platformDefaultBackend (sTargetPlatform mySettings), + verbosity = 0, + debugLevel = 0, + simplPhases = 2, + maxSimplIterations = 4, + ruleCheck = Nothing, + binBlobThreshold = Just 500000, -- 500K is a good default (see #16190) + maxRelevantBinds = Just 6, + maxValidHoleFits = Just 6, + maxRefHoleFits = Just 6, + refLevelHoleFits = Nothing, + maxUncoveredPatterns = 4, + 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, + liberateCaseThreshold = Just 2000, + floatLamArgs = Just 0, -- Default: float only if no fvs + liftLamsRecArgs = Just 5, -- Default: the number of available argument hardware registers on x86_64 + liftLamsNonRecArgs = Just 5, -- Default: the number of available argument hardware registers on x86_64 + liftLamsKnown = False, -- Default: don't turn known calls into unknown ones + cmmProcAlignment = Nothing, + + historySize = 20, + strictnessBefore = [], + + parMakeCount = Nothing, + + enableTimeStats = False, + ghcHeapSize = Nothing, + + importPaths = ["."], + mainModuleNameIs = mAIN_NAME, + mainFunIs = Nothing, + reductionDepth = treatZeroAsInf mAX_REDUCTION_DEPTH, + solverIterations = treatZeroAsInf mAX_SOLVER_ITERATIONS, + givensFuel = mAX_GIVENS_FUEL, + wantedsFuel = mAX_WANTEDS_FUEL, + qcsFuel = mAX_QC_FUEL, + + homeUnitId_ = mainUnitId, + homeUnitInstanceOf_ = Nothing, + homeUnitInstantiations_ = [], + + workingDirectory = Nothing, + thisPackageName = Nothing, + hiddenModules = Set.empty, + reexportedModules = [], + + objectDir = Nothing, + dylibInstallName = Nothing, + hiDir = Nothing, + hieDir = Nothing, + stubDir = Nothing, + dumpDir = Nothing, + + objectSuf_ = phaseInputExt StopLn, + hcSuf = phaseInputExt HCc, + hiSuf_ = "hi", + hieSuf = "hie", + + dynObjectSuf_ = "dyn_" ++ phaseInputExt StopLn, + dynHiSuf_ = "dyn_hi", + dynamicNow = False, + + pluginModNames = [], + pluginModNameOpts = [], + frontendPluginOpts = [], + + externalPluginSpecs = [], + + outputFile_ = Nothing, + dynOutputFile_ = Nothing, + outputHi = Nothing, + dynOutputHi = Nothing, + dynLibLoader = SystemDependent, + dumpPrefix = "non-module.", + dumpPrefixForce = Nothing, + ldInputs = [], + includePaths = IncludeSpecs [] [] [], + libraryPaths = [], + frameworkPaths = [], + cmdlineFrameworks = [], + rtsOpts = Nothing, + rtsOptsEnabled = RtsOptsSafeOnly, + rtsOptsSuggestions = True, + + hpcDir = ".hpc", + + packageDBFlags = [], + packageFlags = [], + pluginPackageFlags = [], + ignorePackageFlags = [], + trustFlags = [], + packageEnv = Nothing, + targetWays_ = Set.empty, + splitInfo = Nothing, + + ghcNameVersion = sGhcNameVersion mySettings, + unitSettings = sUnitSettings mySettings, + fileSettings = sFileSettings mySettings, + toolSettings = sToolSettings mySettings, + targetPlatform = sTargetPlatform mySettings, + platformMisc = sPlatformMisc mySettings, + rawSettings = sRawSettings mySettings, + + tmpDir = panic "defaultDynFlags: uninitialized tmpDir", + + llvmOptLevel = 0, + + -- ghc -M values + depMakefile = "Makefile", + depIncludePkgDeps = False, + depIncludeCppDeps = False, + depExcludeMods = [], + depSuffixes = [], + -- end of ghc -M values + ghcVersionFile = Nothing, + haddockOptions = Nothing, + dumpFlags = EnumSet.empty, + generalFlags = EnumSet.fromList (defaultFlags mySettings), + warningFlags = EnumSet.fromList standardWarnings, + fatalWarningFlags = EnumSet.empty, + customWarningCategories = completeWarningCategorySet, + fatalCustomWarningCategories = emptyWarningCategorySet, + ghciScripts = [], + language = Nothing, + safeHaskell = Sf_None, + safeInfer = True, + safeInferred = True, + thOnLoc = noSrcSpan, + newDerivOnLoc = noSrcSpan, + deriveViaOnLoc = noSrcSpan, + overlapInstLoc = noSrcSpan, + incoherentOnLoc = noSrcSpan, + pkgTrustOnLoc = noSrcSpan, + warnSafeOnLoc = noSrcSpan, + warnUnsafeOnLoc = noSrcSpan, + trustworthyOnLoc = noSrcSpan, + extensions = [], + extensionFlags = flattenExtensionFlags Nothing [], + + 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 = [], + interactivePrint = Nothing, + sseVersion = Nothing, + bmiVersion = Nothing, + avx = False, + avx2 = False, + avx512cd = False, + avx512er = False, + avx512f = False, + avx512pf = False, + -- Use FMA by default on AArch64 + fma = (platformArch . sTargetPlatform $ mySettings) == ArchAArch64, + + maxInlineAllocSize = 128, + maxInlineMemcpyInsns = 32, + maxInlineMemsetInsns = 32, + + initialUnique = 0, + uniqueIncrement = 1, + + reverseErrors = False, + maxErrors = Nothing, + cfgWeights = defaultWeights + } + +type FatalMessager = String -> IO () + +defaultFatalMessager :: FatalMessager +defaultFatalMessager = hPutStrLn stderr + + +newtype FlushOut = FlushOut (IO ()) + +defaultFlushOut :: FlushOut +defaultFlushOut = FlushOut $ hFlush stdout + +-- 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 +flattenExtensionFlags ml = foldr g defaultExtensionFlags + where g (On f) flags = EnumSet.insert f flags + g (Off f) flags = EnumSet.delete f flags + defaultExtensionFlags = EnumSet.fromList (languageExtensions ml) + +-- ----------------------------------------------------------------------------- +-- -jN + +-- | The type for the -jN argument, specifying that -j on its own represents +-- using the number of machine processors. +data ParMakeCount + -- | Use this many processors (@-j@ flag). + = ParMakeThisMany Int + -- | Use parallelism with as many processors as possible (@-j@ flag without an argument). + | ParMakeNumProcessors + -- | Use the specific semaphore @@ to control parallelism (@-jsem @ flag). + | ParMakeSemaphore FilePath + +-- | 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 +-- the "GHC.Unit.Finder": in one-shot mode we look for interface files for +-- imported modules, but in multi-module mode we look for source files +-- in order to check whether they need to be recompiled. +data GhcMode + = CompManager -- ^ @\-\-make@, GHCi, etc. + | OneShot -- ^ @ghc -c Foo.hs@ + | MkDepend -- ^ @ghc -M@, see "GHC.Unit.Finder" for why we need this + deriving Eq + +instance Outputable GhcMode where + ppr CompManager = text "CompManager" + ppr OneShot = text "OneShot" + ppr MkDepend = text "MkDepend" + +isOneShot :: GhcMode -> Bool +isOneShot OneShot = True +isOneShot _other = False + +-- | What to do in the link step, if there is one. +data GhcLink + = NoLink -- ^ Don't link at all + | LinkBinary -- ^ Link object code into a binary + | LinkInMemory -- ^ Use the in-memory dynamic linker (works for both + -- bytecode and object code). + | LinkDynLib -- ^ Link objects into a dynamic lib (DLL on Windows, DSO on ELF platforms) + | LinkStaticLib -- ^ Link objects into a static lib + | LinkMergedObj -- ^ Link objects into a merged "GHCi object" + deriving (Eq, Show) + +isNoLink :: GhcLink -> Bool +isNoLink NoLink = True +isNoLink _ = False + +-- | We accept flags which make packages visible, but how they select +-- the package varies; this data type reflects what selection criterion +-- is used. +data PackageArg = + PackageArg String -- ^ @-package@, by 'PackageName' + | UnitIdArg Unit -- ^ @-package-id@, by 'Unit' + deriving (Eq, Show) + +instance Outputable PackageArg where + ppr (PackageArg pn) = text "package" <+> text pn + ppr (UnitIdArg uid) = text "unit" <+> ppr uid + +-- | Represents the renaming that may be associated with an exposed +-- package, e.g. the @rns@ part of @-package "foo (rns)"@. +-- +-- Here are some example parsings of the package flags (where +-- a string literal is punned to be a 'ModuleName': +-- +-- * @-package foo@ is @ModRenaming True []@ +-- * @-package foo ()@ is @ModRenaming False []@ +-- * @-package foo (A)@ is @ModRenaming False [("A", "A")]@ +-- * @-package foo (A as B)@ is @ModRenaming False [("A", "B")]@ +-- * @-package foo with (A as B)@ is @ModRenaming True [("A", "B")]@ +data ModRenaming = ModRenaming { + modRenamingWithImplicit :: Bool, -- ^ Bring all exposed modules into scope? + modRenamings :: [(ModuleName, ModuleName)] -- ^ Bring module @m@ into scope + -- under name @n@. + } deriving (Eq) +instance Outputable ModRenaming where + ppr (ModRenaming b rns) = ppr b <+> parens (ppr rns) + +-- | Flags for manipulating the set of non-broken packages. +newtype IgnorePackageFlag = IgnorePackage String -- ^ @-ignore-package@ + deriving (Eq) + +-- | Flags for manipulating package trust. +data TrustFlag + = TrustPackage String -- ^ @-trust@ + | DistrustPackage String -- ^ @-distrust@ + deriving (Eq) + +-- | Flags for manipulating packages visibility. +data PackageFlag + = ExposePackage String PackageArg ModRenaming -- ^ @-package@, @-package-id@ + | HidePackage String -- ^ @-hide-package@ + deriving (Eq) -- NB: equality instance is used by packageFlagsChanged + +data PackageDBFlag + = PackageDB PkgDbRef + | NoUserPackageDB + | NoGlobalPackageDB + | ClearPackageDBs + deriving (Eq) + +packageFlagsChanged :: DynFlags -> DynFlags -> Bool +packageFlagsChanged idflags1 idflags0 = + packageFlags idflags1 /= packageFlags idflags0 || + ignorePackageFlags idflags1 /= ignorePackageFlags idflags0 || + pluginPackageFlags idflags1 /= pluginPackageFlags idflags0 || + trustFlags idflags1 /= trustFlags idflags0 || + packageDBFlags idflags1 /= packageDBFlags idflags0 || + packageGFlags idflags1 /= packageGFlags idflags0 + where + packageGFlags dflags = map (`gopt` dflags) + [ Opt_HideAllPackages + , Opt_HideAllPluginPackages + , Opt_AutoLinkPackages ] + +instance Outputable PackageFlag where + ppr (ExposePackage n arg rn) = text n <> braces (ppr arg <+> ppr rn) + ppr (HidePackage str) = text "-hide-package" <+> text str + +data DynLibLoader + = Deployable + | SystemDependent + deriving Eq + +data RtsOptsEnabled + = RtsOptsNone | RtsOptsIgnore | RtsOptsIgnoreAll | RtsOptsSafeOnly + | RtsOptsAll + deriving (Show) + +-- | Are we building with @-fPIE@ or @-fPIC@ enabled? +positionIndependent :: DynFlags -> Bool +positionIndependent dflags = gopt Opt_PIC dflags || gopt Opt_PIE dflags + +-- Note [-dynamic-too business] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- +-- With -dynamic-too flag, we try to build both the non-dynamic and dynamic +-- objects in a single run of the compiler: the pipeline is the same down to +-- Core optimisation, then the backend (from Core to object code) is executed +-- twice. +-- +-- The implementation is currently rather hacky, for example, we don't clearly separate non-dynamic +-- and dynamic loaded interfaces (#9176). +-- +-- To make matters worse, we automatically enable -dynamic-too when some modules +-- need Template-Haskell and GHC is dynamically linked (cf +-- GHC.Driver.Pipeline.compileOne'). +-- +-- We used to try and fall back from a dynamic-too failure but this feature +-- didn't work as expected (#20446) so it was removed to simplify the +-- implementation and not obscure latent bugs. + +data DynamicTooState + = DT_Dont -- ^ Don't try to build dynamic objects too + | DT_OK -- ^ Will still try to generate dynamic objects + | DT_Dyn -- ^ Currently generating dynamic objects (in the backend) + deriving (Eq,Show,Ord) + +dynamicTooState :: DynFlags -> DynamicTooState +dynamicTooState dflags + | not (gopt Opt_BuildDynamicToo dflags) = DT_Dont + | dynamicNow dflags = DT_Dyn + | otherwise = DT_OK + +setDynamicNow :: DynFlags -> DynFlags +setDynamicNow dflags0 = + dflags0 + { dynamicNow = True + } + +data PkgDbRef + = GlobalPkgDb + | UserPkgDb + | PkgDbPath FilePath + deriving Eq + + + +-- An argument to --reexported-module which can optionally specify a module renaming. +data ReexportedModule = ReexportedModule { reexportFrom :: ModuleName + , reexportTo :: ModuleName + } + +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] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + The compile driver adds the path to the folder containing the source file being + compiled to the 'IncludeSpecs', and this change gets recorded in the 'DynFlags' + that are used later to compute the interface file. Because of this, + the flags fingerprint derived from these 'DynFlags' and recorded in the + interface file will end up containing the absolute path to the source folder. + + Build systems with a remote cache like Bazel or Buck (or Shake, see #16956) + store the build artifacts produced by a build BA for reuse in subsequent builds. + + Embedding source paths in interface fingerprints will thwart these attempts and + lead to unnecessary recompilations when the source paths in BA differ from the + source paths in subsequent builds. + -} + +hasPprDebug :: DynFlags -> Bool +hasPprDebug = dopt Opt_D_ppr_debug + +hasNoDebugOutput :: DynFlags -> Bool +hasNoDebugOutput = dopt Opt_D_no_debug_output + +hasNoStateHack :: DynFlags -> Bool +hasNoStateHack = gopt Opt_G_NoStateHack + +hasNoOptCoercion :: DynFlags -> Bool +hasNoOptCoercion = gopt Opt_G_NoOptCoercion + +-- | Test whether a 'DumpFlag' is set +dopt :: DumpFlag -> DynFlags -> Bool +dopt = getDumpFlagFrom verbosity dumpFlags + +-- | Set a 'DumpFlag' +dopt_set :: DynFlags -> DumpFlag -> DynFlags +dopt_set dfs f = dfs{ dumpFlags = EnumSet.insert f (dumpFlags dfs) } + +-- | Unset a 'DumpFlag' +dopt_unset :: DynFlags -> DumpFlag -> DynFlags +dopt_unset dfs f = dfs{ dumpFlags = EnumSet.delete f (dumpFlags dfs) } + +-- | Test whether a 'GeneralFlag' is set +-- +-- Note that `dynamicNow` (i.e., dynamic objects built with `-dynamic-too`) +-- always implicitly enables Opt_PIC, Opt_ExternalDynamicRefs, and disables +-- Opt_SplitSections. +-- +gopt :: GeneralFlag -> DynFlags -> Bool +gopt Opt_PIC dflags + | dynamicNow dflags = True +gopt Opt_ExternalDynamicRefs dflags + | dynamicNow dflags = True +gopt Opt_SplitSections dflags + | dynamicNow dflags = False +gopt f dflags = f `EnumSet.member` generalFlags dflags + +-- | Set a 'GeneralFlag' +gopt_set :: DynFlags -> GeneralFlag -> DynFlags +gopt_set dfs f = dfs{ generalFlags = EnumSet.insert f (generalFlags dfs) } + +-- | Unset a 'GeneralFlag' +gopt_unset :: DynFlags -> GeneralFlag -> DynFlags +gopt_unset dfs f = dfs{ generalFlags = EnumSet.delete f (generalFlags dfs) } + +-- | Test whether a 'WarningFlag' is set +wopt :: WarningFlag -> DynFlags -> Bool +wopt f dflags = f `EnumSet.member` warningFlags dflags + +-- | Set a 'WarningFlag' +wopt_set :: DynFlags -> WarningFlag -> DynFlags +wopt_set dfs f = dfs{ warningFlags = EnumSet.insert f (warningFlags dfs) } + +-- | Unset a 'WarningFlag' +wopt_unset :: DynFlags -> WarningFlag -> DynFlags +wopt_unset dfs f = dfs{ warningFlags = EnumSet.delete f (warningFlags dfs) } + +-- | Test whether a 'WarningFlag' is set as fatal +wopt_fatal :: WarningFlag -> DynFlags -> Bool +wopt_fatal f dflags = f `EnumSet.member` fatalWarningFlags dflags + +-- | Mark a 'WarningFlag' as fatal (do not set the flag) +wopt_set_fatal :: DynFlags -> WarningFlag -> DynFlags +wopt_set_fatal dfs f + = dfs { fatalWarningFlags = EnumSet.insert f (fatalWarningFlags dfs) } + +-- | Mark a 'WarningFlag' as not fatal +wopt_unset_fatal :: DynFlags -> WarningFlag -> DynFlags +wopt_unset_fatal dfs f + = dfs { fatalWarningFlags = EnumSet.delete f (fatalWarningFlags dfs) } + + +-- | Enable all custom warning categories. +wopt_set_all_custom :: DynFlags -> DynFlags +wopt_set_all_custom dfs + = dfs{ customWarningCategories = completeWarningCategorySet } + +-- | Disable all custom warning categories. +wopt_unset_all_custom :: DynFlags -> DynFlags +wopt_unset_all_custom dfs + = dfs{ customWarningCategories = emptyWarningCategorySet } + +-- | Mark all custom warning categories as fatal (do not set the flags). +wopt_set_all_fatal_custom :: DynFlags -> DynFlags +wopt_set_all_fatal_custom dfs + = dfs { fatalCustomWarningCategories = completeWarningCategorySet } + +-- | Mark all custom warning categories as non-fatal. +wopt_unset_all_fatal_custom :: DynFlags -> DynFlags +wopt_unset_all_fatal_custom dfs + = dfs { fatalCustomWarningCategories = emptyWarningCategorySet } + +-- | Set a custom 'WarningCategory' +wopt_set_custom :: DynFlags -> WarningCategory -> DynFlags +wopt_set_custom dfs f = dfs{ customWarningCategories = insertWarningCategorySet f (customWarningCategories dfs) } + +-- | Unset a custom 'WarningCategory' +wopt_unset_custom :: DynFlags -> WarningCategory -> DynFlags +wopt_unset_custom dfs f = dfs{ customWarningCategories = deleteWarningCategorySet f (customWarningCategories dfs) } + +-- | Mark a custom 'WarningCategory' as fatal (do not set the flag) +wopt_set_fatal_custom :: DynFlags -> WarningCategory -> DynFlags +wopt_set_fatal_custom dfs f + = dfs { fatalCustomWarningCategories = insertWarningCategorySet f (fatalCustomWarningCategories dfs) } + +-- | Mark a custom 'WarningCategory' as not fatal +wopt_unset_fatal_custom :: DynFlags -> WarningCategory -> DynFlags +wopt_unset_fatal_custom dfs f + = dfs { fatalCustomWarningCategories = deleteWarningCategorySet f (fatalCustomWarningCategories dfs) } + +-- | Are there any custom warning categories enabled? +wopt_any_custom :: DynFlags -> Bool +wopt_any_custom dfs = not (nullWarningCategorySet (customWarningCategories dfs)) + + +-- | Test whether a 'LangExt.Extension' is set +xopt :: LangExt.Extension -> DynFlags -> Bool +xopt f dflags = f `EnumSet.member` extensionFlags dflags + +-- | Set a 'LangExt.Extension' +xopt_set :: DynFlags -> LangExt.Extension -> DynFlags +xopt_set dfs f + = let onoffs = On f : extensions dfs + in dfs { extensions = onoffs, + extensionFlags = flattenExtensionFlags (language dfs) onoffs } + +-- | Unset a 'LangExt.Extension' +xopt_unset :: DynFlags -> LangExt.Extension -> DynFlags +xopt_unset dfs f + = let onoffs = Off f : extensions dfs + in dfs { extensions = onoffs, + extensionFlags = flattenExtensionFlags (language dfs) onoffs } + +-- | Set or unset a 'LangExt.Extension', unless it has been explicitly +-- set or unset before. +xopt_set_unlessExplSpec + :: LangExt.Extension + -> (DynFlags -> LangExt.Extension -> DynFlags) + -> DynFlags -> DynFlags +xopt_set_unlessExplSpec ext setUnset dflags = + let referedExts = stripOnOff <$> extensions dflags + stripOnOff (On x) = x + stripOnOff (Off x) = x + in + if ext `elem` referedExts then dflags else setUnset dflags ext + +xopt_DuplicateRecordFields :: DynFlags -> FieldLabel.DuplicateRecordFields +xopt_DuplicateRecordFields dfs + | xopt LangExt.DuplicateRecordFields dfs = FieldLabel.DuplicateRecordFields + | otherwise = FieldLabel.NoDuplicateRecordFields + +xopt_FieldSelectors :: DynFlags -> FieldLabel.FieldSelectors +xopt_FieldSelectors dfs + | xopt LangExt.FieldSelectors dfs = FieldLabel.FieldSelectors + | otherwise = FieldLabel.NoFieldSelectors + +lang_set :: DynFlags -> Maybe Language -> DynFlags +lang_set dflags lang = + dflags { + language = lang, + extensionFlags = flattenExtensionFlags lang (extensions dflags) + } + +defaultFlags :: Settings -> [GeneralFlag] +defaultFlags settings +-- See Note [Updating flag description in the User's Guide] + = [ Opt_AutoLinkPackages, + Opt_DiagnosticsShowCaret, + Opt_EmbedManifest, + Opt_FamAppCache, + Opt_GenManifest, + Opt_GhciHistory, + Opt_GhciSandbox, + Opt_GhciDoLoadTargets, + Opt_HelpfulErrors, + Opt_KeepHiFiles, + Opt_KeepOFiles, + Opt_OmitYields, + Opt_PrintBindContents, + Opt_ProfCountEntries, + Opt_SharedImplib, + Opt_SimplPreInlining, + Opt_VersionMacros, + Opt_RPath, + Opt_DumpWithWays, + Opt_CompactUnwind, + Opt_ShowErrorContext, + Opt_SuppressStgReps, + Opt_UnoptimizedCoreForInterpreter, + Opt_SpecialiseIncoherents, + Opt_WriteSelfRecompInfo + ] + + ++ [f | (ns,f) <- optLevelFlags, 0 `elem` ns] + -- The default -O0 options + + -- 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 +-- fits in typed-hole error messages. See Note [Valid hole fits include ...] + -- in the "GHC.Tc.Errors.Hole" module. +validHoleFitDefaults :: [GeneralFlag] +validHoleFitDefaults + = [ Opt_ShowTypeAppOfHoleFits + , Opt_ShowTypeOfHoleFits + , Opt_ShowProvOfHoleFits + , Opt_ShowMatchesOfHoleFits + , Opt_ShowValidHoleFits + , Opt_SortValidHoleFits + , Opt_SortBySizeHoleFits + , Opt_ShowHoleConstraints ] + +-- Note [When is StarIsType enabled] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- The StarIsType extension determines whether to treat '*' as a regular type +-- operator or as a synonym for 'Data.Kind.Type'. Many existing pre-TypeInType +-- programs expect '*' to be synonymous with 'Type', so by default StarIsType is +-- enabled. +-- +-- Programs that use TypeOperators might expect to repurpose '*' for +-- multiplication or another binary operation, but making TypeOperators imply +-- NoStarIsType caused too much breakage on Hackage. +-- + +-- +-- Note [Documenting optimisation flags] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- +-- If you change the list of flags enabled for particular optimisation levels +-- please remember to update the User's Guide. The relevant file is: +-- +-- docs/users_guide/using-optimisation.rst +-- +-- Make sure to note whether a flag is implied by -O0, -O or -O2. + +optLevelFlags :: [([Int], GeneralFlag)] +-- Default settings of flags, before any command-line overrides +optLevelFlags -- see Note [Documenting optimisation flags] + = [ ([0,1,2], Opt_DoLambdaEtaExpansion) + , ([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) + + , ([0], Opt_IgnoreInterfacePragmas) + , ([0], Opt_OmitInterfacePragmas) + + , ([1,2], Opt_CoreConstantFolding) + + , ([1,2], Opt_CallArity) + , ([1,2], Opt_Exitification) + , ([1,2], Opt_CaseMerge) + , ([1,2], Opt_CaseFolding) + , ([1,2], Opt_CmmElimCommonBlocks) + , ([2], Opt_AsmShortcutting) + , ([1,2], Opt_CmmSink) + , ([1,2], Opt_CmmStaticPred) + , ([1,2], Opt_CSE) + , ([1,2], Opt_StgCSE) + , ([2], Opt_StgLiftLams) + , ([1,2], Opt_CmmControlFlow) + + , ([1,2], Opt_EnableRewriteRules) + -- Off for -O0. Otherwise we desugar list literals + -- to 'build' but don't run the simplifier passes that + -- would rewrite them back to cons cells! This seems + -- silly, and matters for the GHCi debugger. + + , ([1,2], Opt_FloatIn) + , ([1,2], Opt_FullLaziness) + , ([1,2], Opt_IgnoreAsserts) + , ([1,2], Opt_Loopification) + , ([1,2], Opt_CfgBlocklayout) -- Experimental + + , ([1,2], Opt_Specialise) + , ([1,2], Opt_CrossModuleSpecialise) + , ([1,2], Opt_InlineGenerics) + , ([1,2], Opt_Strictness) + , ([1,2], Opt_UnboxSmallStrictFields) + , ([1,2], Opt_CprAnal) + , ([1,2], Opt_WorkerWrapper) + , ([1,2], Opt_SolveConstantDicts) + , ([1,2], Opt_NumConstantFolding) + + , ([2], Opt_LiberateCase) + , ([2], Opt_SpecConstr) + , ([2], Opt_FastPAPCalls) +-- , ([2], Opt_RegsGraph) +-- RegsGraph suffers performance regression. See #7679 +-- , ([2], Opt_StaticArgumentTransformation) +-- Static Argument Transformation needs investigation. See #9374 + , ([0,1,2], Opt_SpecEval) + , ([], Opt_SpecEvalDictFun) + ] + + +default_PIC :: Platform -> [GeneralFlag] +default_PIC platform = + case (platformOS platform, platformArch platform) of + -- Darwin always requires PIC. Especially on more recent macOS releases + -- there will be a 4GB __ZEROPAGE that prevents us from using 32bit addresses + -- while we could work around this on x86_64 (like WINE does), we won't be + -- able on aarch64, where this is enforced. + (OSDarwin, ArchX86_64) -> [Opt_PIC] + -- For AArch64, we need to always have PIC enabled. The relocation model + -- on AArch64 does not permit arbitrary relocations. Under ASLR, we can't + -- control much how far apart symbols are in memory for our in-memory static + -- linker; and thus need to ensure we get sufficiently capable relocations. + -- This requires PIC on AArch64, and ExternalDynamicRefs on Linux as on top + -- of that. Subsequently we expect all code on aarch64/linux (and macOS) to + -- be built with -fPIC. + (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. +-- When updating this be sure to update the flag documentation in +-- @docs/users_guide/exts@. +languageExtensions :: Maybe Language -> [LangExt.Extension] + +-- Nothing: the default case +languageExtensions Nothing = languageExtensions (Just defaultLanguage) + +languageExtensions (Just Haskell98) + = [LangExt.ImplicitPrelude, + -- See Note [When is StarIsType enabled] + LangExt.StarIsType, + LangExt.CUSKs, + LangExt.MonomorphismRestriction, + LangExt.NPlusKPatterns, + LangExt.DatatypeContexts, + LangExt.TraditionalRecordSyntax, + LangExt.FieldSelectors, + LangExt.NondecreasingIndentation, + -- strictly speaking non-standard, but we always had this + -- on implicitly before the option was added in 7.1, and + -- 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, + -- Non-standard but enabled for backwards compatability (see GHC proposal #511) + LangExt.ListTuplePuns, + LangExt.ImplicitStagePersistence + ] + +languageExtensions (Just Haskell2010) + = [LangExt.ImplicitPrelude, + -- See Note [When is StarIsType enabled] + LangExt.StarIsType, + LangExt.CUSKs, + LangExt.MonomorphismRestriction, + LangExt.DatatypeContexts, + LangExt.TraditionalRecordSyntax, + LangExt.EmptyDataDecls, + LangExt.ForeignFunctionInterface, + LangExt.PatternGuards, + LangExt.DoAndIfThenElse, + LangExt.FieldSelectors, + LangExt.RelaxedPolyRec, + LangExt.DeepSubsumption, + LangExt.ListTuplePuns, + LangExt.ImplicitStagePersistence + ] + +languageExtensions (Just GHC2021) + = [LangExt.ImplicitPrelude, + -- See Note [When is StarIsType enabled] + LangExt.StarIsType, + LangExt.MonomorphismRestriction, + LangExt.TraditionalRecordSyntax, + LangExt.EmptyDataDecls, + LangExt.ForeignFunctionInterface, + LangExt.PatternGuards, + LangExt.DoAndIfThenElse, + LangExt.FieldSelectors, + LangExt.RelaxedPolyRec, + LangExt.ListTuplePuns, + -- Now the new extensions (not in Haskell2010) + LangExt.BangPatterns, + LangExt.BinaryLiterals, + LangExt.ConstrainedClassMethods, + LangExt.ConstraintKinds, + LangExt.DeriveDataTypeable, + LangExt.DeriveFoldable, + LangExt.DeriveFunctor, + LangExt.DeriveGeneric, + LangExt.DeriveLift, + LangExt.DeriveTraversable, + LangExt.EmptyCase, + LangExt.EmptyDataDeriving, + LangExt.ExistentialQuantification, + LangExt.ExplicitForAll, + LangExt.FlexibleContexts, + LangExt.FlexibleInstances, + LangExt.GADTSyntax, + LangExt.GeneralizedNewtypeDeriving, + LangExt.HexFloatLiterals, + LangExt.ImportQualifiedPost, + LangExt.InstanceSigs, + LangExt.KindSignatures, + LangExt.MultiParamTypeClasses, + LangExt.NamedFieldPuns, + LangExt.NamedWildCards, + LangExt.NumericUnderscores, + LangExt.PolyKinds, + LangExt.PostfixOperators, + LangExt.RankNTypes, + LangExt.ScopedTypeVariables, + LangExt.StandaloneDeriving, + LangExt.StandaloneKindSignatures, + LangExt.TupleSections, + LangExt.TypeApplications, + LangExt.TypeOperators, + 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 + | dynamicNow dflags = addWay WayDyn (targetWays_ dflags) + | otherwise = targetWays_ dflags + +-- | Get target profile +targetProfile :: DynFlags -> Profile +targetProfile dflags = Profile (targetPlatform dflags) (ways dflags) + +-- +-- System tool settings and locations + +programName :: DynFlags -> String +programName dflags = ghcNameVersion_programName $ ghcNameVersion dflags +projectVersion :: DynFlags -> String +projectVersion dflags = ghcNameVersion_projectVersion (ghcNameVersion dflags) +ghcUsagePath :: DynFlags -> FilePath +ghcUsagePath dflags = fileSettings_ghcUsagePath $ fileSettings dflags +ghciUsagePath :: DynFlags -> FilePath +ghciUsagePath dflags = fileSettings_ghciUsagePath $ fileSettings dflags +topDir :: DynFlags -> FilePath +topDir dflags = fileSettings_topDir $ fileSettings dflags +toolDir :: DynFlags -> Maybe FilePath +toolDir dflags = fileSettings_toolDir $ fileSettings dflags +extraGccViaCFlags :: DynFlags -> [String] +extraGccViaCFlags dflags = toolSettings_extraGccViaCFlags $ toolSettings dflags +globalPackageDatabasePath :: DynFlags -> FilePath +globalPackageDatabasePath dflags = fileSettings_globalPackageDatabase $ fileSettings dflags + +-- | The directory for this version of ghc in the user's app directory +-- The appdir used to be in ~/.ghc but to respect the XDG specification +-- we want to move it under $XDG_DATA_HOME/ +-- However, old tooling (like cabal) might still write package environments +-- to the old directory, so we prefer that if a subdirectory of ~/.ghc +-- with the correct target and GHC version suffix exists. +-- +-- i.e. if ~/.ghc/$UNIQUE_SUBDIR exists we use that +-- otherwise we use $XDG_DATA_HOME/$UNIQUE_SUBDIR +-- +-- UNIQUE_SUBDIR is typically a combination of the target platform and GHC version +versionedAppDir :: String -> ArchOS -> MaybeT IO FilePath +versionedAppDir appname platform = do + -- Make sure we handle the case the HOME isn't set (see #11678) + -- We need to fallback to the old scheme if the subdirectory exists. + msum $ map (checkIfExists <=< fmap ( versionedFilePath platform)) + [ tryMaybeT $ getAppUserDataDirectory appname -- this is ~/.ghc/ + , tryMaybeT $ getXdgDirectory XdgData appname -- this is $XDG_DATA_HOME/ + ] + where + checkIfExists dir = tryMaybeT (doesDirectoryExist dir) >>= \case + True -> pure dir + False -> MaybeT (pure Nothing) + +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 + { sdocStyle = style + , sdocColScheme = colScheme dflags + , sdocLastColour = Col.colReset + , sdocShouldUseColor = overrideWith (canUseColor dflags) (useColor dflags) + , 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 + , sdocPrintCaseAsLet = gopt Opt_PprCaseAsLet dflags + , sdocPrintTypecheckerElaboration = gopt Opt_PrintTypecheckerElaboration dflags + , sdocPrintAxiomIncomps = gopt Opt_PrintAxiomIncomps dflags + , sdocPrintExplicitKinds = gopt Opt_PrintExplicitKinds dflags + , sdocPrintExplicitCoercions = gopt Opt_PrintExplicitCoercions dflags + , sdocPrintExplicitRuntimeReps = gopt Opt_PrintExplicitRuntimeReps dflags + , sdocPrintExplicitForalls = gopt Opt_PrintExplicitForalls dflags + , sdocPrintPotentialInstances = gopt Opt_PrintPotentialInstances dflags + , sdocPrintEqualityRelations = gopt Opt_PrintEqualityRelations dflags + , sdocSuppressTicks = gopt Opt_SuppressTicks dflags + , sdocSuppressTypeSignatures = gopt Opt_SuppressTypeSignatures dflags + , sdocSuppressTypeApplications = gopt Opt_SuppressTypeApplications dflags + , sdocSuppressIdInfo = gopt Opt_SuppressIdInfo dflags + , sdocSuppressCoercions = gopt Opt_SuppressCoercions dflags + , sdocSuppressCoercionTypes = gopt Opt_SuppressCoercionTypes dflags + , sdocSuppressUnfoldings = gopt Opt_SuppressUnfoldings dflags + , sdocSuppressVarKinds = gopt Opt_SuppressVarKinds dflags + , sdocSuppressUniques = gopt Opt_SuppressUniques dflags + , sdocSuppressModulePrefixes = gopt Opt_SuppressModulePrefixes dflags + , sdocSuppressStgExts = gopt Opt_SuppressStgExts dflags + , sdocSuppressStgReps = gopt Opt_SuppressStgReps dflags + , sdocErrorSpans = gopt Opt_ErrorSpans dflags + , sdocStarIsType = xopt LangExt.StarIsType dflags + , sdocLinearTypes = xopt LangExt.LinearTypes dflags + , sdocListTuplePuns = xopt LangExt.ListTuplePuns dflags + , sdocPrintTypeAbbreviations = True + , sdocUnitIdForUser = ftext + } + +-- | Initialize the pretty-printing options using the default user style +initDefaultSDocContext :: DynFlags -> SDocContext +initDefaultSDocContext dflags = initSDocContext dflags defaultUserStyle + +initPromotionTickContext :: DynFlags -> PromotionTickContext +initPromotionTickContext dflags = + PromTickCtx { + 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,8 +1,9 @@ {-# LANGUAGE LambdaCase #-} - module GHC.Driver.Env ( Hsc(..) , HscEnv (..) + , hsc_mod_graph + , setModuleGraph , hscUpdateFlags , hscSetFlags , hsc_home_unit @@ -14,8 +15,7 @@ , hsc_all_home_unit_ids , hscUpdateLoggerFlags , hscUpdateHUG - , hscUpdateHPT_lazy - , hscUpdateHPT + , hscInsertHPT , hscSetActiveHomeUnit , hscSetActiveUnitId , hscActiveUnitId @@ -25,24 +25,26 @@ , runInteractiveHsc , hscEPS , hscInterp - , hptCompleteSigs - , hptAllInstances - , hptInstancesBelow - , hptAnns - , hptAllThings - , hptSomeThingsBelowUs - , hptRules , prepareAnnotations , discardIC , lookupType , lookupIfaceByModule + , lookupIfaceByModuleHsc , mainModIs + + , hugRulesBelow + , hugInstancesBelow + , hugAnnsBelow + , hugCompleteSigsBelow + + -- * Legacy API + , hscUpdateHPT ) where import GHC.Prelude -import GHC.Driver.Session +import GHC.Driver.DynFlags import GHC.Driver.Errors ( printOrThrowDiagnostics ) import GHC.Driver.Errors.Types ( GhcMessage ) import GHC.Driver.Config.Logger (initLogFlags) @@ -57,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 @@ -82,16 +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 Data.Set (Set) -import GHC.Unit.Module.Graph -import Data.List (sort) -import qualified Data.Map as Map 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 @@ -114,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 @@ -131,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] @@ -170,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`). -} @@ -221,94 +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 - - --- | 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 - -hptAllThings :: (HomeModInfo -> [a]) -> HscEnv -> [a] -hptAllThings extract hsc_env = concatMap (concatMap extract . eltsHpt . homeUnitEnv_hpt . snd) - (hugElts (hsc_HUG hsc_env)) - --- | 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. -hptModulesBelow :: HscEnv -> UnitId -> ModuleNameWithIsBoot -> Set ModNodeKeyWithUid -hptModulesBelow hsc_env uid mn = filtered_mods $ [ mn | NodeKey_Module mn <- modules_below] - where - td_map = mgTransDeps (hsc_mod_graph hsc_env) - - modules_below = maybe [] Set.toList $ Map.lookup (NodeKey_Module (ModNodeKeyWithUid mn uid)) td_map - - filtered_mods = Set.fromDistinctAscList . filter_mods . sort +-------------------------------------------------------------------------------- +-- * Queries on Transitive Closure +-------------------------------------------------------------------------------- - -- 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 +-- | 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 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 +-- | 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 (hptModulesBelow hsc_env 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 @@ -318,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 (hptModulesBelow hsc_env uid 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 @@ -343,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 @@ -359,20 +332,23 @@ lookupType hsc_env name = do eps <- liftIO $ hscEPS hsc_env let pte = eps_PTE eps - hpt = hsc_HUG hsc_env + lookupTypeInPTE hsc_env pte name - mod = assertPpr (isExternalName name) (ppr name) $ - if isHoleName name - then mkHomeModule (hsc_home_unit hsc_env) (moduleName (nameModule name)) - else nameModule name +lookupTypeInPTE :: HscEnv -> PackageTypeEnv -> Name -> IO (Maybe TyThing) +lookupTypeInPTE hsc_env pte name = ty + where + hpt = hsc_HUG hsc_env + mod = assertPpr (isExternalName name) (ppr name) $ + if isHoleName name + then mkHomeModule (hsc_home_unit hsc_env) (moduleName (nameModule name)) + else nameModule name - !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 - pure ty + ty = if isOneShot (ghcMode (hsc_dflags hsc_env)) + -- in one-shot, we don't use the HPT + 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 @@ -380,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? @@ -392,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 -- @@ -454,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 @@ -7,7 +7,7 @@ import GHC.Driver.Errors.Types ( GhcMessage ) import {-# SOURCE #-} GHC.Driver.Hooks -import GHC.Driver.Session ( ContainsDynFlags(..), HasDynFlags(..), DynFlags ) +import GHC.Driver.DynFlags ( ContainsDynFlags(..), HasDynFlags(..), DynFlags ) import GHC.Driver.LlvmConfigCache (LlvmConfigCache) import GHC.Prelude @@ -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 @@ -2,54 +2,41 @@ module GHC.Driver.Errors ( printOrThrowDiagnostics , printMessages - , handleFlagWarnings , mkDriverPsHeaderMessage ) where import GHC.Driver.Errors.Types -import GHC.Data.Bag import GHC.Prelude -import GHC.Types.SrcLoc import GHC.Types.SourceError import GHC.Types.Error import GHC.Utils.Error -import GHC.Utils.Outputable (hang, ppr, ($$), SDocContext, text, withPprStyle, mkErrStyle, sdocStyle ) +import GHC.Utils.Outputable (hang, ppr, ($$), text, mkErrStyle, sdocStyle, updSDocContext ) import GHC.Utils.Logger -import qualified GHC.Driver.CmdLine as CmdLine -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 (diagnosticReason dia) (diagnosticCode dia)) s $ - withPprStyle style (messageWithHints ctx dia) - | MsgEnvelope { errMsgSpan = s, - errMsgDiagnostic = dia, - errMsgSeverity = sev, - 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 => SDocContext -> a -> SDoc - messageWithHints ctx e = - let main_msg = formatBulleted ctx $ diagnosticMessage msg_opts e + messageWithHints :: a -> SDoc + messageWithHints e = + let main_msg = formatBulleted $ diagnosticMessage msg_opts e in case diagnosticHints e of [] -> main_msg [h] -> main_msg $$ hang (text "Suggested fix:") 2 (ppr h) hs -> main_msg $$ hang (text "Suggested fixes:") 2 - (formatBulleted ctx . mkDecorated . map ppr $ hs) - -handleFlagWarnings :: Logger -> GhcMessageOpts -> DiagOpts -> [CmdLine.Warn] -> IO () -handleFlagWarnings logger print_config opts warns = do - let -- It would be nicer if warns :: [Located SDoc], but that - -- has circular import problems. - bag = listToBag [ mkPlainMsgEnvelope opts loc $ - GhcDriverMessage $ - DriverUnknownMessage $ - UnknownDiagnostic $ - mkPlainDiagnostic reason noHints $ text warn - | CmdLine.Warn reason (L loc warn) <- warns ] - - printOrThrowDiagnostics logger print_config opts (mkMessages bag) + (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 @@ -13,15 +13,16 @@ import GHC.Driver.Errors.Types import GHC.Driver.Flags -import GHC.Driver.Session -import GHC.HsToCore.Errors.Ppr () -import GHC.Parser.Errors.Ppr () -import GHC.Tc.Errors.Ppr () +import GHC.Driver.DynFlags +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,6 +31,10 @@ import Language.Haskell.Syntax.Decls (RuleDecl(..)) import GHC.Tc.Errors.Types (TcRnMessage) import GHC.HsToCore.Errors.Types (DsMessage) +import GHC.Iface.Errors.Types +import GHC.Tc.Errors.Ppr () -- instance Diagnostic TcRnMessage +import GHC.Iface.Errors.Ppr () -- instance Diagnostic IfaceMessage +import GHC.CmmToLlvm.Version (llvmVersionStr, supportedLlvmVersionLowerBound, supportedLlvmVersionUpperBound) -- -- Suggestions @@ -40,12 +45,14 @@ suggestInstantiatedWith pi_mod_name insts = [ InstantiationSuggestion k v | (k,v) <- ((pi_mod_name, mkHoleModule pi_mod_name) : insts) ] -instance Diagnostic GhcMessage where - type DiagnosticOpts GhcMessage = GhcMessageOpts - defaultDiagnosticOpts = GhcMessageOpts (defaultDiagnosticOpts @PsMessage) +instance HasDefaultDiagnosticOpts GhcMessageOpts where + defaultOpts = GhcMessageOpts (defaultDiagnosticOpts @PsMessage) (defaultDiagnosticOpts @TcRnMessage) (defaultDiagnosticOpts @DsMessage) (defaultDiagnosticOpts @DriverMessage) + +instance Diagnostic GhcMessage where + type DiagnosticOpts GhcMessage = GhcMessageOpts diagnosticMessage opts = \case GhcPsMessage m -> diagnosticMessage (psMessageOpts opts) m @@ -55,8 +62,8 @@ -> diagnosticMessage (dsMessageOpts opts) m GhcDriverMessage m -> diagnosticMessage (driverMessageOpts opts) m - GhcUnknownMessage (UnknownDiagnostic @e m) - -> diagnosticMessage (defaultDiagnosticOpts @e) m + GhcUnknownMessage (UnknownDiagnostic f _ m) + -> diagnosticMessage (f opts) m diagnosticReason = \case GhcPsMessage m @@ -82,14 +89,16 @@ GhcUnknownMessage m -> diagnosticHints m - diagnosticCode = constructorCode + diagnosticCode = constructorCode @GHC +instance HasDefaultDiagnosticOpts DriverMessageOpts where + defaultOpts = DriverMessageOpts (defaultDiagnosticOpts @PsMessage) (defaultDiagnosticOpts @IfaceMessage) + instance Diagnostic DriverMessage where type DiagnosticOpts DriverMessage = DriverMessageOpts - defaultDiagnosticOpts = DriverMessageOpts (defaultDiagnosticOpts @PsMessage) diagnosticMessage opts = \case - DriverUnknownMessage (UnknownDiagnostic @e m) - -> diagnosticMessage (defaultDiagnosticOpts @e) m + DriverUnknownMessage (UnknownDiagnostic f _ m) + -> diagnosticMessage (f opts) m DriverPsHeaderMessage m -> diagnosticMessage (psDiagnosticOpts opts) m DriverMissingHomeModules uid missing buildingCabalPackage @@ -146,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 $ @@ -218,7 +227,62 @@ -> mkSimpleDecorated $ vcat ([text "Home units are not closed." , text "It is necessary to also load the following units:" ] ++ map (\uid -> text "-" <+> ppr uid) needed_unit_ids) + DriverInterfaceError reason -> diagnosticMessage (ifaceDiagnosticOpts opts) reason + DriverInconsistentDynFlags msg + -> mkSimpleDecorated $ text msg + DriverSafeHaskellIgnoredExtension ext + -> let arg = text "-X" <> ppr ext + in mkSimpleDecorated $ arg <+> text "is not allowed in Safe Haskell; ignoring" <+> arg + DriverPackageTrustIgnored + -> mkSimpleDecorated $ text "-fpackage-trust ignored; must be specified with a Safe Haskell flag" + + DriverUnrecognisedFlag arg + -> 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 @@ -272,6 +336,23 @@ -> ErrorWithoutFlag DriverHomePackagesNotClosed {} -> ErrorWithoutFlag + DriverInterfaceError reason -> diagnosticReason reason + DriverInconsistentDynFlags {} + -> WarningWithFlag Opt_WarnInconsistentFlags + DriverSafeHaskellIgnoredExtension {} + -> WarningWithoutFlag + DriverPackageTrustIgnored {} + -> WarningWithoutFlag + DriverUnrecognisedFlag {} + -> WarningWithFlag Opt_WarnUnrecognisedWarningFlags + DriverDeprecatedFlag {} + -> WarningWithFlag Opt_WarnDeprecatedFlags + DriverModuleGraphCycle {} + -> ErrorWithoutFlag + DriverInstantiationNodeInDependencyGeneration {} + -> ErrorWithoutFlag + DriverNoConfiguredLLVMToolchain + -> WarningWithoutFlag diagnosticHints = \case DriverUnknownMessage m @@ -328,5 +409,22 @@ -> noHints DriverHomePackagesNotClosed {} -> noHints + DriverInterfaceError reason -> diagnosticHints reason + DriverInconsistentDynFlags {} + -> noHints + DriverSafeHaskellIgnoredExtension {} + -> noHints + DriverPackageTrustIgnored {} + -> noHints + DriverUnrecognisedFlag {} + -> 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,11 +4,11 @@ module GHC.Driver.Errors.Types ( GhcMessage(..) + , AnyGhcDiagnostic , GhcMessageOpts(..) , DriverMessage(..) , DriverMessageOpts(..) , DriverMessages, PsMessage(PsHeaderMessage) - , BuildingCabalPackage(..) , WarningMessages , ErrorMessages , WarnMsg @@ -25,20 +25,25 @@ import Data.Bifunctor import Data.Typeable -import GHC.Driver.Session +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) ) -import GHC.Tc.Errors.Types ( TcRnMessage ) import GHC.HsToCore.Errors.Types ( DsMessage ) import GHC.Hs.Extension (GhcTc) import Language.Haskell.Syntax.Decls (RuleDecl) +import qualified GHC.LanguageExtensions as LangExt import GHC.Generics ( Generic ) +import GHC.Tc.Errors.Types +import GHC.Iface.Errors.Types + -- | A collection of warning messages. -- /INVARIANT/: Each 'GhcMessage' in the collection should have 'SevWarning' severity. type WarningMessages = Messages GhcMessage @@ -90,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 -> GhcMessage + GhcUnknownMessage :: (UnknownDiagnosticFor GhcMessage) -> GhcMessage deriving Generic +type AnyGhcDiagnostic = UnknownDiagnosticFor GhcMessage data GhcMessageOpts = GhcMessageOpts { psMessageOpts :: DiagnosticOpts PsMessage , tcMessageOpts :: DiagnosticOpts TcRnMessage @@ -107,8 +113,8 @@ -- 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 = GhcUnknownMessage . UnknownDiagnostic +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 -- the result of 'IO (Messages TcRnMessage, a)'. @@ -126,7 +132,7 @@ -- | A message from the driver. data DriverMessage where -- | Simply wraps a generic 'Diagnostic' message @a@. - DriverUnknownMessage :: UnknownDiagnostic -> DriverMessage + DriverUnknownMessage :: UnknownDiagnosticFor DriverMessage -> DriverMessage -- | A parse error in parsing a Haskell file header during dependency -- analysis @@ -148,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. @@ -181,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 @@ -368,17 +374,50 @@ DriverHomePackagesNotClosed :: ![UnitId] -> DriverMessage + DriverInterfaceError :: !IfaceMessage -> DriverMessage + + -- TODO: Add structure messages rather than a String + DriverInconsistentDynFlags :: String -> DriverMessage + + DriverSafeHaskellIgnoredExtension :: !LangExt.Extension -> DriverMessage + + DriverPackageTrustIgnored :: DriverMessage + + 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 data DriverMessageOpts = - DriverMessageOpts { psDiagnosticOpts :: DiagnosticOpts PsMessage } + DriverMessageOpts { psDiagnosticOpts :: DiagnosticOpts PsMessage + , ifaceDiagnosticOpts :: DiagnosticOpts IfaceMessage } --- | Pass to a 'DriverMessage' the information whether or not the --- '-fbuilding-cabal-package' flag is set. -data BuildingCabalPackage - = YesBuildingCabalPackage - | NoBuildingCabalPackage - deriving Eq -- | Checks if we are building a cabal package by consulting the 'DynFlags'. checkBuildingCabalPackage :: DynFlags -> BuildingCabalPackage diff --git a/GHC/Driver/Flags.hs b/GHC/Driver/Flags.hs --- a/GHC/Driver/Flags.hs +++ b/GHC/Driver/Flags.hs @@ -1,24 +1,50 @@ +{-# LANGUAGE LambdaCase #-} + module GHC.Driver.Flags ( DumpFlag(..) , getDumpFlagFrom , enabledIfVerbose , GeneralFlag(..) , Language(..) + , defaultLanguage , optimisationFlags , codeGenFlags -- * Warnings + , WarningGroup(..) + , warningGroupName + , warningGroupFlags + , warningGroupIncludesExtendedWarnings , WarningFlag(..) , warnFlagNames , warningGroups , warningHierarchies , smallestWarningGroups + , smallestWarningGroupsForCategory + , standardWarnings , minusWOpts , minusWallOpts , minusWeverythingOpts , minusWcompatOpts , unusedBindsFlags + + , OnOff(..) + , TurnOnFlag + , turnOn + , turnOff + , impliedXFlags + , validHoleFitsImpliedGFlags + , impliedGFlags + , impliedOffGFlags + , glasgowExtsFlags + + , ExtensionDeprecation(..) + , Deprecation(..) + , extensionDeprecation + , deprecation + , extensionNames + , extensionName ) where @@ -32,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 @@ -43,11 +76,353 @@ 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] +-- See Note [Updating flag description in the User's Guide] in GHC.Driver.Session -- debugging flags = Opt_D_dump_cmm @@ -58,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 @@ -102,6 +477,7 @@ | Opt_D_dump_simpl | Opt_D_dump_simpl_iterations | Opt_D_dump_spec + | Opt_D_dump_spec_constr | Opt_D_dump_prep | Opt_D_dump_late_cc | Opt_D_dump_stg_from_core -- ^ Initial STG (CoreToStg output) @@ -109,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 @@ -121,14 +498,18 @@ | Opt_D_dump_types | Opt_D_dump_rules | Opt_D_dump_cse + | Opt_D_dump_float_out + | Opt_D_dump_float_in + | Opt_D_dump_liberate_case + | Opt_D_dump_static_argument_transformation | Opt_D_dump_worker_wrapper | Opt_D_dump_rn_trace | 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 @@ -195,7 +576,7 @@ -- | Enumerates the simple on-or-off dynamic flags data GeneralFlag --- See Note [Updating flag description in the User's Guide] +-- See Note [Updating flag description in the User's Guide] in GHC.Driver.Session = Opt_DumpToFile -- ^ Append dump output to files instead of stdout. | Opt_DumpWithWays -- ^ Use foo.ways. instead of foo. @@ -207,6 +588,7 @@ | Opt_DoAsmLinting | Opt_DoAnnotationLinting | Opt_DoBoundsChecking + | Opt_AddBcoName | Opt_NoLlvmMangler -- hidden flag | Opt_FastLlvm -- hidden flag | Opt_NoTypeableBinds @@ -216,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 @@ -260,20 +646,21 @@ | Opt_LiberateCase | Opt_SpecConstr | 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 @@ -281,21 +668,22 @@ | 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 @@ -305,7 +693,7 @@ -- 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 @@ -313,14 +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_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 @@ -330,6 +728,7 @@ | Opt_IgnoreHpcChanges | Opt_ExcessPrecision | Opt_EagerBlackHoling + | Opt_OrigThunkInfo | Opt_NoHsMain | Opt_SplitSections | Opt_StgStats @@ -348,11 +747,20 @@ | Opt_BuildingCabalPackage | Opt_IgnoreDotGhci | Opt_GhciSandbox + | Opt_InsertBreakpoints | Opt_GhciHistory | Opt_GhciLeakCheck | 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 @@ -389,13 +797,15 @@ | Opt_KeepGoing | Opt_ByteCode | Opt_ByteCodeAndObjectCode + | Opt_UnoptimizedCoreForInterpreter | 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 @@ -418,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 @@ -511,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 @@ -558,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 @@ -570,10 +986,11 @@ , Opt_InfoTableMap , Opt_InfoTableMapWithStack , Opt_InfoTableMapWithFallback + , Opt_OrigThunkInfo ] data WarningFlag = --- See Note [Updating flag description in the User's Guide] +-- See Note [Updating flag description in the User's Guide] in GHC.Driver.Session Opt_WarnDuplicateExports | Opt_WarnDuplicateConstraints | Opt_WarnRedundantConstraints @@ -603,10 +1020,9 @@ | Opt_WarnUnusedRecordWildcards | Opt_WarnRedundantBangPatterns | Opt_WarnRedundantRecordWildcards - | Opt_WarnWarningsDeprecations | 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 @@ -635,43 +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_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_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 @@ -683,11 +1118,11 @@ Opt_WarnAlternativeLayoutRuleTransitional -> "alternative-layout-rule-transitional" :| [] Opt_WarnAmbiguousFields -> "ambiguous-fields" :| [] Opt_WarnAutoOrphans -> "auto-orphans" :| [] + Opt_WarnTermVariableCapture -> "term-variable-capture" :| [] Opt_WarnCPPUndef -> "cpp-undef" :| [] Opt_WarnUnbangedStrictPatterns -> "unbanged-strict-patterns" :| [] Opt_WarnDeferredTypeErrors -> "deferred-type-errors" :| [] Opt_WarnDeferredOutOfScopeVariables -> "deferred-out-of-scope-variables" :| [] - Opt_WarnWarningsDeprecations -> "deprecations" :| ["warnings-deprecations"] Opt_WarnDeprecatedFlags -> "deprecated-flags" :| [] Opt_WarnDerivingDefaults -> "deriving-defaults" :| [] Opt_WarnDerivingTypeable -> "deriving-typeable" :| [] @@ -716,6 +1151,7 @@ Opt_WarnSemigroup -> "semigroup" :| [] Opt_WarnMissingSignatures -> "missing-signatures" :| [] Opt_WarnMissingKindSignatures -> "missing-kind-signatures" :| [] + Opt_WarnMissingPolyKindSignatures -> "missing-poly-kind-signatures" :| [] Opt_WarnMissingExportedSignatures -> "missing-exported-signatures" :| [] Opt_WarnMonomorphism -> "monomorphism-restriction" :| [] Opt_WarnNameShadowing -> "name-shadowing" :| [] @@ -778,6 +1214,20 @@ Opt_WarnTypeEqualityOutOfScope -> "type-equality-out-of-scope" :| [] Opt_WarnLoopySuperclassSolve -> "loopy-superclass-solve" :| [] Opt_WarnTypeEqualityRequiresOperators -> "type-equality-requires-operators" :| [] + 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 @@ -785,24 +1235,62 @@ -- Note [Documenting warning flags] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -- --- If you change the list of warning enabled by default +-- If you change the list of warnings enabled by default -- please remember to update the User's Guide. The relevant file is: -- -- docs/users_guide/using-warnings.rst + +-- | A group of warning flags that can be enabled or disabled collectively, +-- e.g. using @-Wcompat@ to enable all warnings in the 'W_compat' group. +data WarningGroup = W_compat + | W_unused_binds + | W_extended_warnings + | W_default + | W_extra + | W_all + | W_everything + deriving (Bounded, Enum, Eq) + +warningGroupName :: WarningGroup -> String +warningGroupName W_compat = "compat" +warningGroupName W_unused_binds = "unused-binds" +warningGroupName W_extended_warnings = "extended-warnings" +warningGroupName W_default = "default" +warningGroupName W_extra = "extra" +warningGroupName W_all = "all" +warningGroupName W_everything = "everything" + +warningGroupFlags :: WarningGroup -> [WarningFlag] +warningGroupFlags W_compat = minusWcompatOpts +warningGroupFlags W_unused_binds = unusedBindsFlags +warningGroupFlags W_extended_warnings = [] +warningGroupFlags W_default = standardWarnings +warningGroupFlags W_extra = minusWOpts +warningGroupFlags W_all = minusWallOpts +warningGroupFlags W_everything = minusWeverythingOpts + +-- | Does this warning group contain (all) extended warning categories? See +-- Note [Warning categories] in GHC.Unit.Module.Warnings. +-- +-- The 'W_extended_warnings' group contains extended warnings but no +-- 'WarningFlag's, but extended warnings are also treated as part of 'W_default' +-- and every warning group that includes it. +warningGroupIncludesExtendedWarnings :: WarningGroup -> Bool +warningGroupIncludesExtendedWarnings W_compat = False +warningGroupIncludesExtendedWarnings W_unused_binds = False +warningGroupIncludesExtendedWarnings W_extended_warnings = True +warningGroupIncludesExtendedWarnings W_default = True +warningGroupIncludesExtendedWarnings W_extra = True +warningGroupIncludesExtendedWarnings W_all = True +warningGroupIncludesExtendedWarnings W_everything = True + -- | 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 :: [(String, [WarningFlag])] -warningGroups = - [ ("compat", minusWcompatOpts) - , ("unused-binds", unusedBindsFlags) - , ("default", standardWarnings) - , ("extra", minusWOpts) - , ("all", minusWallOpts) - , ("everything", minusWeverythingOpts) - ] +warningGroups :: [WarningGroup] +warningGroups = [minBound..maxBound] -- | Warning group hierarchies, where there is an explicit inclusion -- relation. @@ -814,32 +1302,35 @@ -- Separating this from 'warningGroups' allows for multiple -- hierarchies with no inherent relation to be defined. -- --- The special-case Weverything group is not included. -warningHierarchies :: [[String]] +-- The special-case 'W_everything' group is not included. +warningHierarchies :: [[WarningGroup]] warningHierarchies = hierarchies ++ map (:[]) rest where - hierarchies = [["default", "extra", "all"]] - rest = filter (`notElem` "everything" : concat hierarchies) $ - map fst warningGroups + hierarchies = [[W_default, W_extra, W_all]] + rest = filter (`notElem` W_everything : concat hierarchies) warningGroups -- | Find the smallest group in every hierarchy which a warning -- belongs to, excluding Weverything. -smallestWarningGroups :: WarningFlag -> [String] +smallestWarningGroups :: WarningFlag -> [WarningGroup] smallestWarningGroups flag = mapMaybe go warningHierarchies where -- Because each hierarchy is arranged from smallest to largest, -- the first group we find in a hierarchy which contains the flag -- is the smallest. go (group:rest) = fromMaybe (go rest) $ do - flags <- lookup group warningGroups - guard (flag `elem` flags) + guard (flag `elem` warningGroupFlags group) pure (Just group) go [] = Nothing +-- | The smallest group in every hierarchy to which a custom warning +-- category belongs is currently always @-Wextended-warnings@. +-- See Note [Warning categories] in "GHC.Unit.Module.Warnings". +smallestWarningGroupsForCategory :: [WarningGroup] +smallestWarningGroupsForCategory = [W_extended_warnings] + -- | Warnings enabled unless specified otherwise standardWarnings :: [WarningFlag] standardWarnings -- see Note [Documenting warning flags] = [ Opt_WarnOverlappingPatterns, - Opt_WarnWarningsDeprecations, Opt_WarnDeprecatedFlags, Opt_WarnDeferredTypeErrors, Opt_WarnTypedHoles, @@ -871,14 +1362,21 @@ Opt_WarnNonCanonicalMonadInstances, Opt_WarnNonCanonicalMonoidInstances, Opt_WarnOperatorWhitespaceExtConflict, - Opt_WarnForallIdentifier, Opt_WarnUnicodeBidirectionalFormatCharacters, Opt_WarnGADTMonoLocalBinds, - Opt_WarnLoopySuperclassSolve, - Opt_WarnTypeEqualityRequiresOperators + Opt_WarnBadlyLevelledTypes, + Opt_WarnTypeEqualityRequiresOperators, + 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 ++ @@ -894,7 +1392,7 @@ Opt_WarnUnbangedStrictPatterns ] --- | Things you get with -Wall +-- | Things you get with @-Wall@. minusWallOpts :: [WarningFlag] minusWallOpts = minusWOpts ++ @@ -909,27 +1407,27 @@ Opt_WarnUnusedRecordWildcards, Opt_WarnRedundantRecordWildcards, Opt_WarnIncompleteUniPatterns, - Opt_WarnIncompletePatternsRecUpd + Opt_WarnIncompletePatternsRecUpd, + 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_WarnCompatUnqualifiedImports - , Opt_WarnTypeEqualityOutOfScope + = [ 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 @@ -1,4 +1,5 @@ {-# LANGUAGE GADTs #-} +{-# LANGUAGE TupleSections #-} module GHC.Driver.GenerateCgIPEStub (generateCgIPEStub, lookupEstimatedTicks) where @@ -9,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.Session (gopt, targetPlatform) +import GHC.Driver.DynFlags (gopt, targetPlatform) import GHC.Driver.Config.StgToCmm -import GHC.Driver.Config.Cmm +import GHC.Driver.Config.Cmm ( initCmmConfig ) import GHC.Prelude import GHC.Runtime.Heap.Layout (isStackRep) import GHC.Settings (platformTablesNextToCode) @@ -28,6 +28,7 @@ import GHC.StgToCmm.Prof (initInfoTableProv) import GHC.StgToCmm.Types (CmmCgInfos (..), ModuleLFInfos) import GHC.StgToCmm.Utils +import GHC.StgToCmm.CgUtils (CgStream) import GHC.Types.IPE (InfoTableProvMap (provInfoTables), IpeSourceLocation) import GHC.Types.Name.Set (NonCaffySet) import GHC.Types.Tickish (GenTickish (SourceNote)) @@ -35,6 +36,7 @@ import GHC.Unit.Module (moduleNameString) import qualified GHC.Utils.Logger as Logger import GHC.Utils.Outputable (ppr) +import GHC.Types.Unique.DSM {- Note [Stacktraces from Info Table Provenance Entries (IPE based stack unwinding)] @@ -193,12 +195,13 @@ :: HscEnv -> Module -> InfoTableProvMap + -- ^ If the CmmInfoTables map refer Cmm symbols which were deterministically renamed, the info table provenance map must also be accordingly renamed. -> ( NonCaffySet , ModuleLFInfos , Map CmmInfoTable (Maybe IpeSourceLocation) , IPEStats ) - -> Stream IO CmmGroupSRTs CmmCgInfos + -> CgStream CmmGroupSRTs CmmCgInfos generateCgIPEStub hsc_env this_mod denv (nonCaffySet, moduleLFInfos, infoTablesWithTickishes, initStats) = do let dflags = hsc_dflags hsc_env platform = targetPlatform dflags @@ -207,11 +210,22 @@ cmm_cfg = initCmmConfig dflags cgState <- liftIO initC - -- Yield Cmm for Info Table Provenance Entries (IPEs) - let denv' = denv {provInfoTables = Map.mapKeys cit_lbl infoTablesWithTickishes} - ((mIpeStub, ipeCmmGroup), _) = runC (initStgToCmmConfig dflags this_mod) fstate cgState $ getCmm (initInfoTableProv initStats (Map.keys infoTablesWithTickishes) denv') + -- NB: For determinism, don't use DetUniqFM to rename the IPE Cmm because + -- detRenameCmm isn't idempotent and this Cmm references symbols in the rest + -- of the code! Instead, make sure all labels generated for IPE related code + -- sources uniques from the DUniqSupply gotten from CgStream (see its use in + -- initInfoTableProv/emitIpeBufferListNode). + (mIpeStub, ipeCmmGroup) <- liftEff $ UDSMT $ \dus -> do - (_, ipeCmmGroupSRTs) <- liftIO $ cmmPipeline logger cmm_cfg (emptySRT this_mod) ipeCmmGroup + -- Yield Cmm for Info Table Provenance Entries (IPEs) + let denv' = denv {provInfoTables = Map.mapKeys cit_lbl infoTablesWithTickishes} + (((mIpeStub, dus'), ipeCmmGroup), _) = + runC (initStgToCmmConfig dflags this_mod) fstate cgState $ + getCmm (initInfoTableProv initStats (Map.keys infoTablesWithTickishes) denv' dus) + + return ((mIpeStub, ipeCmmGroup), dus') + + (_, ipeCmmGroupSRTs) <- liftEff $ withDUS $ cmmPipeline logger cmm_cfg (emptySRT this_mod) (removeDeterm ipeCmmGroup) Stream.yield ipeCmmGroupSRTs ipeStub <- diff --git a/GHC/Driver/Hooks.hs b/GHC/Driver/Hooks.hs --- a/GHC/Driver/Hooks.hs +++ b/GHC/Driver/Hooks.hs @@ -32,7 +32,7 @@ import GHC.Prelude import GHC.Driver.Env -import GHC.Driver.Session +import GHC.Driver.DynFlags import GHC.Driver.Pipeline.Phases import GHC.Hs.Decls @@ -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 @@ -121,6 +120,9 @@ be decoupled from its use of the DsM definition in GHC.HsToCore.Types. Since both DsM and the definition of @ForeignsHook@ live in the same module, there is virtually no difference for plugin authors that want to write a foreign hook. + +An awkward consequences is that the `type instance DsForeignsHook`, in +GHC.HsToCore.Types is an orphan instance. -} -- See Note [The Decoupling Abstract Data Hack] @@ -146,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,2648 +1,2915 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE LambdaCase #-} - -{-# LANGUAGE NondecreasingIndentation #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE MultiWayIf #-} - -{-# OPTIONS_GHC -fprof-auto-top #-} - -------------------------------------------------------------------------------- --- --- | Main API for compiling plain Haskell source code. --- --- This module implements compilation of a Haskell source. It is --- /not/ concerned with preprocessing of source files; this is handled --- in "GHC.Driver.Pipeline" --- --- There are various entry points depending on what mode we're in: --- "batch" mode (@--make@), "one-shot" mode (@-c@, @-S@ etc.), and --- "interactive" mode (GHCi). There are also entry points for --- individual passes: parsing, typechecking/renaming, desugaring, and --- simplification. --- --- All the functions here take an 'HscEnv' as a parameter, but none of --- them return a new one: 'HscEnv' is treated as an immutable value --- from here on in (although it has mutable components, for the --- caches). --- --- We use the Hsc monad to deal with warning messages consistently: --- specifically, while executing within an Hsc monad, warnings are --- collected. When a Hsc monad returns to an IO monad, the --- warnings are printed, or compilation aborts if the @-Werror@ --- flag is enabled. --- --- (c) The GRASP/AQUA Project, Glasgow University, 1993-2000 --- -------------------------------------------------------------------------------- - -module GHC.Driver.Main - ( - -- * Making an HscEnv - newHscEnv - , newHscEnvWithHUG - , initHscEnv - - -- * Compiling complete source files - , Messager, batchMsg, batchMultiMsg - , HscBackendAction (..), HscRecompStatus (..) - , initModDetails - , initWholeCoreBindings - , hscMaybeWriteIface - , hscCompileCmmFile - - , hscGenHardCode - , hscInteractive - , mkCgInteractiveGuts - , CgInteractiveGuts - , generateByteCode - , generateFreshByteCode - - -- * Running passes separately - , hscRecompStatus - , hscParse - , hscTypecheckRename - , hscTypecheckAndGetWarnings - , hscDesugar - , makeSimpleDetails - , hscSimplify -- ToDo, shouldn't really export this - , hscDesugarAndSimplify - - -- * Safe Haskell - , hscCheckSafe - , hscGetSafe - - -- * Support for interactive evaluation - , hscParseIdentifier - , hscTcRcLookupName - , hscTcRnGetInfo - , hscIsGHCiMonad - , hscGetModuleInterface - , hscRnImportDecls - , hscTcRnLookupRdrName - , hscStmt, hscParseStmtWithLocation, hscStmtWithLocation, hscParsedStmt - , hscDecls, hscParseDeclsWithLocation, hscDeclsWithLocation, hscParsedDecls - , hscParseModuleWithLocation - , hscTcExpr, TcRnExprMode(..), hscImport, hscKcType - , hscParseExpr - , hscParseType - , hscCompileCoreExpr - , hscTidy - - - -- * Low-level exports for hooks - , hscCompileCoreExpr' - -- We want to make sure that we export enough to be able to redefine - -- hsc_typecheck in client code - , hscParse', hscSimplify', hscDesugar', tcRnModule', doCodeGen - , getHscEnv - , hscSimpleIface' - , oneShotMsg - , dumpIfaceStats - , ioMsgMaybe - , showModuleIndex - , hscAddSptEntries - , writeInterfaceOnlyMode - ) where - -import GHC.Prelude - -import GHC.Platform -import GHC.Platform.Ways - -import GHC.Driver.Plugins -import GHC.Driver.Session -import GHC.Driver.Backend -import GHC.Driver.Env -import GHC.Driver.Env.KnotVars -import GHC.Driver.Errors -import GHC.Driver.Errors.Types -import GHC.Driver.CodeOutput -import GHC.Driver.Config.Cmm.Parser (initCmmParserConfig) -import GHC.Driver.Config.Core.Opt.Simplify ( initSimplifyExprOpts ) -import GHC.Driver.Config.Core.Lint ( endPassHscEnvIO ) -import GHC.Driver.Config.Core.Lint.Interactive ( lintInteractiveExpr ) -import GHC.Driver.Config.CoreToStg -import GHC.Driver.Config.CoreToStg.Prep -import GHC.Driver.Config.Logger (initLogFlags) -import GHC.Driver.Config.Parser (initParserOpts) -import GHC.Driver.Config.Stg.Ppr (initStgPprOpts) -import GHC.Driver.Config.Stg.Pipeline (initStgPipelineOpts) -import GHC.Driver.Config.StgToCmm (initStgToCmmConfig) -import GHC.Driver.Config.Cmm (initCmmConfig) -import GHC.Driver.LlvmConfigCache (initLlvmConfigCache) -import GHC.Driver.Config.StgToJS (initStgToJSConfig) -import GHC.Driver.Config.Diagnostic -import GHC.Driver.Config.Tidy -import GHC.Driver.Hooks -import GHC.Driver.GenerateCgIPEStub (generateCgIPEStub, lookupEstimatedTicks) - -import GHC.Runtime.Context -import GHC.Runtime.Interpreter ( addSptEntry ) -import GHC.Runtime.Loader ( initializePlugins ) -import GHCi.RemoteTypes ( ForeignHValue ) -import GHC.ByteCode.Types - -import GHC.Linker.Loader -import GHC.Linker.Types - -import GHC.Hs -import GHC.Hs.Dump -import GHC.Hs.Stats ( ppSourceStats ) - -import GHC.HsToCore - -import GHC.StgToByteCode ( byteCodeGen ) -import GHC.StgToJS ( stgToJS ) - -import GHC.IfaceToCore ( typecheckIface, typecheckWholeCoreBindings ) - -import GHC.Iface.Load ( ifaceStats, writeIface ) -import GHC.Iface.Make -import GHC.Iface.Recomp -import GHC.Iface.Tidy -import GHC.Iface.Ext.Ast ( mkHieFile ) -import GHC.Iface.Ext.Types ( getAsts, hie_asts, hie_module ) -import GHC.Iface.Ext.Binary ( readHieFile, writeHieFile , hie_file_result) -import GHC.Iface.Ext.Debug ( diffFile, validateScopes ) - -import GHC.Core -import GHC.Core.Lint.Interactive ( interactiveInScope ) -import GHC.Core.Tidy ( tidyExpr ) -import GHC.Core.Type ( Type, Kind ) -import GHC.Core.Multiplicity -import GHC.Core.Utils ( exprType ) -import GHC.Core.ConLike -import GHC.Core.Opt.Pipeline -import GHC.Core.Opt.Pipeline.Types ( CoreToDo (..)) -import GHC.Core.TyCon -import GHC.Core.InstEnv -import GHC.Core.FamInstEnv -import GHC.Core.Rules -import GHC.Core.Stats -import GHC.Core.LateCC (addLateCostCentresPgm) - - -import GHC.CoreToStg.Prep -import GHC.CoreToStg ( coreToStg ) - -import GHC.Parser.Errors.Types -import GHC.Parser -import GHC.Parser.Lexer as Lexer - -import GHC.Tc.Module -import GHC.Tc.Utils.Monad -import GHC.Tc.Utils.Zonk ( ZonkFlexi (DefaultFlexi) ) - -import GHC.Stg.Syntax -import GHC.Stg.Pipeline ( stg2stg, StgCgInfos ) - -import GHC.Builtin.Utils -import GHC.Builtin.Names -import GHC.Builtin.Uniques ( mkPseudoUniqueE ) - -import qualified GHC.StgToCmm as StgToCmm ( codeGen ) -import GHC.StgToCmm.Types (CmmCgInfos (..), ModuleLFInfos) - -import GHC.Cmm -import GHC.Cmm.Info.Build -import GHC.Cmm.Pipeline -import GHC.Cmm.Info -import GHC.Cmm.Parser - -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 -import GHC.Unit.Module.ModSummary -import GHC.Unit.Module.Graph -import GHC.Unit.Module.Imported -import GHC.Unit.Module.Deps -import GHC.Unit.Module.Status -import GHC.Unit.Home.ModInfo - -import GHC.Types.Id -import GHC.Types.SourceError -import GHC.Types.SafeHaskell -import GHC.Types.ForeignStubs -import GHC.Types.Var.Env ( emptyTidyEnv ) -import GHC.Types.Error -import GHC.Types.Fixity.Env -import GHC.Types.CostCentre -import GHC.Types.IPE -import GHC.Types.SourceFile -import GHC.Types.SrcLoc -import GHC.Types.Name -import GHC.Types.Name.Cache ( initNameCache ) -import GHC.Types.Name.Reader -import GHC.Types.Name.Ppr -import GHC.Types.TyThing -import GHC.Types.HpcInfo - -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.Data.FastString -import GHC.Data.Bag -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 qualified Data.List.NonEmpty as NE -import Control.Monad -import Data.IORef -import System.FilePath as FilePath -import System.Directory -import qualified Data.Map as M -import Data.Map (Map) -import qualified Data.Set as S -import Data.Set (Set) -import Control.DeepSeq (force) -import Data.List.NonEmpty (NonEmpty ((:|))) -import GHC.Unit.Module.WholeCoreBindings -import GHC.Types.TypeEnv -import System.IO -import {-# SOURCE #-} GHC.Driver.Pipeline -import Data.Time - -import System.IO.Unsafe ( unsafeInterleaveIO ) -import GHC.Iface.Env ( trace_if ) -import GHC.Stg.InferTags.TagSig (seqTagSig) -import GHC.StgToCmm.Utils (IPEStats) -import GHC.Types.Unique.FM -import GHC.Cmm.Config (CmmConfig) - - -{- ********************************************************************** -%* * - Initialisation -%* * -%********************************************************************* -} - -newHscEnv :: FilePath -> DynFlags -> IO HscEnv -newHscEnv top_dir dflags = newHscEnvWithHUG top_dir dflags (homeUnitId_ dflags) home_unit_graph - where - home_unit_graph = unitEnv_singleton - (homeUnitId_ dflags) - (mkHomeUnitEnv dflags emptyHomePackageTable Nothing) - -newHscEnvWithHUG :: FilePath -> DynFlags -> UnitId -> HomeUnitGraph -> IO HscEnv -newHscEnvWithHUG top_dir top_dynflags cur_unit home_unit_graph = do - nc_var <- initNameCache 'r' knownKeyNames - fc_var <- initFinderCache - logger <- initLogger - tmpfs <- initTmpFs - let dflags = homeUnitEnv_dflags $ 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 - , hsc_type_env_vars = emptyKnotVars - , hsc_interp = Nothing - , hsc_unit_env = unit_env - , hsc_plugins = emptyPlugins - , hsc_hooks = emptyHooks - , hsc_tmpfs = tmpfs - , hsc_llvm_config = llvm_config - } - --- | Initialize HscEnv from an optional top_dir path -initHscEnv :: Maybe FilePath -> IO HscEnv -initHscEnv mb_top_dir = do - top_dir <- findTopDir mb_top_dir - 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) -getDiagnostics = Hsc $ \_ w -> return (w, w) - -clearDiagnostics :: Hsc () -clearDiagnostics = Hsc $ \_ _ -> return ((), emptyMessages) - -logDiagnostics :: Messages GhcMessage -> Hsc () -logDiagnostics w = Hsc $ \_ w0 -> return ((), w0 `unionMessages` w) - -getHscEnv :: Hsc HscEnv -getHscEnv = Hsc $ \e w -> return (e, w) - -handleWarnings :: Hsc () -handleWarnings = do - diag_opts <- initDiagOpts <$> getDynFlags - print_config <- initPrintConfig <$> getDynFlags - logger <- getLogger - w <- getDiagnostics - liftIO $ printOrThrowDiagnostics logger print_config diag_opts w - clearDiagnostics - --- | log warning in the monad, and if there are errors then --- throw a SourceError exception. -logWarningsReportErrors :: (Messages PsWarning, Messages PsError) -> Hsc () -logWarningsReportErrors (warnings,errors) = do - logDiagnostics (GhcPsMessage <$> warnings) - when (not $ isEmptyMessages errors) $ throwErrors (GhcPsMessage <$> errors) - --- | Log warnings and throw errors, assuming the messages --- contain at least one error (e.g. coming from PFailed) -handleWarningsThrowErrors :: (Messages PsWarning, Messages PsError) -> Hsc a -handleWarningsThrowErrors (warnings, errors) = do - diag_opts <- initDiagOpts <$> getDynFlags - logDiagnostics (GhcPsMessage <$> warnings) - logger <- getLogger - let (wWarns, wErrs) = partitionMessages warnings - liftIO $ printMessages logger NoDiagnosticOpts diag_opts wWarns - throwErrors $ fmap GhcPsMessage $ errors `unionMessages` wErrs - --- | Deal with errors and warnings returned by a compilation step --- --- In order to reduce dependencies to other parts of the compiler, functions --- outside the "main" parts of GHC return warnings and errors as a parameter --- and signal success via by wrapping the result in a 'Maybe' type. This --- function logs the returned warnings and propagates errors as exceptions --- (of type 'SourceError'). --- --- This function assumes the following invariants: --- --- 1. If the second result indicates success (is of the form 'Just x'), --- there must be no error messages in the first result. --- --- 2. If there are no error messages, but the second result indicates failure --- there should be warnings in the first result. That is, if the action --- failed, it must have been due to the warnings (i.e., @-Werror@). -ioMsgMaybe :: IO (Messages GhcMessage, Maybe a) -> Hsc a -ioMsgMaybe ioA = do - (msgs, mb_r) <- liftIO ioA - let (warns, errs) = partitionMessages msgs - logDiagnostics warns - case mb_r of - Nothing -> throwErrors errs - Just r -> assert (isEmptyMessages errs ) return r - --- | like ioMsgMaybe, except that we ignore error messages and return --- 'Nothing' instead. -ioMsgMaybe' :: IO (Messages GhcMessage, Maybe a) -> Hsc (Maybe a) -ioMsgMaybe' ioA = do - (msgs, mb_r) <- liftIO $ ioA - logDiagnostics (mkMessages $ getWarningMessages msgs) - return mb_r - --- ----------------------------------------------------------------------------- --- | Lookup things in the compiler's environment - -hscTcRnLookupRdrName :: HscEnv -> LocatedN RdrName -> IO (NonEmpty Name) -hscTcRnLookupRdrName hsc_env0 rdr_name - = runInteractiveHsc hsc_env0 $ - do { hsc_env <- getHscEnv - -- tcRnLookupRdrName can return empty list only together with TcRnUnknownMessage. - -- Once errors has been dealt with in hoistTcRnMessage, we can enforce - -- this invariant in types by converting to NonEmpty. - ; ioMsgMaybe $ fmap (fmap (>>= NE.nonEmpty)) $ hoistTcRnMessage $ - tcRnLookupRdrName hsc_env rdr_name } - -hscTcRcLookupName :: HscEnv -> Name -> IO (Maybe TyThing) -hscTcRcLookupName hsc_env0 name = runInteractiveHsc hsc_env0 $ do - hsc_env <- getHscEnv - ioMsgMaybe' $ hoistTcRnMessage $ tcRnLookupName hsc_env name - -- ignore errors: the only error we're likely to get is - -- "name not found", and the Maybe in the return type - -- is used to indicate that. - -hscTcRnGetInfo :: HscEnv -> Name - -> IO (Maybe (TyThing, Fixity, [ClsInst], [FamInst], SDoc)) -hscTcRnGetInfo hsc_env0 name - = runInteractiveHsc hsc_env0 $ - do { hsc_env <- getHscEnv - ; ioMsgMaybe' $ hoistTcRnMessage $ tcRnGetInfo hsc_env name } - -hscIsGHCiMonad :: HscEnv -> String -> IO Name -hscIsGHCiMonad hsc_env name - = runHsc hsc_env $ ioMsgMaybe $ hoistTcRnMessage $ isGHCiMonad hsc_env name - -hscGetModuleInterface :: HscEnv -> Module -> IO ModIface -hscGetModuleInterface hsc_env0 mod = runInteractiveHsc hsc_env0 $ do - hsc_env <- getHscEnv - ioMsgMaybe $ hoistTcRnMessage $ getModuleInterface hsc_env mod - --- ----------------------------------------------------------------------------- --- | Rename some import declarations -hscRnImportDecls :: HscEnv -> [LImportDecl GhcPs] -> IO GlobalRdrEnv -hscRnImportDecls hsc_env0 import_decls = runInteractiveHsc hsc_env0 $ do - hsc_env <- getHscEnv - ioMsgMaybe $ hoistTcRnMessage $ tcRnImportDecls hsc_env import_decls - --- ----------------------------------------------------------------------------- --- | parse a file, returning the abstract syntax - -hscParse :: HscEnv -> ModSummary -> IO HsParsedModule -hscParse hsc_env mod_summary = runHsc hsc_env $ hscParse' mod_summary - --- internal version, that doesn't fail due to -Werror -hscParse' :: ModSummary -> Hsc HsParsedModule -hscParse' mod_summary - | Just r <- ms_parsed_mod mod_summary = return r - | otherwise = do - dflags <- getDynFlags - logger <- getLogger - {-# SCC "Parser" #-} withTiming logger - (text "Parser"<+>brackets (ppr $ ms_mod mod_summary)) - (const ()) $ do - let src_filename = ms_hspp_file mod_summary - maybe_src_buf = ms_hspp_buf mod_summary - - -------------------------- Parser ---------------- - -- sometimes we already have the buffer in memory, perhaps - -- because we needed to parse the imports out of it, or get the - -- module name. - buf <- case maybe_src_buf of - Just b -> return b - Nothing -> liftIO $ hGetStringBuffer src_filename - - let loc = mkRealSrcLoc (mkFastString src_filename) 1 1 - - let diag_opts = initDiagOpts dflags - when (wopt Opt_WarnUnicodeBidirectionalFormatCharacters dflags) $ do - case checkBidirectionFormatChars (PsLoc loc (BufPos 0)) buf of - Nothing -> pure () - Just chars@((eloc,chr,_) :| _) -> - let span = mkSrcSpanPs $ mkPsSpan eloc (advancePsLoc eloc chr) - in logDiagnostics $ singleMessage $ - mkPlainMsgEnvelope diag_opts span $ - GhcPsMessage $ PsWarnBidirectionalFormatChars chars - - let parseMod | HsigFile == ms_hsc_src mod_summary - = parseSignature - | otherwise = parseModule - - case unP parseMod (initParserState (initParserOpts dflags) buf loc) of - PFailed pst -> - handleWarningsThrowErrors (getPsMessages pst) - POk pst rdr_module -> do - liftIO $ putDumpFileMaybe logger Opt_D_dump_parsed "Parser" - FormatHaskell (ppr rdr_module) - liftIO $ putDumpFileMaybe logger Opt_D_dump_parsed_ast "Parser AST" - FormatHaskell (showAstData NoBlankSrcSpan - NoBlankEpAnnotations - rdr_module) - liftIO $ putDumpFileMaybe logger Opt_D_source_stats "Source Statistics" - FormatText (ppSourceStats False rdr_module) - - -- To get the list of extra source files, we take the list - -- that the parser gave us, - -- - eliminate files beginning with '<'. gcc likes to use - -- pseudo-filenames like "" and "" - -- - normalise them (eliminate differences between ./f and f) - -- - filter out the preprocessed source file - -- - filter out anything beginning with tmpdir - -- - remove duplicates - -- - filter out the .hs/.lhs source filename if we have one - -- - let n_hspp = FilePath.normalise src_filename - TempDir tmp_dir = tmpDir dflags - srcs0 = nub $ filter (not . (tmp_dir `isPrefixOf`)) - $ filter (not . (== n_hspp)) - $ map FilePath.normalise - $ filter (not . isPrefixOf "<") - $ map unpackFS - $ srcfiles pst - srcs1 = case ml_hs_file (ms_location mod_summary) of - Just f -> filter (/= FilePath.normalise f) srcs0 - Nothing -> srcs0 - - -- sometimes we see source files from earlier - -- preprocessing stages that cannot be found, so just - -- filter them out: - srcs2 <- liftIO $ filterM doesFileExist srcs1 - - let res = HsParsedModule { - hpm_module = rdr_module, - hpm_src_files = srcs2 - } - - -- apply parse transformation of plugins - let applyPluginAction p opts - = parsedResultAction p opts mod_summary - hsc_env <- getHscEnv - (ParsedResult transformed (PsMessages warns errs)) <- - withPlugins (hsc_plugins hsc_env) applyPluginAction - (ParsedResult res (uncurry PsMessages $ getPsMessages pst)) - - logDiagnostics (GhcPsMessage <$> warns) - unless (isEmptyMessages errs) $ throwErrors (GhcPsMessage <$> errs) - - return transformed - -checkBidirectionFormatChars :: PsLoc -> StringBuffer -> Maybe (NonEmpty (PsLoc, Char, String)) -checkBidirectionFormatChars start_loc sb - | containsBidirectionalFormatChar sb = Just $ go start_loc sb - | otherwise = Nothing - where - go :: PsLoc -> StringBuffer -> NonEmpty (PsLoc, Char, String) - go loc sb - | atEnd sb = panic "checkBidirectionFormatChars: no char found" - | otherwise = case nextChar sb of - (chr, sb) - | Just desc <- lookup chr bidirectionalFormatChars -> - (loc, chr, desc) :| go1 (advancePsLoc loc chr) sb - | otherwise -> go (advancePsLoc loc chr) sb - - go1 :: PsLoc -> StringBuffer -> [(PsLoc, Char, String)] - go1 loc sb - | atEnd sb = [] - | otherwise = case nextChar sb of - (chr, sb) - | Just desc <- lookup chr bidirectionalFormatChars -> - (loc, chr, desc) : go1 (advancePsLoc loc chr) sb - | otherwise -> go1 (advancePsLoc loc chr) sb - - --- ----------------------------------------------------------------------------- --- | If the renamed source has been kept, extract it. Dump it if requested. - - -extract_renamed_stuff :: ModSummary -> TcGblEnv -> Hsc RenamedStuff -extract_renamed_stuff mod_summary tc_result = do - let rn_info = getRenamedStuff tc_result - - dflags <- getDynFlags - logger <- getLogger - liftIO $ putDumpFileMaybe logger Opt_D_dump_rn_ast "Renamer" - FormatHaskell (showAstData NoBlankSrcSpan NoBlankEpAnnotations rn_info) - - -- Create HIE files - when (gopt Opt_WriteHie dflags) $ do - -- I assume this fromJust is safe because `-fwrite-hie-file` - -- enables the option which keeps the renamed source. - hieFile <- mkHieFile mod_summary tc_result (fromJust rn_info) - let out_file = ml_hie_file $ ms_location mod_summary - liftIO $ writeHieFile out_file hieFile - liftIO $ putDumpFileMaybe logger Opt_D_dump_hie "HIE AST" FormatHaskell (ppr $ hie_asts hieFile) - - -- Validate HIE files - when (gopt Opt_ValidateHie dflags) $ do - hs_env <- Hsc $ \e w -> return (e, w) - liftIO $ do - -- Validate Scopes - case validateScopes (hie_module hieFile) $ getAsts $ hie_asts hieFile of - [] -> putMsg logger $ text "Got valid scopes" - xs -> do - putMsg logger $ text "Got invalid scopes" - mapM_ (putMsg logger) xs - -- Roundtrip testing - file' <- readHieFile (hsc_NC hs_env) out_file - case diffFile hieFile (hie_file_result file') of - [] -> - putMsg logger $ text "Got no roundtrip errors" - xs -> do - putMsg logger $ text "Got roundtrip errors" - let logger' = updateLogFlags logger (log_set_dopt Opt_D_ppr_debug) - mapM_ (putMsg logger') xs - return rn_info - - --- ----------------------------------------------------------------------------- --- | 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 $ - hsc_typecheck True mod_summary (Just rdr_module) - --- | Do Typechecking without throwing SourceError exception with -Werror -hscTypecheckAndGetWarnings :: HscEnv -> ModSummary -> IO (FrontendResult, WarningMessages) -hscTypecheckAndGetWarnings hsc_env summary = runHsc' hsc_env $ do - case hscFrontendHook (hsc_hooks hsc_env) of - Nothing -> FrontendTypecheck . fst <$> hsc_typecheck False summary Nothing - Just h -> h summary - --- | A bunch of logic piled around @tcRnModule'@, concerning a) backpack --- b) concerning dumping rename info and hie files. It would be nice to further --- separate this stuff out, probably in conjunction better separating renaming --- and type checking (#17781). -hsc_typecheck :: Bool -- ^ Keep renamed source? - -> ModSummary -> Maybe HsParsedModule - -> Hsc (TcGblEnv, RenamedStuff) -hsc_typecheck keep_rn mod_summary mb_rdr_module = do - hsc_env <- getHscEnv - let hsc_src = ms_hsc_src mod_summary - dflags = hsc_dflags hsc_env - home_unit = hsc_home_unit hsc_env - outer_mod = ms_mod mod_summary - mod_name = moduleName outer_mod - outer_mod' = mkHomeModule home_unit mod_name - inner_mod = homeModuleNameInstantiation home_unit mod_name - src_filename = ms_hspp_file mod_summary - real_loc = realSrcLocSpan $ mkRealSrcLoc (mkFastString src_filename) 1 1 - keep_rn' = gopt Opt_WriteHie dflags || keep_rn - massert (isHomeModule home_unit outer_mod) - tc_result <- if hsc_src == HsigFile && not (isHoleModule inner_mod) - then ioMsgMaybe $ hoistTcRnMessage $ tcRnInstantiateSignature hsc_env outer_mod' real_loc - else - do hpm <- case mb_rdr_module of - Just hpm -> return hpm - Nothing -> hscParse' mod_summary - tc_result0 <- tcRnModule' mod_summary keep_rn' hpm - if hsc_src == HsigFile - then do (iface, _) <- liftIO $ hscSimpleIface hsc_env Nothing tc_result0 mod_summary - ioMsgMaybe $ hoistTcRnMessage $ - tcRnMergeSignatures hsc_env hpm tc_result0 iface - else return tc_result0 - -- TODO are we extracting anything when we merely instantiate a signature? - -- If not, try to move this into the "else" case above. - rn_info <- extract_renamed_stuff mod_summary tc_result - return (tc_result, rn_info) - --- wrapper around tcRnModule to handle safe haskell extras -tcRnModule' :: ModSummary -> Bool -> HsParsedModule - -> Hsc TcGblEnv -tcRnModule' sum save_rn_syntax mod = do - hsc_env <- getHscEnv - dflags <- getDynFlags - - let diag_opts = initDiagOpts dflags - -- -Wmissing-safe-haskell-mode - when (not (safeHaskellModeEnabled dflags) - && wopt Opt_WarnMissingSafeHaskellMode dflags) $ - logDiagnostics $ singleMessage $ - mkPlainMsgEnvelope diag_opts (getLoc (hpm_module mod)) $ - GhcDriverMessage $ DriverMissingSafeHaskellMode (ms_mod sum) - - tcg_res <- {-# SCC "Typecheck-Rename" #-} - ioMsgMaybe $ hoistTcRnMessage $ - tcRnModule hsc_env sum - save_rn_syntax mod - - -- See Note [Safe Haskell Overlapping Instances Implementation] - -- although this is used for more than just that failure case. - tcSafeOK <- liftIO $ readIORef (tcg_safe_infer tcg_res) - whyUnsafe <- liftIO $ readIORef (tcg_safe_infer_reasons tcg_res) - let allSafeOK = safeInferred dflags && tcSafeOK - - -- end of the safe haskell line, how to respond to user? - if not (safeHaskellOn dflags) - || (safeInferOn dflags && not allSafeOK) - -- if safe Haskell off or safe infer failed, mark unsafe - then markUnsafeInfer tcg_res whyUnsafe - - -- module (could be) safe, throw warning if needed - else do - tcg_res' <- hscCheckSafeImports tcg_res - safe <- liftIO $ readIORef (tcg_safe_infer tcg_res') - when safe $ - case wopt Opt_WarnSafe dflags of - True - | safeHaskell dflags == Sf_Safe -> return () - | otherwise -> (logDiagnostics $ singleMessage $ - mkPlainMsgEnvelope diag_opts (warnSafeOnLoc dflags) $ - GhcDriverMessage $ DriverInferredSafeModule (tcg_mod tcg_res')) - False | safeHaskell dflags == Sf_Trustworthy && - wopt Opt_WarnTrustworthySafe dflags -> - (logDiagnostics $ singleMessage $ - mkPlainMsgEnvelope diag_opts (trustworthyOnLoc dflags) $ - GhcDriverMessage $ DriverMarkedTrustworthyButInferredSafe (tcg_mod tcg_res')) - False -> return () - return tcg_res' - --- | Convert a typechecked module to Core -hscDesugar :: HscEnv -> ModSummary -> TcGblEnv -> IO ModGuts -hscDesugar hsc_env mod_summary tc_result = - runHsc hsc_env $ hscDesugar' (ms_location mod_summary) tc_result - -hscDesugar' :: ModLocation -> TcGblEnv -> Hsc ModGuts -hscDesugar' mod_location tc_result = do - hsc_env <- getHscEnv - ioMsgMaybe $ hoistDsMessage $ - {-# SCC "deSugar" #-} - deSugar hsc_env mod_location tc_result - --- | Make a 'ModDetails' from the results of typechecking. Used when --- typechecking only, as opposed to full compilation. -makeSimpleDetails :: Logger -> TcGblEnv -> IO ModDetails -makeSimpleDetails logger tc_result = mkBootModDetailsTc logger tc_result - - -{- ********************************************************************** -%* * - The main compiler pipeline -%* * -%********************************************************************* -} - -{- - -------------------------------- - The compilation proper - -------------------------------- - -It's the task of the compilation proper to compile Haskell, hs-boot and core -files to either byte-code, hard-code (C, asm, LLVM, etc.) or to nothing at all -(the module is still parsed and type-checked. This feature is mostly used by -IDE's and the likes). Compilation can happen in either 'one-shot', 'batch', -'nothing', or 'interactive' mode. 'One-shot' mode targets hard-code, 'batch' -mode targets hard-code, 'nothing' mode targets nothing and 'interactive' mode -targets byte-code. - -The modes are kept separate because of their different types and meanings: - - * In 'one-shot' mode, we're only compiling a single file and can therefore - discard the new ModIface and ModDetails. This is also the reason it only - targets hard-code; compiling to byte-code or nothing doesn't make sense when - we discard the result. - - * 'Batch' mode is like 'one-shot' except that we keep the resulting ModIface - and ModDetails. 'Batch' mode doesn't target byte-code since that require us to - return the newly compiled byte-code. - - * 'Nothing' mode has exactly the same type as 'batch' mode but they're still - kept separate. This is because compiling to nothing is fairly special: We - don't output any interface files, we don't run the simplifier and we don't - generate any code. - - * 'Interactive' mode is similar to 'batch' mode except that we return the - compiled byte-code together with the ModIface and ModDetails. - -Trying to compile a hs-boot file to byte-code will result in a run-time error. -This is the only thing that isn't caught by the type-system. --} - - -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 --- recompile a module or not! -hscRecompStatus :: Maybe Messager - -> HscEnv - -> ModSummary - -> Maybe ModIface - -> HomeModLinkable - -> (Int,Int) - -> IO HscRecompStatus -hscRecompStatus - mHscMessage hsc_env mod_summary mb_old_iface old_linkable mod_index - = do - let - msg what = case mHscMessage of - Just hscMessage -> hscMessage hsc_env mod_index what (ModuleNode [] mod_summary) - Nothing -> return () - - -- First check to see if the interface file agrees with the - -- source file. - -- - -- Save the interface that comes back from checkOldIface. - -- In one-shot mode we don't have the old iface until this - -- point, when checkOldIface reads it from the disk. - recomp_if_result - <- {-# SCC "checkOldIface" #-} - liftIO $ checkOldIface hsc_env mod_summary mb_old_iface - 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 - UpToDateItem checked_iface -> do - let lcl_dflags = ms_hspp_opts mod_summary - if | not (backendGeneratesCode (backend lcl_dflags)) -> do - -- No need for a linkable, we're good to go - msg UpToDate - return $ HscUpToDate checked_iface emptyHomeModInfoLinkable - | not (backendGeneratesCodeForHsBoot (backend lcl_dflags)) - , IsBoot <- isBootSummary mod_summary -> do - msg UpToDate - return $ HscUpToDate checked_iface emptyHomeModInfoLinkable - | otherwise -> do - -- Do need linkable - -- 1. Just check whether we have bytecode/object linkables and then - -- we will decide if we need them or not. - bc_linkable <- checkByteCode checked_iface mod_summary (homeMod_bytecode old_linkable) - obj_linkable <- liftIO $ checkObjects lcl_dflags (homeMod_object old_linkable) mod_summary - trace_if (hsc_logger hsc_env) (vcat [text "BCO linkable", nest 2 (ppr bc_linkable), text "Object Linkable", ppr obj_linkable]) - - let just_bc = justBytecode <$> bc_linkable - just_o = justObjects <$> obj_linkable - _maybe_both_os = case (bc_linkable, obj_linkable) of - (UpToDateItem bc, UpToDateItem o) -> UpToDateItem (bytecodeAndObjects bc o) - -- If missing object code, just say we need to recompile because of object code. - (_, OutOfDateItem reason _) -> OutOfDateItem reason Nothing - -- If just missing byte code, just use the object code - -- so you should use -fprefer-byte-code with -fwrite-if-simplified-core or you'll - -- end up using bytecode on recompilation - (_, UpToDateItem {} ) -> just_o - - definitely_both_os = case (bc_linkable, obj_linkable) of - (UpToDateItem bc, UpToDateItem o) -> UpToDateItem (bytecodeAndObjects bc o) - -- If missing object code, just say we need to recompile because of object code. - (_, OutOfDateItem reason _) -> OutOfDateItem reason Nothing - -- If just missing byte code, just use the object code - -- so you should use -fprefer-byte-code with -fwrite-if-simplified-core or you'll - -- end up using bytecode on recompilation - (OutOfDateItem reason _, _ ) -> OutOfDateItem reason Nothing - --- pprTraceM "recomp" (ppr just_bc <+> ppr just_o) - -- 2. Decide which of the products we will need - let recomp_linkable_result = case () of - _ | backendCanReuseLoadedCode (backend lcl_dflags) -> - case bc_linkable of - -- If bytecode is available for Interactive then don't load object code - UpToDateItem _ -> just_bc - _ -> case obj_linkable of - -- If o is availabe, then just use that - UpToDateItem _ -> just_o - _ -> outOfDateItemBecause MissingBytecode Nothing - -- Need object files for making object files - | backendWritesFiles (backend lcl_dflags) -> - if gopt Opt_ByteCodeAndObjectCode lcl_dflags - -- We say we are going to write both, so recompile unless we have both - then definitely_both_os - -- Only load the object file unless we are saying we need to produce both. - -- Unless we do this then you can end up using byte-code for a module you specify -fobject-code for. - else just_o - | otherwise -> pprPanic "hscRecompStatus" (text $ show $ backend lcl_dflags) - case recomp_linkable_result of - UpToDateItem linkable -> do - msg $ UpToDate - return $ HscUpToDate checked_iface $ linkable - OutOfDateItem reason _ -> do - msg $ NeedsRecompile reason - return $ HscRecompNeeded $ Just $ mi_iface_hash $ mi_final_exts $ checked_iface - --- | Check that the .o files produced by compilation are already up-to-date --- or not. -checkObjects :: DynFlags -> Maybe Linkable -> ModSummary -> IO (MaybeValidated Linkable) -checkObjects dflags mb_old_linkable summary = do - let - dt_enabled = gopt Opt_BuildDynamicToo dflags - this_mod = ms_mod summary - mb_obj_date = ms_obj_date summary - mb_dyn_obj_date = ms_dyn_obj_date summary - mb_if_date = ms_iface_date summary - obj_fn = ml_obj_file (ms_location summary) - -- dynamic-too *also* produces the dyn_o_file, so have to check - -- that's there, and if it's not, regenerate both .o and - -- .dyn_o - checkDynamicObj k = if dt_enabled - then case (>=) <$> mb_dyn_obj_date <*> mb_if_date of - Just True -> k - _ -> return $ outOfDateItemBecause MissingDynObjectFile Nothing - -- Not in dynamic-too mode - else k - - checkDynamicObj $ - case (,) <$> mb_obj_date <*> mb_if_date of - Just (obj_date, if_date) - | obj_date >= if_date -> - case mb_old_linkable of - Just old_linkable - | isObjectLinkable old_linkable, linkableTime old_linkable == obj_date - -> return $ UpToDateItem old_linkable - _ -> UpToDateItem <$> findObjectLinkable this_mod obj_fn obj_date - _ -> return $ outOfDateItemBecause MissingObjectFile Nothing - --- | Check to see if we can reuse the old linkable, by this point we will --- have just checked that the old interface matches up with the source hash, so --- no need to check that again here -checkByteCode :: ModIface -> ModSummary -> Maybe Linkable -> IO (MaybeValidated Linkable) -checkByteCode iface mod_sum mb_old_linkable = - case mb_old_linkable of - Just old_linkable - | not (isObjectLinkable old_linkable) - -> return $ (UpToDateItem old_linkable) - _ -> loadByteCode iface mod_sum - -loadByteCode :: ModIface -> ModSummary -> IO (MaybeValidated Linkable) -loadByteCode iface mod_sum = do - 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])) - _ -> return $ outOfDateItemBecause MissingBytecode Nothing --------------------------------------------------------------- --- Compilers --------------------------------------------------------------- - - --- 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 - -- NB: This result is actually not that useful - -- in one-shot mode, since we're not going to do - -- any further typechecking. It's much more useful - -- in make mode, since this HMI will go into the HPT. - genModDetails hsc_env' iface - --- Hydrate any WholeCoreBindings linkables into BCOs -initWholeCoreBindings :: HscEnv -> ModIface -> ModDetails -> Linkable -> IO Linkable -initWholeCoreBindings hsc_env mod_iface details (LM utc_time this_mod uls) = LM utc_time this_mod <$> mapM go uls - 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 - -{- -Note [ModDetails and --make mode] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -An interface file consists of two parts - -* The `ModIface` which ends up getting written to disk. - The `ModIface` is a completely acyclic tree, which can be serialised - and de-serialised completely straightforwardly. The `ModIface` is - also the structure that is finger-printed for recompilation control. - -* The `ModDetails` which provides a more structured view that is suitable - for usage during compilation. The `ModDetails` is heavily cyclic: - An `Id` contains a `Type`, which mentions a `TyCon` that contains kind - that mentions other `TyCons`; the `Id` also includes an unfolding that - in turn mentions more `Id`s; And so on. - -The `ModIface` can be created from the `ModDetails` and the `ModDetails` from -a `ModIface`. - -During tidying, just before interfaces are written to disk, -the ModDetails is calculated and then converted into a ModIface (see GHC.Iface.Make.mkIface_). -Then when GHC needs to restart typechecking from a certain point it can read the -interface file, and regenerate the ModDetails from the ModIface (see GHC.IfaceToCore.typecheckIface). -The key part about the loading is that the ModDetails is regenerated lazily -from the ModIface, so that there's only a detailed in-memory representation -for declarations which are actually used from the interface. This mode is -also used when reading interface files from external packages. - -In the old --make mode implementation, the interface was written after compiling a module -but the in-memory ModDetails which was used to compute the ModIface was retained. -The result was that --make mode used much more memory than `-c` mode, because a large amount of -information about a module would be kept in the ModDetails but never used. - -The new idea is that even in `--make` mode, when there is an in-memory `ModDetails` -at hand, we re-create the `ModDetails` from the `ModIface`. Doing this means that -we only have to keep the `ModIface` decls in memory and then lazily load -detailed representations if needed. It turns out this makes a really big difference -to memory usage, halving maximum memory used in some cases. - -See !5492 and #13586 --} - --- Runs the post-typechecking frontend (desugar and simplify). We want to --- generate most of the interface as late as possible. This gets us up-to-date --- and good unfoldings and other info in the interface file. --- --- We might create a interface right away, in which case we also return the --- updated HomeModInfo. But we might also need to run the backend first. In the --- later case Status will be HscRecomp and we return a function from ModIface -> --- HomeModInfo. --- --- HscRecomp in turn will carry the information required to compute a interface --- when passed the result of the code generator. So all this can and is done at --- the call site of the backend code gen if it is run. -hscDesugarAndSimplify :: ModSummary - -> FrontendResult - -> Messages GhcMessage - -> Maybe Fingerprint - -> Hsc HscBackendAction -hscDesugarAndSimplify summary (FrontendTypecheck tc_result) tc_warnings mb_old_hash = do - hsc_env <- getHscEnv - dflags <- getDynFlags - logger <- getLogger - let bcknd = backend dflags - hsc_src = ms_hsc_src summary - diag_opts = initDiagOpts dflags - print_config = initPrintConfig dflags - - -- Desugar, if appropriate - -- - -- 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 - - -- Report the warnings from both typechecking and desugar together - w <- getDiagnostics - liftIO $ printOrThrowDiagnostics logger print_config diag_opts (unionMessages tc_warnings w) - clearDiagnostics - - -- Simplify, if appropriate, and (whether we simplified or not) generate an - -- interface file. - case mb_desugar of - -- Just cause we desugared doesn't mean we are generating code, see above. - Just desugared_guts | backendGeneratesCode bcknd -> do - plugins <- liftIO $ readIORef (tcg_th_coreplugins tc_result) - simplified_guts <- hscSimplify' plugins desugared_guts - - (cg_guts, details) <- - liftIO $ hscTidy hsc_env simplified_guts - - let !partial_iface = - {-# 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) - - return HscRecomp { hscs_guts = cg_guts, - hscs_mod_location = ms_location summary, - hscs_partial_iface = partial_iface, - hscs_old_iface_hash = mb_old_hash - } - - Just desugared_guts | gopt Opt_WriteIfSimplifiedCore dflags -> do - -- If -fno-code is enabled (hence we fall through to this case) - -- Running the simplifier once is necessary before doing byte code generation - -- in order to inline data con wrappers but we honour whatever level of simplificication the - -- user requested. See #22008 for some discussion. - plugins <- liftIO $ readIORef (tcg_th_coreplugins tc_result) - simplified_guts <- hscSimplify' plugins desugared_guts - (cg_guts, _) <- - liftIO $ hscTidy hsc_env simplified_guts - - (iface, _details) <- liftIO $ - hscSimpleIface hsc_env (Just $ cg_binds cg_guts) tc_result summary - - liftIO $ hscMaybeWriteIface logger dflags True iface mb_old_hash (ms_location summary) - - return $ HscUpdate iface - - - -- We are not generating code or writing an interface with simplified core so we can skip simplification - -- and generate a simple interface. - _ -> do - (iface, _details) <- liftIO $ - hscSimpleIface hsc_env Nothing tc_result summary - - liftIO $ hscMaybeWriteIface logger dflags True iface mb_old_hash (ms_location summary) - - return $ HscUpdate iface - -{- -Note [Writing interface files] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We write one interface file per module and per compilation, except with --dynamic-too where we write two interface files (non-dynamic and dynamic). - -We can write two kinds of interfaces (see Note [Interface file stages] in -"GHC.Driver.Types"): - - * simple interface: interface generated after the core pipeline - - * full interface: simple interface completed with information from the - backend - -Depending on the situation, we write one or the other (using -`hscMaybeWriteIface`). We must be careful with `-dynamic-too` because only the -backend is run twice, so if we write a simple interface we need to write both -the non-dynamic and the dynamic interfaces at the same time (with the same -contents). - -Cases for which we generate simple interfaces: - - * GHC.Driver.Main.hscDesugarAndSimplify: when a compilation does NOT require (re)compilation - of the hard code - - * GHC.Driver.Pipeline.compileOne': when we run in One Shot mode and target - bytecode (if interface writing is forced). - - * GHC.Driver.Backpack uses simple interfaces for indefinite units - (units with module holes). It writes them indirectly by forcing the - -fwrite-interface flag while setting backend to NoBackend. - -Cases for which we generate full interfaces: - - * GHC.Driver.Pipeline.runPhase: when we must be compiling to regular hard - code and/or require recompilation. - -By default interface file names are derived from module file names by adding -suffixes. The interface file name can be overloaded with "-ohi", except when -`-dynamic-too` is used. - --} - --- | Write interface files -hscMaybeWriteIface - :: Logger - -> DynFlags - -> Bool - -- ^ Is this a simple interface generated after the core pipeline, or one - -- with information from the backend? See: Note [Writing interface files] - -> ModIface - -> Maybe Fingerprint - -- ^ The old interface hash, used to decide if we need to actually write the - -- new interface. - -> ModLocation - -> IO () -hscMaybeWriteIface logger dflags is_simple iface old_iface mod_location = do - let force_write_interface = gopt Opt_WriteInterface dflags - write_interface = backendWritesFiles (backend dflags) - - write_iface dflags' iface = - let !iface_name = if dynamicNow dflags' then ml_dyn_hi_file mod_location else ml_hi_file mod_location - profile = targetProfile dflags' - in - {-# SCC "writeIface" #-} - withTiming logger - (text "WriteIface"<+>brackets (text iface_name)) - (const ()) - (writeIface logger profile iface_name iface) - - if (write_interface || force_write_interface) then do - - -- FIXME: with -dynamic-too, "change" is only meaningful for the - -- non-dynamic interface, not for the dynamic one. We should have another - -- flag for the dynamic interface. In the meantime: - -- - -- * when we write a single full interface, we check if we are - -- currently writing the dynamic interface due to -dynamic-too, in - -- which case we ignore "change". - -- - -- * when we write two simple interfaces at once because of - -- dynamic-too, we use "change" both for the non-dynamic and the - -- 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 dt = dynamicTooState dflags - - when (logHasDumpFlag logger Opt_D_dump_if_trace) $ putMsg logger $ - hang (text "Writing interface(s):") 2 $ vcat - [ text "Kind:" <+> if is_simple then text "simple" else text "full" - , text "Hash change:" <+> ppr change - , text "DynamicToo state:" <+> text (show dt) - ] - - if is_simple - then when change $ do -- FIXME: see 'change' comment above - write_iface dflags iface - case dt of - DT_Dont -> return () - DT_Dyn -> panic "Unexpected DT_Dyn state when writing simple interface" - DT_OK -> write_iface (setDynamicNow dflags) iface - else case dt of - DT_Dont | change -> write_iface dflags iface - DT_OK | change -> write_iface dflags iface - -- FIXME: see change' comment above - DT_Dyn -> write_iface dflags iface - _ -> return () - - when (gopt Opt_WriteHie dflags) $ do - -- This is slightly hacky. A hie file is considered to be up to date - -- if its modification time on disk is greater than or equal to that - -- of the .hi file (since we should always write a .hi file if we are - -- writing a .hie file). However, with the way this code is - -- structured at the moment, the .hie file is often written before - -- the .hi file; by touching the file here, we ensure that it is - -- correctly considered up-to-date. - -- - -- The file should exist by the time we get here, but we check for - -- existence just in case, so that we don't accidentally create empty - -- .hie files. - let hie_file = ml_hie_file mod_location - whenM (doesFileExist hie_file) $ - GHC.SysTools.touch logger dflags "Touching hie file" hie_file - else - -- See Note [Strictness in ModIface] - forceModIface iface - --------------------------------------------------------------- --- NoRecomp handlers --------------------------------------------------------------- - - --- | genModDetails is used to initialise 'ModDetails' at the end of compilation. --- This has two main effects: --- 1. Increases memory usage by unloading a lot of the TypeEnv --- 2. Globalising certain parts (DFunIds) in the TypeEnv (which used to be achieved using UpdateIdInfos) --- For the second part to work, it's critical that we use 'initIfaceLoadModule' here rather than --- 'initIfaceCheck' as 'initIfaceLoadModule' removes the module from the KnotVars, otherwise name lookups --- succeed by hitting the old TypeEnv, which missing out the critical globalisation step for DFuns. - --- After the DFunIds are globalised, it's critical to overwrite the old TypeEnv with the new --- more compact and more correct version. This reduces memory usage whilst compiling the rest of --- the module loop. -genModDetails :: HscEnv -> ModIface -> IO ModDetails -genModDetails hsc_env old_iface - = do - -- CRITICAL: To use initIfaceLoadModule as that removes the current module from the KnotVars and - -- hence properly globalises DFunIds. - new_details <- {-# SCC "tcRnIface" #-} - initIfaceLoadModule hsc_env (mi_module old_iface) (typecheckIface old_iface) - case lookupKnotVars (hsc_type_env_vars hsc_env) (mi_module old_iface) of - Nothing -> return () - Just te_var -> writeIORef te_var (md_types new_details) - 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 --------------------------------------------------------------- - --- Note [Safe Haskell Trust Check] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- Safe Haskell checks that an import is trusted according to the following --- rules for an import of module M that resides in Package P: --- --- * If M is recorded as Safe and all its trust dependencies are OK --- then M is considered safe. --- * If M is recorded as Trustworthy and P is considered trusted and --- all M's trust dependencies are OK then M is considered safe. --- --- By trust dependencies we mean that the check is transitive. So if --- a module M that is Safe relies on a module N that is trustworthy, --- importing module M will first check (according to the second case) --- that N is trusted before checking M is trusted. --- --- This is a minimal description, so please refer to the user guide --- for more details. The user guide is also considered the authoritative --- source in this matter, not the comments or code. - - --- Note [Safe Haskell Inference] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- Safe Haskell does Safe inference on modules that don't have any specific --- safe haskell mode flag. The basic approach to this is: --- * When deciding if we need to do a Safe language check, treat --- an unmarked module as having -XSafe mode specified. --- * For checks, don't throw errors but return them to the caller. --- * Caller checks if there are errors: --- * For modules explicitly marked -XSafe, we throw the errors. --- * For unmarked modules (inference mode), we drop the errors --- and mark the module as being Unsafe. --- --- It used to be that we only did safe inference on modules that had no Safe --- Haskell flags, but now we perform safe inference on all modules as we want --- to allow users to set the `-Wsafe`, `-Wunsafe` and --- `-Wtrustworthy-safe` flags on Trustworthy and Unsafe modules so that a --- user can ensure their assumptions are correct and see reasons for why a --- module is safe or unsafe. --- --- This is tricky as we must be careful when we should throw an error compared --- to just warnings. For checking safe imports we manage it as two steps. First --- we check any imports that are required to be safe, then we check all other --- imports to see if we can infer them to be safe. - - --- | Check that the safe imports of the module being compiled are valid. --- If not we either issue a compilation error if the module is explicitly --- using Safe Haskell, or mark the module as unsafe if we're in safe --- inference mode. -hscCheckSafeImports :: TcGblEnv -> Hsc TcGblEnv -hscCheckSafeImports tcg_env = do - dflags <- getDynFlags - tcg_env' <- checkSafeImports tcg_env - checkRULES dflags tcg_env' - - where - checkRULES dflags tcg_env' = - let diag_opts = initDiagOpts dflags - in case safeLanguageOn dflags of - True -> do - -- XSafe: we nuke user written RULES - logDiagnostics $ fmap GhcDriverMessage $ warns diag_opts (tcg_rules tcg_env') - return tcg_env' { tcg_rules = [] } - False - -- SafeInferred: user defined RULES, so not safe - | safeInferOn dflags && not (null $ tcg_rules tcg_env') - -> markUnsafeInfer tcg_env' $ warns diag_opts (tcg_rules tcg_env') - - -- Trustworthy OR SafeInferred: with no RULES - | otherwise - -> return tcg_env' - - warns diag_opts rules = mkMessages $ listToBag $ map (warnRules diag_opts) rules - - warnRules :: DiagOpts -> LRuleDecl GhcTc -> MsgEnvelope DriverMessage - warnRules diag_opts (L loc rule) = - mkPlainMsgEnvelope diag_opts (locA loc) $ DriverUserDefinedRuleIgnored rule - --- | Validate that safe imported modules are actually safe. For modules in the --- HomePackage (the package the module we are compiling in resides) this just --- involves checking its trust type is 'Safe' or 'Trustworthy'. For modules --- that reside in another package we also must check that the external package --- is trusted. See the Note [Safe Haskell Trust Check] above for more --- information. --- --- The code for this is quite tricky as the whole algorithm is done in a few --- distinct phases in different parts of the code base. See --- 'GHC.Rename.Names.rnImportDecl' for where package trust dependencies for a --- module are collected and unioned. Specifically see the Note [Tracking Trust --- Transitively] in "GHC.Rename.Names" and the Note [Trust Own Package] in --- "GHC.Rename.Names". -checkSafeImports :: TcGblEnv -> Hsc TcGblEnv -checkSafeImports tcg_env - = do - dflags <- getDynFlags - imps <- mapM condense imports' - let (safeImps, regImps) = partition (\(_,_,s) -> s) imps - - -- We want to use the warning state specifically for detecting if safe - -- inference has failed, so store and clear any existing warnings. - oldErrs <- getDiagnostics - clearDiagnostics - - -- Check safe imports are correct - safePkgs <- S.fromList <$> mapMaybeM checkSafe safeImps - safeErrs <- getDiagnostics - clearDiagnostics - - -- Check non-safe imports are correct if inferring safety - -- See the Note [Safe Haskell Inference] - (infErrs, infPkgs) <- case (safeInferOn dflags) of - False -> return (emptyMessages, S.empty) - True -> do infPkgs <- S.fromList <$> mapMaybeM checkSafe regImps - infErrs <- getDiagnostics - clearDiagnostics - return (infErrs, infPkgs) - - -- restore old errors - logDiagnostics oldErrs - - diag_opts <- initDiagOpts <$> getDynFlags - print_config <- initPrintConfig <$> getDynFlags - logger <- getLogger - - -- Will throw if failed safe check - liftIO $ printOrThrowDiagnostics logger print_config diag_opts safeErrs - - -- No fatal warnings or errors: passed safe check - let infPassed = isEmptyMessages infErrs - tcg_env' <- case (not infPassed) of - True -> markUnsafeInfer tcg_env infErrs - False -> return tcg_env - when (packageTrustOn dflags) $ checkPkgTrust pkgReqs - let newTrust = pkgTrustReqs dflags safePkgs infPkgs infPassed - return tcg_env' { tcg_imports = impInfo `plusImportAvails` newTrust } - - where - impInfo = tcg_imports tcg_env -- ImportAvails - imports = imp_mods impInfo -- ImportedMods - imports1 = moduleEnvToList imports -- (Module, [ImportedBy]) - imports' = map (fmap importedByUser) imports1 -- (Module, [ImportedModsVal]) - pkgReqs = imp_trust_pkgs impInfo -- [Unit] - - condense :: (Module, [ImportedModsVal]) -> Hsc (Module, SrcSpan, IsSafeImport) - condense (_, []) = panic "GHC.Driver.Main.condense: Pattern match failure!" - condense (m, x:xs) = do imv <- foldlM cond' x xs - return (m, imv_span imv, imv_is_safe imv) - - -- ImportedModsVal = (ModuleName, Bool, SrcSpan, IsSafeImport) - cond' :: ImportedModsVal -> ImportedModsVal -> Hsc ImportedModsVal - cond' v1 v2 - | imv_is_safe v1 /= imv_is_safe v2 - = throwOneError $ - mkPlainErrorMsgEnvelope (imv_span v1) $ - GhcDriverMessage $ DriverMixedSafetyImport (imv_name v1) - | otherwise - = return v1 - - -- easier interface to work with - checkSafe :: (Module, SrcSpan, a) -> Hsc (Maybe UnitId) - checkSafe (m, l, _) = fst `fmap` hscCheckSafe' m l - - -- what pkg's to add to our trust requirements - pkgTrustReqs :: DynFlags -> Set UnitId -> Set UnitId -> - Bool -> ImportAvails - pkgTrustReqs dflags req inf infPassed | safeInferOn dflags - && not (safeHaskellModeEnabled dflags) && infPassed - = emptyImportAvails { - imp_trust_pkgs = req `S.union` inf - } - pkgTrustReqs dflags _ _ _ | safeHaskell dflags == Sf_Unsafe - = emptyImportAvails - pkgTrustReqs _ req _ _ = emptyImportAvails { imp_trust_pkgs = req } - --- | Check that a module is safe to import. --- --- We return True to indicate the import is safe and False otherwise --- although in the False case an exception may be thrown first. -hscCheckSafe :: HscEnv -> Module -> SrcSpan -> IO Bool -hscCheckSafe hsc_env m l = runHsc hsc_env $ do - dflags <- getDynFlags - pkgs <- snd `fmap` hscCheckSafe' m l - when (packageTrustOn dflags) $ checkPkgTrust pkgs - errs <- getDiagnostics - return $ isEmptyMessages errs - --- | Return if a module is trusted and the pkgs it depends on to be trusted. -hscGetSafe :: HscEnv -> Module -> SrcSpan -> IO (Bool, Set UnitId) -hscGetSafe hsc_env m l = runHsc hsc_env $ do - (self, pkgs) <- hscCheckSafe' m l - good <- isEmptyMessages `fmap` getDiagnostics - clearDiagnostics -- don't want them printed... - let pkgs' | Just p <- self = S.insert p pkgs - | otherwise = pkgs - return (good, pkgs') - --- | Is a module trusted? If not, throw or log errors depending on the type. --- Return (regardless of trusted or not) if the trust type requires the modules --- own package be trusted and a list of other packages required to be trusted --- (these later ones haven't been checked) but the own package trust has been. -hscCheckSafe' :: Module -> SrcSpan - -> Hsc (Maybe UnitId, Set UnitId) -hscCheckSafe' m l = do - hsc_env <- getHscEnv - let home_unit = hsc_home_unit hsc_env - (tw, pkgs) <- isModSafe home_unit m l - case tw of - False -> return (Nothing, pkgs) - True | isHomeModule home_unit m -> return (Nothing, pkgs) - -- TODO: do we also have to check the trust of the instantiation? - -- Not necessary if that is reflected in dependencies - | otherwise -> return (Just $ toUnitId (moduleUnit m), pkgs) - where - isModSafe :: HomeUnit -> Module -> SrcSpan -> Hsc (Bool, Set UnitId) - isModSafe home_unit m l = do - hsc_env <- getHscEnv - dflags <- getDynFlags - iface <- lookup' m - let diag_opts = initDiagOpts dflags - case iface of - -- can't load iface to check trust! - Nothing -> throwOneError $ - mkPlainErrorMsgEnvelope l $ - GhcDriverMessage $ DriverCannotLoadInterfaceFile m - - -- got iface, check trust - Just iface' -> - let trust = getSafeMode $ mi_trust iface' - trust_own_pkg = mi_trust_pkg iface' - -- check module is trusted - safeM = trust `elem` [Sf_Safe, Sf_SafeInferred, Sf_Trustworthy] - -- check package is trusted - safeP = packageTrusted dflags (hsc_units hsc_env) home_unit trust trust_own_pkg m - -- pkg trust reqs - pkgRs = dep_trusted_pkgs $ mi_deps iface' - -- warn if Safe module imports Safe-Inferred module. - warns = if wopt Opt_WarnInferredSafeImports dflags - && safeLanguageOn dflags - && trust == Sf_SafeInferred - then inferredImportWarn diag_opts - else emptyMessages - -- General errors we throw but Safe errors we log - errs = case (safeM, safeP) of - (True, True ) -> emptyMessages - (True, False) -> pkgTrustErr - (False, _ ) -> modTrustErr - in do - logDiagnostics warns - logDiagnostics errs - return (trust == Sf_Trustworthy, pkgRs) - - where - state = hsc_units hsc_env - inferredImportWarn diag_opts = singleMessage - $ mkMsgEnvelope diag_opts l (pkgQual state) - $ GhcDriverMessage $ DriverInferredSafeImport m - pkgTrustErr = singleMessage - $ mkErrorMsgEnvelope l (pkgQual state) - $ GhcDriverMessage $ DriverCannotImportFromUntrustedPackage state m - modTrustErr = singleMessage - $ mkErrorMsgEnvelope l (pkgQual state) - $ GhcDriverMessage $ DriverCannotImportUnsafeModule m - - -- Check the package a module resides in is trusted. Safe compiled - -- modules are trusted without requiring that their package is trusted. For - -- trustworthy modules, modules in the home package are trusted but - -- otherwise we check the package trust flag. - packageTrusted :: DynFlags -> UnitState -> HomeUnit -> SafeHaskellMode -> Bool -> Module -> Bool - packageTrusted dflags unit_state home_unit safe_mode trust_own_pkg mod = - case safe_mode of - Sf_None -> False -- shouldn't hit these cases - Sf_Ignore -> False -- shouldn't hit these cases - Sf_Unsafe -> False -- prefer for completeness. - _ | not (packageTrustOn dflags) -> True - Sf_Safe | not trust_own_pkg -> True - Sf_SafeInferred | not trust_own_pkg -> True - _ | isHomeModule home_unit mod -> True - _ -> unitIsTrusted $ unsafeLookupUnit unit_state (moduleUnit m) - - 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 - -- 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 - case iface of - Just _ -> return iface - Nothing -> snd `fmap` (liftIO $ getModuleInterface hsc_env m) - - --- | Check the list of packages are trusted. -checkPkgTrust :: Set UnitId -> Hsc () -checkPkgTrust pkgs = do - hsc_env <- getHscEnv - let errors = S.foldr go emptyBag pkgs - state = hsc_units hsc_env - go pkg acc - | unitIsTrusted $ unsafeLookupUnitId state pkg - = acc - | otherwise - = (`consBag` acc) - $ mkErrorMsgEnvelope noSrcSpan (pkgQual state) - $ GhcDriverMessage - $ DriverPackageNotTrusted state pkg - if isEmptyBag errors - then return () - else liftIO $ throwErrors $ mkMessages errors - --- | Set module to unsafe and (potentially) wipe trust information. --- --- Make sure to call this method to set a module to inferred unsafe, it should --- be a central and single failure method. We only wipe the trust information --- when we aren't in a specific Safe Haskell mode. --- --- While we only use this for recording that a module was inferred unsafe, we --- may call it on modules using Trustworthy or Unsafe flags so as to allow --- warning flags for safety to function correctly. See Note [Safe Haskell --- Inference]. -markUnsafeInfer :: forall e . Diagnostic e => TcGblEnv -> Messages e -> Hsc TcGblEnv -markUnsafeInfer tcg_env whyUnsafe = do - dflags <- getDynFlags - - let reason = WarningWithFlag Opt_WarnUnsafe - let diag_opts = initDiagOpts dflags - when (diag_wopt Opt_WarnUnsafe diag_opts) - (logDiagnostics $ singleMessage $ - mkPlainMsgEnvelope diag_opts (warnUnsafeOnLoc dflags) $ - GhcDriverMessage $ DriverUnknownMessage $ - UnknownDiagnostic $ - mkPlainDiagnostic reason noHints $ - whyUnsafe' dflags) - - liftIO $ writeIORef (tcg_safe_infer tcg_env) False - liftIO $ writeIORef (tcg_safe_infer_reasons tcg_env) emptyMessages - -- NOTE: Only wipe trust when not in an explicitly safe haskell mode. Other - -- times inference may be on but we are in Trustworthy mode -- so we want - -- to record safe-inference failed but not wipe the trust dependencies. - case not (safeHaskellModeEnabled dflags) of - True -> return $ tcg_env { tcg_imports = wiped_trust } - False -> return tcg_env - - where - wiped_trust = (tcg_imports tcg_env) { imp_trust_pkgs = S.empty } - pprMod = ppr $ moduleName $ tcg_mod tcg_env - whyUnsafe' df = vcat [ quotes pprMod <+> text "has been inferred as unsafe!" - , text "Reason:" - , nest 4 $ (vcat $ badFlags df) $+$ - -- MP: Using defaultDiagnosticOpts here is not right but it's also not right to handle these - -- unsafety error messages in an unstructured manner. - (vcat $ pprMsgEnvelopeBagWithLoc (defaultDiagnosticOpts @e) (getMessages whyUnsafe)) $+$ - (vcat $ badInsts $ tcg_insts tcg_env) - ] - badFlags df = concatMap (badFlag df) unsafeFlagsForInfer - badFlag df (str,loc,on,_) - | on df = [mkLocMessage MCOutput (loc df) $ - text str <+> text "is not allowed in Safe Haskell"] - | otherwise = [] - badInsts insts = concatMap badInst insts - - checkOverlap (NoOverlap _) = False - checkOverlap _ = True - - badInst ins | checkOverlap (overlapMode (is_flag ins)) - = [mkLocMessage MCOutput (nameSrcSpan $ getName $ is_dfun ins) $ - ppr (overlapMode $ is_flag ins) <+> - text "overlap mode isn't allowed in Safe Haskell"] - | otherwise = [] - --- | Figure out the final correct safe haskell mode -hscGetSafeMode :: TcGblEnv -> Hsc SafeHaskellMode -hscGetSafeMode tcg_env = do - dflags <- getDynFlags - liftIO $ finalSafeMode dflags tcg_env - --------------------------------------------------------------- --- Simplifiers --------------------------------------------------------------- - --- | Run Core2Core simplifier. The list of String is a list of (Core) plugin --- module names added via TH (cf 'addCorePlugin'). -hscSimplify :: HscEnv -> [String] -> ModGuts -> IO ModGuts -hscSimplify hsc_env plugins modguts = - runHsc hsc_env $ hscSimplify' plugins modguts - --- | Run Core2Core simplifier. The list of String is a list of (Core) plugin --- module names added via TH (cf 'addCorePlugin'). -hscSimplify' :: [String] -> ModGuts -> Hsc ModGuts -hscSimplify' plugins ds_result = do - hsc_env <- getHscEnv - hsc_env_with_plugins <- if null plugins -- fast path - then return hsc_env - else liftIO $ initializePlugins - $ hscUpdateFlags (\dflags -> foldr addPluginModuleName dflags plugins) - hsc_env - {-# SCC "Core2Core" #-} - liftIO $ core2core hsc_env_with_plugins ds_result - --------------------------------------------------------------- --- Interface generators --------------------------------------------------------------- - --- | Generate a stripped down interface file, e.g. for boot files or when ghci --- generates interface files. See Note [simpleTidyPgm - mkBootModDetailsTc] -hscSimpleIface :: HscEnv - -> Maybe CoreProgram - -> TcGblEnv - -> ModSummary - -> IO (ModIface, ModDetails) -hscSimpleIface hsc_env mb_core_program tc_result summary - = runHsc hsc_env $ hscSimpleIface' mb_core_program tc_result summary - -hscSimpleIface' :: Maybe CoreProgram - -> TcGblEnv - -> ModSummary - -> Hsc (ModIface, ModDetails) -hscSimpleIface' mb_core_program tc_result summary = do - hsc_env <- getHscEnv - logger <- getLogger - details <- liftIO $ mkBootModDetailsTc logger tc_result - safe_mode <- hscGetSafeMode tc_result - new_iface - <- {-# SCC "MkFinalIface" #-} - liftIO $ - mkIfaceTc hsc_env safe_mode details summary mb_core_program tc_result - -- And the answer is ... - liftIO $ dumpIfaceStats hsc_env - return (new_iface, details) - --------------------------------------------------------------- --- BackEnd combinators --------------------------------------------------------------- - --- | Compile to hard-code. -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, - 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 - } = 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. - - (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 )) - else - return (core_binds, local_ccs) - - - - ------------------- - -- 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 - - ----------------- Convert to STG ------------------ - (stg_binds, denv, (caf_ccs, caf_cc_stacks), stg_cg_infos) - <- {-# SCC "CoreToStg" #-} - withTiming logger - (text "CoreToStg"<+>brackets (ppr this_mod)) - (\(a, b, (c,d), tag_env) -> - a `seqList` - b `seq` - c `seqList` - d `seqList` - (seqEltsUFM (seqTagSig) tag_env)) - (myCoreToStg logger dflags (hsc_IC hsc_env) False this_mod location prepd_binds) - - let cost_centre_info = - (late_local_ccs ++ caf_ccs, caf_cc_stacks) - platform = targetPlatform dflags - prof_init - | sccProfilingEnabled dflags = profilingInitCode platform this_mod cost_centre_info - | otherwise = mempty - - ------------------ Code generation ------------------ - -- The back-end is streamed: each top-level function goes - -- from Stg all the way to asm before dealing with the next - -- top-level function, so withTiming isn't very useful here. - -- Hence we have one withTiming for the whole backend, the - -- next withTiming after this will be "Assembler" (hard code only). - withTiming logger (text "CodeGen"<+>brackets (ppr this_mod)) (const ()) - $ case backendCodeOutput (backend dflags) of - JSCodeOutput -> - do - let js_config = initStgToJSConfig dflags - cmm_cg_infos = Nothing - stub_c_exists = Nothing - foreign_fps = [] - - putDumpFileMaybe logger Opt_D_dump_stg_final "Final STG:" FormatSTG - (pprGenStgTopBindings (initStgPprOpts dflags) stg_binds) - - -- do the unfortunately effectual business - stgToJS logger js_config stg_binds this_mod spt_entries foreign_stubs0 cost_centre_info output_filename - return (output_filename, stub_c_exists, foreign_fps, Just stg_cg_infos, cmm_cg_infos) - - _ -> - do - cmms <- {-# SCC "StgToCmm" #-} - doCodeGen hsc_env this_mod denv data_tycons - cost_centre_info - stg_binds hpc_info - - ------------------ Code output ----------------------- - rawcmms0 <- {-# SCC "cmmToRawCmm" #-} - case cmmToRawCmmHook hooks of - Nothing -> cmmToRawCmm logger profile cmms - Just h -> h dflags (Just this_mod) cmms - - 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 - - let foreign_stubs st = foreign_stubs0 - `appendStubC` prof_init - `appendStubC` cgIPEStub st - - (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 - return ( output_filename, stub_c_exists, foreign_fps - , Just stg_cg_infos, Just cmm_cg_infos) - - --- The part of CgGuts that we need for HscInteractive -data CgInteractiveGuts = CgInteractiveGuts { cgi_module :: Module - , cgi_binds :: CoreProgram - , cgi_tycons :: [TyCon] - , cgi_foreign :: ForeignStubs - , 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 - -hscInteractive :: HscEnv - -> CgInteractiveGuts - -> ModLocation - -> IO (Maybe FilePath, CompiledByteCode, [SptEntry]) -hscInteractive hsc_env cgguts location = do - let dflags = hsc_dflags hsc_env - let logger = hsc_logger hsc_env - let tmpfs = hsc_tmpfs hsc_env - let CgInteractiveGuts{ -- This is the last use of the ModGuts in a compilation. - -- From now on, we just use the bits we need. - cgi_module = this_mod, - cgi_binds = core_binds, - cgi_tycons = tycons, - cgi_foreign = foreign_stubs, - 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 - - ------------------- - -- 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 - - -- The stg cg info only provides a runtime benfit, but is not requires so we just - -- omit it here - (stg_binds, _infotable_prov, _caf_ccs__caf_cc_stacks, _ignore_stg_cg_infos) - <- {-# SCC "CoreToStg" #-} - myCoreToStg logger dflags (hsc_IC hsc_env) True this_mod location prepd_binds - ----------------- Generate byte code ------------------ - comp_bc <- byteCodeGen hsc_env this_mod stg_binds data_tycons mod_breaks - ------------------ 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) - -generateByteCode :: HscEnv - -> CgInteractiveGuts - -> ModLocation - -> IO [Unlinked] -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) - -generateFreshByteCode :: HscEnv - -> ModuleName - -> CgInteractiveGuts - -> 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 ------------------------------- - -hscCompileCmmFile :: HscEnv -> FilePath -> FilePath -> FilePath -> IO (Maybe FilePath) -hscCompileCmmFile hsc_env original_filename filename output_filename = runHsc hsc_env $ do - let dflags = hsc_dflags hsc_env - logger = hsc_logger hsc_env - hooks = hsc_hooks hsc_env - tmpfs = hsc_tmpfs hsc_env - profile = targetProfile dflags - home_unit = hsc_home_unit hsc_env - platform = targetPlatform dflags - llvm_config = hsc_llvm_config hsc_env - cmm_config = initCmmConfig dflags - do_info_table = gopt Opt_InfoTableMap dflags - -- Make up a module name to give the NCG. We can't pass bottom here - -- lest we reproduce #11784. - mod_name = mkModuleName $ "Cmm$" ++ original_filename - cmm_mod = mkHomeModule home_unit mod_name - cmmpConfig = initCmmParserConfig dflags - (cmm, 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) - liftIO $ do - putDumpFileMaybe logger Opt_D_dump_cmm_verbose_by_proc "Parsed Cmm" FormatCMM (pdoc platform cmm) - - -- Compile decls in Cmm files one decl at a time, to avoid re-ordering - -- them in SRT analysis. - -- - -- 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 - - unless (null cmmgroup) $ - putDumpFileMaybe logger Opt_D_dump_cmm "Output Cmm" - FormatCMM (pdoc platform cmmgroup) - - rawCmms <- case cmmToRawCmmHook hooks of - Nothing -> cmmToRawCmm logger profile (Stream.yield cmmgroup) - Just h -> h dflags Nothing (Stream.yield cmmgroup) - - let foreign_stubs _ - | not $ null ipe_ents = - let ip_init = ipInitCode do_info_table platform cmm_mod - in NoStubs `appendStubC` ip_init - | 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 - 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"} - --------------------- Stuff for new code gen --------------------- - -{- -Note [Forcing of stg_binds] -~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The two last steps in the STG pipeline are: - -* Sorting the bindings in dependency order. -* Annotating them with free variables. - -We want to make sure we do not keep references to unannotated STG bindings -alive, nor references to bindings which have already been compiled to Cmm. - -We explicitly force the bindings to avoid this. - -This reduces residency towards the end of the CodeGen phase significantly -(5-10%). --} - -doCodeGen :: HscEnv -> Module -> InfoTableProvMap -> [TyCon] - -> CollectedCCs - -> [CgStgTopBinding] -- ^ Bindings come already annotated with fvs - -> HpcInfo - -> IO (Stream IO 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 - let dflags = hsc_dflags hsc_env - logger = hsc_logger hsc_env - hooks = hsc_hooks hsc_env - tmpfs = hsc_tmpfs hsc_env - platform = targetPlatform dflags - stg_ppr_opts = (initStgPprOpts dflags) - - 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 cmm_stream :: Stream IO CmmGroup ModuleLFInfos - -- 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 - - -- codegen consumes a stream of CmmGroup, and produces a new - -- stream of CmmGroup (not necessarily synchronised: one - -- CmmGroup on input may produce many CmmGroups on output due - -- to proc-point splitting). - - let dump1 a = do - unless (null a) $ - putDumpFileMaybe logger Opt_D_dump_cmm_from_stg - "Cmm produced by codegen" FormatCMM (pdoc platform a) - return a - - ppr_stream1 = Stream.mapM dump1 cmm_stream - - cmm_config = initCmmConfig dflags - - pipeline_stream :: Stream IO CmmGroupSRTs CmmCgInfos - pipeline_stream = do - ((mod_srt_info, ipes, ipe_stats), lf_infos) <- - {-# SCC "cmmPipeline" #-} - Stream.mapAccumL_ (pipeline_action logger cmm_config) (emptySRT this_mod, M.empty, mempty) ppr_stream1 - let nonCaffySet = srtMapNonCAFs (moduleSRTMap mod_srt_info) - generateCgIPEStub hsc_env this_mod denv (nonCaffySet, lf_infos, ipes, ipe_stats) - - pipeline_action - :: Logger - -> CmmConfig - -> (ModuleSRTInfo, Map CmmInfoTable (Maybe IpeSourceLocation), IPEStats) - -> CmmGroup - -> 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 - - -- 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 - else - return (ipes, stats) - - return ((mod_srt_info', ipes', stats'), cmm_srts) - - dump2 a = do - unless (null a) $ - putDumpFileMaybe logger Opt_D_dump_cmm "Output Cmm" FormatCMM (pdoc platform a) - return a - - return $ Stream.mapM dump2 pipeline_stream - -myCoreToStgExpr :: Logger -> DynFlags -> InteractiveContext - -> Bool - -> Module -> ModLocation -> CoreExpr - -> IO ( Id - , [CgStgTopBinding] - , InfoTableProvMap - , CollectedCCs - , StgCgInfos ) -myCoreToStgExpr logger dflags ictxt for_bytecode this_mod ml prepd_expr = do - {- Create a temporary binding (just because myCoreToStg needs a - binding for the stg2stg step) -} - let bco_tmp_id = mkSysLocal (fsLit "BCO_toplevel") - (mkPseudoUniqueE 0) - ManyTy - (exprType prepd_expr) - (stg_binds, prov_map, collected_ccs, stg_cg_infos) <- - myCoreToStg logger - dflags - ictxt - for_bytecode - this_mod - ml - [NonRec bco_tmp_id prepd_expr] - return (bco_tmp_id, stg_binds, prov_map, collected_ccs, stg_cg_infos) - -myCoreToStg :: Logger -> DynFlags -> InteractiveContext - -> Bool - -> Module -> ModLocation -> CoreProgram - -> IO ( [CgStgTopBinding] -- output program - , InfoTableProvMap - , CollectedCCs -- CAF cost centre info (declared and used) - , StgCgInfos ) -myCoreToStg logger dflags ictxt for_bytecode this_mod ml prepd_binds = do - let (stg_binds, denv, cost_centre_info) - = {-# SCC "Core2Stg" #-} - coreToStg (initCoreToStgOpts dflags) this_mod ml prepd_binds - - (stg_binds_with_fvs,stg_cg_info) - <- {-# SCC "Stg2Stg" #-} - stg2stg logger (interactiveInScope ictxt) (initStgPipelineOpts dflags for_bytecode) - this_mod stg_binds - - putDumpFileMaybe logger Opt_D_dump_stg_cg "CodeGenInput STG:" FormatSTG - (pprGenStgTopBindings (initStgPprOpts dflags) stg_binds_with_fvs) - - return (stg_binds_with_fvs, denv, cost_centre_info, stg_cg_info) - -{- ********************************************************************** -%* * -\subsection{Compiling a do-statement} -%* * -%********************************************************************* -} - -{- -When the UnlinkedBCOExpr is linked you get an HValue of type *IO [HValue]* When -you run it you get a list of HValues that should be the same length as the list -of names; add them to the ClosureEnv. - -A naked expression returns a singleton Name [it]. The stmt is lifted into the -IO monad as explained in Note [Interactively-bound Ids in GHCi] in GHC.Runtime.Context --} - --- | Compile a stmt all the way to an HValue, but don't run it --- --- We return Nothing to indicate an empty statement (or comment only), not a --- parse error. -hscStmt :: HscEnv -> String -> IO (Maybe ([Id], ForeignHValue, FixityEnv)) -hscStmt hsc_env stmt = hscStmtWithLocation hsc_env stmt "" 1 - --- | Compile a stmt all the way to an HValue, but don't run it --- --- We return Nothing to indicate an empty statement (or comment only), not a --- parse error. -hscStmtWithLocation :: HscEnv - -> String -- ^ The statement - -> String -- ^ The source - -> Int -- ^ Starting line - -> IO ( Maybe ([Id] - , ForeignHValue {- IO [HValue] -} - , FixityEnv)) -hscStmtWithLocation hsc_env0 stmt source linenumber = - runInteractiveHsc hsc_env0 $ do - maybe_stmt <- hscParseStmtWithLocation source linenumber stmt - case maybe_stmt of - Nothing -> return Nothing - - Just parsed_stmt -> do - hsc_env <- getHscEnv - liftIO $ hscParsedStmt hsc_env parsed_stmt - -hscParsedStmt :: HscEnv - -> GhciLStmt GhcPs -- ^ The parsed statement - -> IO ( Maybe ([Id] - , ForeignHValue {- IO [HValue] -} - , FixityEnv)) -hscParsedStmt hsc_env stmt = runInteractiveHsc hsc_env $ do - -- Rename and typecheck it - (ids, tc_expr, fix_env) <- ioMsgMaybe $ hoistTcRnMessage $ tcRnStmt hsc_env stmt - - -- Desugar it - ds_expr <- ioMsgMaybe $ hoistDsMessage $ deSugarExpr hsc_env tc_expr - liftIO (lintInteractiveExpr (text "desugar expression") hsc_env ds_expr) - handleWarnings - - -- Then code-gen, and link it - -- It's important NOT to have package 'interactive' as thisUnitId - -- for linking, else we try to link 'main' and can't find it. - -- Whereas the linker already knows to ignore 'interactive' - let src_span = srcLocSpan interactiveSrcLoc - (hval,_,_) <- liftIO $ hscCompileCoreExpr hsc_env src_span ds_expr - - 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 <- - runInteractiveHsc hsc_env $ - hscParseThingWithLocation source line_num parseModule str - return mod - -hscParseDeclsWithLocation :: HscEnv -> String -> Int -> String -> IO [LHsDecl GhcPs] -hscParseDeclsWithLocation hsc_env source line_num str = do - 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 - let interp = hscInterp hsc_env - - {- Rename and typecheck it -} - tc_gblenv <- ioMsgMaybe $ hoistTcRnMessage $ tcRnDeclsi hsc_env decls - - {- Grab the new instances -} - -- We grab the whole environment because of the overlapping that may have - -- been done. See the notes at the definition of InteractiveContext - -- (ic_instances) for more details. - let defaults = tcg_default tc_gblenv - - {- 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" } - ds_result <- hscDesugar' iNTERACTIVELoc tc_gblenv - - {- Simplify -} - simpl_mg <- liftIO $ do - plugins <- readIORef (tcg_th_coreplugins tc_gblenv) - hscSimplify hsc_env plugins ds_result - - {- Tidy -} - (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 - - !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, _infotable_prov, _caf_ccs__caf_cc_stacks, _stg_cg_info) - <- {-# SCC "CoreToStg" #-} - liftIO $ myCoreToStg (hsc_logger hsc_env) - (hsc_dflags hsc_env) - (hsc_IC hsc_env) - True - this_mod - iNTERACTIVELoc - prepd_binds - - {- Generate byte code -} - cbc <- liftIO $ byteCodeGen hsc_env this_mod - stg_binds data_tycons mod_breaks - - let src_span = srcLocSpan interactiveSrcLoc - _ <- liftIO $ loadDecls interp hsc_env src_span cbc - - {- Load static pointer table entries -} - liftIO $ hscAddSptEntries hsc_env (cg_spt_entries tidy_cg) - - let tcs = filterOut isImplicitTyCon (mg_tcs simpl_mg) - patsyns = mg_patsyns simpl_mg - - ext_ids = [ id | id <- bindersOfBinds core_binds - , isExternalName (idName id) - , not (isDFunId id || isImplicitId id) ] - -- We only need to keep around the external bindings - -- (as decided by GHC.Iface.Tidy), since those are the only ones - -- that might later be looked up by name. But we can exclude - -- - DFunIds, which are in 'cls_insts' (see Note [ic_tythings] in GHC.Runtime.Context - -- - Implicit Ids, which are implicit in tcs - -- c.f. GHC.Tc.Module.runTcInteractive, which reconstructs the TypeEnv - - new_tythings = map AnId ext_ids ++ map ATyCon tcs ++ map (AConLike . PatSynCon) patsyns - ictxt = hsc_IC hsc_env - -- See Note [Fixity declarations in GHCi] - fix_env = tcg_fix_env tc_gblenv - new_ictxt = extendInteractiveContext ictxt new_tythings cls_insts - fam_insts defaults fix_env - return (new_tythings, new_ictxt) - --- | Load the given static-pointer table entries into the interpreter. --- See Note [Grand plan for static forms] in "GHC.Iface.Tidy.StaticPtrTable". -hscAddSptEntries :: HscEnv -> [SptEntry] -> IO () -hscAddSptEntries hsc_env entries = do - let interp = hscInterp hsc_env - let add_spt_entry :: SptEntry -> IO () - add_spt_entry (SptEntry i fpr) = do - -- These are only names from the current module - (val, _, _) <- loadName interp hsc_env (idName i) - addSptEntry interp fpr val - mapM_ add_spt_entry entries - -{- - Note [Fixity declarations in GHCi] - ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - To support fixity declarations on types defined within GHCi (as requested - in #10018) we record the fixity environment in InteractiveContext. - When we want to evaluate something GHC.Tc.Module.runTcInteractive pulls out this - fixity environment and uses it to initialize the global typechecker environment. - After the typechecker has finished its business, an updated fixity environment - (reflecting whatever fixity declarations were present in the statements we - passed it) will be returned from hscParsedStmt. This is passed to - updateFixityEnv, which will stuff it back into InteractiveContext, to be - used in evaluating the next statement. - --} - -hscImport :: HscEnv -> String -> IO (ImportDecl GhcPs) -hscImport hsc_env str = runInteractiveHsc hsc_env $ do - -- Use >>= \case instead of MonadFail desugaring to take into - -- consideration `instance XXModule p = DataConCantHappen`. - -- Tracked in #15681 - hscParseThing parseModule str >>= \case - (L _ (HsModule{hsmodImports=is})) -> - case is of - [L _ i] -> return i - _ -> liftIO $ throwOneError $ - mkPlainErrorMsgEnvelope noSrcSpan $ - GhcPsMessage $ PsUnknownMessage $ - UnknownDiagnostic $ mkPlainError noHints $ - text "parse error in import declaration" - --- | Typecheck an expression (but don't run it) -hscTcExpr :: HscEnv - -> TcRnExprMode - -> String -- ^ The expression - -> IO Type -hscTcExpr hsc_env0 mode expr = runInteractiveHsc hsc_env0 $ do - hsc_env <- getHscEnv - parsed_expr <- hscParseExpr expr - ioMsgMaybe $ hoistTcRnMessage $ tcRnExpr hsc_env mode parsed_expr - --- | Find the kind of a type, after generalisation -hscKcType - :: HscEnv - -> Bool -- ^ Normalise the type - -> String -- ^ The type as a string - -> IO (Type, Kind) -- ^ Resulting type (possibly normalised) and kind -hscKcType hsc_env0 normalise str = runInteractiveHsc hsc_env0 $ do - hsc_env <- getHscEnv - ty <- hscParseType str - ioMsgMaybe $ hoistTcRnMessage $ tcRnType hsc_env DefaultFlexi normalise ty - -hscParseExpr :: String -> Hsc (LHsExpr GhcPs) -hscParseExpr expr = do - maybe_stmt <- hscParseStmt expr - case maybe_stmt of - Just (L _ (BodyStmt _ expr _ _)) -> return expr - _ -> throwOneError $ - mkPlainErrorMsgEnvelope noSrcSpan $ - GhcPsMessage $ PsUnknownMessage $ UnknownDiagnostic $ mkPlainError noHints $ - text "not an expression:" <+> quotes (text expr) - -hscParseStmt :: String -> Hsc (Maybe (GhciLStmt GhcPs)) -hscParseStmt = hscParseThing parseStmt - -hscParseStmtWithLocation :: String -> Int -> String - -> Hsc (Maybe (GhciLStmt GhcPs)) -hscParseStmtWithLocation source linenumber stmt = - hscParseThingWithLocation source linenumber parseStmt stmt - -hscParseType :: String -> Hsc (LHsType GhcPs) -hscParseType = hscParseThing parseType - -hscParseIdentifier :: HscEnv -> String -> IO (LocatedN RdrName) -hscParseIdentifier hsc_env str = - runInteractiveHsc hsc_env $ hscParseThing parseIdentifier str - -hscParseThing :: (Outputable thing, Data thing) - => Lexer.P thing -> String -> Hsc thing -hscParseThing = hscParseThingWithLocation "" 1 - -hscParseThingWithLocation :: (Outputable thing, Data thing) => String -> Int - -> Lexer.P thing -> String -> Hsc thing -hscParseThingWithLocation source linenumber parser str = do - dflags <- getDynFlags - logger <- getLogger - withTiming logger - (text "Parser [source]") - (const ()) $ {-# SCC "Parser" #-} do - - let buf = stringToStringBuffer str - loc = mkRealSrcLoc (fsLit source) linenumber 1 - - case unP parser (initParserState (initParserOpts dflags) buf loc) of - PFailed pst -> - handleWarningsThrowErrors (getPsMessages pst) - POk pst thing -> do - logWarningsReportErrors (getPsMessages pst) - liftIO $ putDumpFileMaybe logger Opt_D_dump_parsed "Parser" - FormatHaskell (ppr thing) - liftIO $ putDumpFileMaybe logger Opt_D_dump_parsed_ast "Parser AST" - FormatHaskell (showAstData NoBlankSrcSpan NoBlankEpAnnotations thing) - return thing - -hscTidy :: HscEnv -> ModGuts -> IO (CgGuts, ModDetails) -hscTidy hsc_env guts = do - let logger = hsc_logger hsc_env - let this_mod = mg_module guts - - opts <- initTidyOpts hsc_env - (cgguts, details) <- withTiming logger - (text "CoreTidy"<+>brackets (ppr this_mod)) - (const ()) - $! {-# SCC "CoreTidy" #-} tidyProgram opts guts - - -- post tidy pretty-printing and linting... - let tidy_rules = md_rules details - let all_tidy_binds = cg_binds cgguts - let name_ppr_ctx = mkNamePprCtx ptc (hsc_unit_env hsc_env) (mg_rdr_env guts) - ptc = initPromotionTickContext (hsc_dflags hsc_env) - - endPassHscEnvIO hsc_env name_ppr_ctx CoreTidy all_tidy_binds tidy_rules - - -- If the endPass didn't print the rules, but ddump-rules is - -- on, print now - unless (logHasDumpFlag logger Opt_D_dump_simpl) $ - putDumpFileMaybe logger Opt_D_dump_rules - "Tidy Core rules" - FormatText - (pprRulesForUser tidy_rules) - - -- Print one-line size info - let cs = coreBindsStats all_tidy_binds - putDumpFileMaybe logger Opt_D_dump_core_stats "Core Stats" - FormatText - (text "Tidy size (terms,types,coercions)" - <+> ppr (moduleName this_mod) <> colon - <+> int (cs_tm cs) - <+> int (cs_ty cs) - <+> int (cs_co cs)) - - pure (cgguts, details) - - -{- ********************************************************************** -%* * - Desugar, simplify, convert to bytecode, and link an expression -%* * -%********************************************************************* -} - -hscCompileCoreExpr :: HscEnv -> SrcSpan -> CoreExpr -> IO (ForeignHValue, [Linkable], PkgsLoaded) -hscCompileCoreExpr hsc_env loc expr = - case hscCompileCoreExprHook (hsc_hooks hsc_env) of - Nothing -> hscCompileCoreExpr' hsc_env loc expr - Just h -> h hsc_env loc expr - -hscCompileCoreExpr' :: HscEnv -> SrcSpan -> CoreExpr -> IO (ForeignHValue, [Linkable], PkgsLoaded) -hscCompileCoreExpr' hsc_env srcspan ds_expr - = do { {- Simplify it -} - -- Question: should we call SimpleOpt.simpleOptExpr here instead? - -- It is, well, simpler, and does less inlining etc. - let dflags = hsc_dflags hsc_env - ; let logger = hsc_logger hsc_env - ; let ic = hsc_IC hsc_env - ; let unit_env = hsc_unit_env hsc_env - ; let simplify_expr_opts = initSimplifyExprOpts dflags ic - ; simpl_expr <- simplifyExpr logger (ue_eps unit_env) simplify_expr_opts ds_expr - - {- Tidy it (temporary, until coreSat does cloning) -} - ; let tidy_expr = tidyExpr emptyTidyEnv simpl_expr - - {- Prepare for codegen -} - ; cp_cfg <- initCorePrepConfig hsc_env - ; prepd_expr <- corePrepExpr - logger cp_cfg - tidy_expr - - {- Lint if necessary -} - ; lintInteractiveExpr (text "hscCompileExpr") hsc_env prepd_expr - ; let iNTERACTIVELoc = 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 ictxt = hsc_IC hsc_env - ; (binding_id, stg_expr, _, _, _stg_cg_info) <- - myCoreToStgExpr logger - dflags - ictxt - True - (icInteractiveModule ictxt) - iNTERACTIVELoc - prepd_expr - - {- Convert to BCOs -} - ; bcos <- byteCodeGen hsc_env - (icInteractiveModule ictxt) - stg_expr - [] Nothing - - {- load it -} - ; (fv_hvs, mods_needed, units_needed) <- loadDecls (hscInterp hsc_env) hsc_env srcspan bcos - {- Get the HValue for the root -} - ; return (expectJust "hscCompileCoreExpr'" - $ lookup (idName binding_id) fv_hvs, mods_needed, units_needed) } - - -{- ********************************************************************** -%* * - Statistics on reading interfaces -%* * -%********************************************************************* -} - -dumpIfaceStats :: HscEnv -> IO () -dumpIfaceStats hsc_env = do - eps <- hscEPS hsc_env - let - logger = hsc_logger hsc_env - dump_rn_stats = logHasDumpFlag logger Opt_D_dump_rn_stats - dump_if_trace = logHasDumpFlag logger Opt_D_dump_if_trace - when (dump_if_trace || dump_rn_stats) $ - 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 +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NondecreasingIndentation #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiWayIf #-} + +{-# OPTIONS_GHC -fprof-auto-top #-} + +------------------------------------------------------------------------------- +-- +-- | Main API for compiling plain Haskell source code. +-- +-- This module implements compilation of a Haskell source. It is +-- /not/ concerned with preprocessing of source files; this is handled +-- in "GHC.Driver.Pipeline" +-- +-- There are various entry points depending on what mode we're in: +-- "batch" mode (@--make@), "one-shot" mode (@-c@, @-S@ etc.), and +-- "interactive" mode (GHCi). There are also entry points for +-- individual passes: parsing, typechecking/renaming, desugaring, and +-- simplification. +-- +-- All the functions here take an 'HscEnv' as a parameter, but none of +-- them return a new one: 'HscEnv' is treated as an immutable value +-- from here on in (although it has mutable components, for the +-- caches). +-- +-- We use the Hsc monad to deal with warning messages consistently: +-- specifically, while executing within an Hsc monad, warnings are +-- collected. When a Hsc monad returns to an IO monad, the +-- warnings are printed, or compilation aborts if the @-Werror@ +-- flag is enabled. +-- +-- (c) The GRASP/AQUA Project, Glasgow University, 1993-2000 +-- +------------------------------------------------------------------------------- + +module GHC.Driver.Main + ( + -- * Making an HscEnv + newHscEnv + , newHscEnvWithHUG + , initHscEnv + + -- * Compiling complete source files + , Messager, batchMsg, batchMultiMsg + , HscBackendAction (..), HscRecompStatus (..) + , initModDetails + , initWholeCoreBindings + , loadIfaceByteCode + , loadIfaceByteCodeLazy + , hscMaybeWriteIface + , hscCompileCmmFile + + , hscGenHardCode + , hscInteractive + , mkCgInteractiveGuts + , CgInteractiveGuts + , generateByteCode + , generateFreshByteCode + + -- * Running passes separately + , hscRecompStatus + , hscParse + , hscTypecheckRename + , hscTypecheckRenameWithDiagnostics + , hscTypecheckAndGetWarnings + , hscDesugar + , makeSimpleDetails + , hscSimplify -- ToDo, shouldn't really export this + , hscDesugarAndSimplify + + -- * Safe Haskell + , hscCheckSafe + , hscGetSafe + + -- * Support for interactive evaluation + , hscParseIdentifier + , hscTcRcLookupName + , hscTcRnGetInfo + , hscIsGHCiMonad + , hscGetModuleInterface + , hscRnImportDecls + , hscTcRnLookupRdrName + , hscStmt, hscParseStmtWithLocation, hscStmtWithLocation, hscParsedStmt + , hscParseDeclsWithLocation, hscParsedDecls + , hscParseModuleWithLocation + , hscTcExpr, TcRnExprMode(..), hscImport, hscKcType + , hscParseExpr + , hscParseType + , hscCompileCoreExpr + , hscTidy + + + -- * Low-level exports for hooks + , hscCompileCoreExpr' + -- We want to make sure that we export enough to be able to redefine + -- hsc_typecheck in client code + , hscParse', hscSimplify', hscDesugar', tcRnModule', doCodeGen + , getHscEnv + , hscSimpleIface' + , oneShotMsg + , dumpIfaceStats + , ioMsgMaybe + , showModuleIndex + , hscAddSptEntries + , writeInterfaceOnlyMode + , loadByteCode + , genModDetails + ) where + +import GHC.Prelude + +import GHC.Platform + +import GHC.Driver.Plugins +import GHC.Driver.Session +import GHC.Driver.Backend +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) +import GHC.Driver.Config.Core.Opt.Simplify ( initSimplifyExprOpts ) +import GHC.Driver.Config.Core.Lint ( endPassHscEnvIO ) +import GHC.Driver.Config.Core.Lint.Interactive ( lintInteractiveExpr ) +import GHC.Driver.Config.CoreToStg +import GHC.Driver.Config.CoreToStg.Prep +import GHC.Driver.Config.Logger (initLogFlags) +import GHC.Driver.Config.Parser (initParserOpts) +import GHC.Driver.Config.Stg.Ppr (initStgPprOpts) +import GHC.Driver.Config.Stg.Pipeline (initStgPipelineOpts) +import GHC.Driver.Config.StgToCmm (initStgToCmmConfig) +import GHC.Driver.Config.Cmm (initCmmConfig) +import GHC.Driver.LlvmConfigCache (initLlvmConfigCache) +import GHC.Driver.Config.StgToJS (initStgToJSConfig) +import GHC.Driver.Config.Diagnostic +import GHC.Driver.Config.Tidy +import GHC.Driver.Hooks +import GHC.Driver.GenerateCgIPEStub (generateCgIPEStub, lookupEstimatedTicks) + +import GHC.Runtime.Context +import GHC.Runtime.Interpreter +import GHC.Runtime.Interpreter.JS +import GHC.Runtime.Loader ( initializePlugins ) +import GHCi.RemoteTypes +import GHC.ByteCode.Types + +import GHC.Linker.Loader +import GHC.Linker.Types +import GHC.Linker.Deps + +import GHC.Hs +import GHC.Hs.Dump +import GHC.Hs.Stats ( ppSourceStats ) + +import GHC.HsToCore + +import GHC.StgToByteCode ( byteCodeGen ) +import GHC.StgToJS ( stgToJS ) +import GHC.StgToJS.Ids +import GHC.StgToJS.Types +import GHC.JS.Syntax + +import GHC.IfaceToCore ( typecheckIface, typecheckWholeCoreBindings ) + +import GHC.Iface.Load ( ifaceStats, writeIface, flagsToIfCompression, getGhcPrimIface ) +import GHC.Iface.Make +import GHC.Iface.Recomp +import GHC.Iface.Tidy +import GHC.Iface.Ext.Ast ( mkHieFile ) +import GHC.Iface.Ext.Types ( getAsts, hie_asts, hie_module ) +import GHC.Iface.Ext.Binary ( readHieFile, writeHieFile , hie_file_result) +import GHC.Iface.Ext.Debug ( diffFile, validateScopes ) + +import GHC.Core +import GHC.Core.Lint.Interactive ( interactiveInScope ) +import GHC.Core.Tidy ( tidyExpr ) +import GHC.Core.Utils ( exprType ) +import GHC.Core.ConLike +import GHC.Core.Opt.Pipeline +import GHC.Core.Opt.Pipeline.Types ( CoreToDo (..)) +import GHC.Core.TyCon +import GHC.Core.InstEnv +import GHC.Core.FamInstEnv +import GHC.Core.Rules +import GHC.Core.Stats +import GHC.Core.LateCC +import GHC.Core.LateCC.Types + + +import GHC.CoreToStg.Prep( CorePrepPgmConfig, corePrepPgm, corePrepExpr ) +import GHC.CoreToStg.AddImplicitBinds( addImplicitBinds ) +import GHC.CoreToStg ( coreToStg ) + +import GHC.Parser.Errors.Types +import GHC.Parser +import GHC.Parser.Lexer as Lexer + +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.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.Module.ModDetails +import GHC.Unit.Module.ModGuts +import GHC.Unit.Module.ModIface +import GHC.Unit.Module.ModSummary +import GHC.Unit.Module.Graph +import GHC.Unit.Module.Imported +import GHC.Unit.Module.Deps +import GHC.Unit.Module.Status +import GHC.Unit.Home.ModInfo + +import GHC.Types.Id +import GHC.Types.SourceError +import GHC.Types.SafeHaskell +import GHC.Types.ForeignStubs +import GHC.Types.Name.Env ( mkNameEnv ) +import GHC.Types.Var.Env ( mkEmptyTidyEnv ) +import GHC.Types.Var.Set +import GHC.Types.Error +import GHC.Types.Fixity.Env +import GHC.Types.CostCentre +import GHC.Types.IPE +import GHC.Types.SourceFile +import GHC.Types.SrcLoc +import GHC.Types.Name +import GHC.Types.Name.Cache ( newNameCache ) +import GHC.Types.Name.Reader +import GHC.Types.Name.Ppr +import GHC.Types.TyThing +import GHC.Types.Unique.Supply (uniqFromTag) +import GHC.Types.Unique.Set + +import GHC.Utils.Fingerprint ( Fingerprint ) +import GHC.Utils.Panic +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.Maybe + +import GHC.SysTools (initSysTools) +import GHC.SysTools.BaseDir (findTopDir) + +import Data.Data hiding (Fixity, TyCon) +import Data.Functor ((<&>)) +import Data.List ( nub, isPrefixOf, partition ) +import qualified Data.List.NonEmpty as NE +import Control.Monad +import Data.IORef +import System.FilePath as FilePath +import System.Directory +import qualified Data.Map as M +import Data.Map (Map) +import qualified Data.Set as S +import Data.Set (Set) +import Control.DeepSeq (force) +import Data.List.NonEmpty (NonEmpty ((:|))) +import GHC.Unit.Module.WholeCoreBindings +import GHC.Types.TypeEnv +import System.IO +import {-# SOURCE #-} GHC.Driver.Pipeline +import Data.Time + +import System.IO.Unsafe ( unsafeInterleaveIO ) +import GHC.Iface.Env ( trace_if ) +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 + +{- ********************************************************************** +%* * + Initialisation +%* * +%********************************************************************* -} + +newHscEnv :: FilePath -> DynFlags -> IO HscEnv +newHscEnv top_dir dflags = do + hpt <- emptyHomePackageTable + newHscEnvWithHUG top_dir dflags (homeUnitId_ dflags) (home_unit_graph hpt) + where + home_unit_graph hpt = HUG.unitEnv_singleton + (homeUnitId_ dflags) + (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 <- newNameCache + fc_var <- initFinderCache + logger <- initLogger + tmpfs <- initTmpFs + 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_IC = emptyInteractiveContext dflags + , hsc_NC = nc_var + , hsc_FC = fc_var + , hsc_type_env_vars = emptyKnotVars + , hsc_interp = Nothing + , hsc_unit_env = unit_env + , hsc_plugins = emptyPlugins + , hsc_hooks = emptyHooks + , hsc_tmpfs = tmpfs + , hsc_llvm_config = llvm_config + } + +-- | Initialize HscEnv from an optional top_dir path +initHscEnv :: Maybe FilePath -> IO HscEnv +initHscEnv mb_top_dir = do + top_dir <- findTopDir mb_top_dir + mySettings <- initSysTools top_dir + dflags <- initDynFlags (defaultDynFlags mySettings) + hsc_env <- newHscEnv top_dir dflags + setUnsafeGlobalDynFlags dflags + -- c.f. DynFlags.parseDynamicFlagsFull, which + -- creates DynFlags and sets the UnsafeGlobalDynFlags + return hsc_env + +-- ----------------------------------------------------------------------------- + +getDiagnostics :: Hsc (Messages GhcMessage) +getDiagnostics = Hsc $ \_ w -> return (w, w) + +clearDiagnostics :: Hsc () +clearDiagnostics = Hsc $ \_ _ -> return ((), emptyMessages) + +logDiagnostics :: Messages GhcMessage -> Hsc () +logDiagnostics w = Hsc $ \_ w0 -> return ((), w0 `unionMessages` w) + +getHscEnv :: Hsc HscEnv +getHscEnv = Hsc $ \e w -> return (e, w) + +handleWarnings :: Hsc () +handleWarnings = do + diag_opts <- initDiagOpts <$> getDynFlags + print_config <- initPrintConfig <$> getDynFlags + logger <- getLogger + w <- getDiagnostics + liftIO $ printOrThrowDiagnostics logger print_config diag_opts w + clearDiagnostics + +-- | log warning in the monad, and if there are errors then +-- throw a SourceError exception. +logWarningsReportErrors :: (Messages PsWarning, Messages PsError) -> Hsc () +logWarningsReportErrors (warnings,errors) = do + logDiagnostics (GhcPsMessage <$> warnings) + when (not $ isEmptyMessages errors) $ throwErrors (GhcPsMessage <$> errors) + +-- | Log warnings and throw errors, assuming the messages +-- contain at least one error (e.g. coming from PFailed) +handleWarningsThrowErrors :: (Messages PsWarning, Messages PsError) -> Hsc a +handleWarningsThrowErrors (warnings, errors) = do + diag_opts <- initDiagOpts <$> getDynFlags + logDiagnostics (GhcPsMessage <$> warnings) + logger <- getLogger + let (wWarns, wErrs) = partitionMessages warnings + liftIO $ printMessages logger NoDiagnosticOpts diag_opts wWarns + throwErrors $ fmap GhcPsMessage $ errors `unionMessages` wErrs + +-- | Deal with errors and warnings returned by a compilation step +-- +-- In order to reduce dependencies to other parts of the compiler, functions +-- outside the "main" parts of GHC return warnings and errors as a parameter +-- and signal success via by wrapping the result in a 'Maybe' type. This +-- function logs the returned warnings and propagates errors as exceptions +-- (of type 'SourceError'). +-- +-- This function assumes the following invariants: +-- +-- 1. If the second result indicates success (is of the form 'Just x'), +-- there must be no error messages in the first result. +-- +-- 2. If there are no error messages, but the second result indicates failure +-- there should be warnings in the first result. That is, if the action +-- failed, it must have been due to the warnings (i.e., @-Werror@). +ioMsgMaybe :: IO (Messages GhcMessage, Maybe a) -> Hsc a +ioMsgMaybe ioA = do + (msgs, mb_r) <- liftIO ioA + let (warns, errs) = partitionMessages msgs + logDiagnostics warns + case mb_r of + Nothing -> throwErrors errs + Just r -> assert (isEmptyMessages errs ) return r + +-- | like ioMsgMaybe, except that we ignore error messages and return +-- 'Nothing' instead. +ioMsgMaybe' :: IO (Messages GhcMessage, Maybe a) -> Hsc (Maybe a) +ioMsgMaybe' ioA = do + (msgs, mb_r) <- liftIO $ ioA + logDiagnostics (mkMessages $ getWarningMessages msgs) + return mb_r + +-- ----------------------------------------------------------------------------- +-- | Lookup things in the compiler's environment + +hscTcRnLookupRdrName :: HscEnv -> LocatedN RdrName -> IO (NonEmpty Name) +hscTcRnLookupRdrName hsc_env0 rdr_name + = runInteractiveHsc hsc_env0 $ + do { hsc_env <- getHscEnv + -- tcRnLookupRdrName can return empty list only together with TcRnUnknownMessage. + -- Once errors has been dealt with in hoistTcRnMessage, we can enforce + -- this invariant in types by converting to NonEmpty. + ; ioMsgMaybe $ fmap (fmap (>>= NE.nonEmpty)) $ hoistTcRnMessage $ + tcRnLookupRdrName hsc_env rdr_name } + +hscTcRcLookupName :: HscEnv -> Name -> IO (Maybe TyThing) +hscTcRcLookupName hsc_env0 name = runInteractiveHsc hsc_env0 $ do + hsc_env <- getHscEnv + ioMsgMaybe' $ hoistTcRnMessage $ tcRnLookupName hsc_env name + -- ignore errors: the only error we're likely to get is + -- "name not found", and the Maybe in the return type + -- is used to indicate that. + +hscTcRnGetInfo :: HscEnv -> Name + -> IO (Maybe (TyThing, Fixity, [ClsInst], [FamInst], SDoc)) +hscTcRnGetInfo hsc_env0 name + = runInteractiveHsc hsc_env0 $ + do { hsc_env <- getHscEnv + ; ioMsgMaybe' $ hoistTcRnMessage $ tcRnGetInfo hsc_env name } + +hscIsGHCiMonad :: HscEnv -> String -> IO Name +hscIsGHCiMonad hsc_env name + = runHsc hsc_env $ ioMsgMaybe $ hoistTcRnMessage $ isGHCiMonad hsc_env name + +hscGetModuleInterface :: HscEnv -> Module -> IO ModIface +hscGetModuleInterface hsc_env0 mod = runInteractiveHsc hsc_env0 $ do + hsc_env <- getHscEnv + ioMsgMaybe $ hoistTcRnMessage $ getModuleInterface hsc_env mod + +-- ----------------------------------------------------------------------------- +-- | Rename some import declarations +hscRnImportDecls :: HscEnv -> [LImportDecl GhcPs] -> IO GlobalRdrEnv +hscRnImportDecls hsc_env0 import_decls = runInteractiveHsc hsc_env0 $ do + hsc_env <- getHscEnv + ioMsgMaybe $ hoistTcRnMessage $ tcRnImportDecls hsc_env import_decls + +-- ----------------------------------------------------------------------------- +-- | parse a file, returning the abstract syntax + +hscParse :: HscEnv -> ModSummary -> IO HsParsedModule +hscParse hsc_env mod_summary = runHsc hsc_env $ hscParse' mod_summary + +-- internal version, that doesn't fail due to -Werror +hscParse' :: ModSummary -> Hsc HsParsedModule +hscParse' mod_summary + | Just r <- ms_parsed_mod mod_summary = return r + | otherwise = do + dflags <- getDynFlags + logger <- getLogger + {-# SCC "Parser" #-} withTiming logger + (text "Parser"<+>brackets (ppr $ ms_mod mod_summary)) + (const ()) $ do + let src_filename = ms_hspp_file mod_summary + maybe_src_buf = ms_hspp_buf mod_summary + + -------------------------- Parser ---------------- + -- sometimes we already have the buffer in memory, perhaps + -- because we needed to parse the imports out of it, or get the + -- module name. + buf <- case maybe_src_buf of + Just b -> return b + Nothing -> liftIO $ hGetStringBuffer src_filename + + let loc = mkRealSrcLoc (mkFastString src_filename) 1 1 + + let diag_opts = initDiagOpts dflags + when (wopt Opt_WarnUnicodeBidirectionalFormatCharacters dflags) $ do + case checkBidirectionFormatChars (PsLoc loc (BufPos 0)) buf of + Nothing -> pure () + Just chars@((eloc,chr,_) :| _) -> + let span = mkSrcSpanPs $ mkPsSpan eloc (advancePsLoc eloc chr) + in logDiagnostics $ singleMessage $ + mkPlainMsgEnvelope diag_opts span $ + GhcPsMessage $ PsWarnBidirectionalFormatChars chars + + let parseMod | HsigFile == ms_hsc_src mod_summary + = parseSignature + | otherwise = parseModule + + case unP parseMod (initParserState (initParserOpts dflags) buf loc) of + PFailed pst -> + handleWarningsThrowErrors (getPsMessages pst) + POk pst rdr_module -> do + liftIO $ putDumpFileMaybe logger Opt_D_dump_parsed "Parser" + FormatHaskell (ppr rdr_module) + liftIO $ putDumpFileMaybe logger Opt_D_dump_parsed_ast "Parser AST" + FormatHaskell (showAstData NoBlankSrcSpan + NoBlankEpAnnotations + rdr_module) + liftIO $ putDumpFileMaybe logger Opt_D_source_stats "Source Statistics" + FormatText (ppSourceStats False rdr_module) + + -- To get the list of extra source files, we take the list + -- that the parser gave us, + -- - eliminate files beginning with '<'. gcc likes to use + -- pseudo-filenames like "" and "" + -- - normalise them (eliminate differences between ./f and f) + -- - filter out the preprocessed source file + -- - filter out anything beginning with tmpdir + -- - remove duplicates + -- - filter out the .hs/.lhs source filename if we have one + -- + let n_hspp = FilePath.normalise src_filename + TempDir tmp_dir = tmpDir dflags + srcs0 = nub $ filter (not . (tmp_dir `isPrefixOf`)) + $ filter (not . (== n_hspp)) + $ map FilePath.normalise + $ filter (not . isPrefixOf "<") + $ map unpackFS + $ srcfiles pst + srcs1 = case ml_hs_file (ms_location mod_summary) of + Just f -> filter (/= FilePath.normalise f) srcs0 + Nothing -> srcs0 + + -- sometimes we see source files from earlier + -- preprocessing stages that cannot be found, so just + -- filter them out: + srcs2 <- liftIO $ filterM doesFileExist srcs1 + + let res = HsParsedModule { + hpm_module = rdr_module, + hpm_src_files = srcs2 + } + + -- apply parse transformation of plugins + let applyPluginAction p opts + = parsedResultAction p opts mod_summary + hsc_env <- getHscEnv + (ParsedResult transformed (PsMessages warns errs)) <- + withPlugins (hsc_plugins hsc_env) applyPluginAction + (ParsedResult res (uncurry PsMessages $ getPsMessages pst)) + + logDiagnostics (GhcPsMessage <$> warns) + unless (isEmptyMessages errs) $ throwErrors (GhcPsMessage <$> errs) + + return transformed + +checkBidirectionFormatChars :: PsLoc -> StringBuffer -> Maybe (NonEmpty (PsLoc, Char, String)) +checkBidirectionFormatChars start_loc sb + | containsBidirectionalFormatChar sb = Just $ go start_loc sb + | otherwise = Nothing + where + go :: PsLoc -> StringBuffer -> NonEmpty (PsLoc, Char, String) + go loc sb + | atEnd sb = panic "checkBidirectionFormatChars: no char found" + | otherwise = case nextChar sb of + (chr, sb) + | Just desc <- lookup chr bidirectionalFormatChars -> + (loc, chr, desc) :| go1 (advancePsLoc loc chr) sb + | otherwise -> go (advancePsLoc loc chr) sb + + go1 :: PsLoc -> StringBuffer -> [(PsLoc, Char, String)] + go1 loc sb + | atEnd sb = [] + | otherwise = case nextChar sb of + (chr, sb) + | Just desc <- lookup chr bidirectionalFormatChars -> + (loc, chr, desc) : go1 (advancePsLoc loc chr) sb + | otherwise -> go1 (advancePsLoc loc chr) sb + + +-- ----------------------------------------------------------------------------- +-- | If the renamed source has been kept, extract it. Dump it if requested. + + +extract_renamed_stuff :: ModSummary -> TcGblEnv -> Hsc RenamedStuff +extract_renamed_stuff mod_summary tc_result = do + let rn_info = getRenamedStuff tc_result + + dflags <- getDynFlags + logger <- getLogger + liftIO $ putDumpFileMaybe logger Opt_D_dump_rn_ast "Renamer" + FormatHaskell (showAstData NoBlankSrcSpan NoBlankEpAnnotations rn_info) + + -- Create HIE files + when (gopt Opt_WriteHie dflags) $ do + -- I assume this fromJust is safe because `-fwrite-hie-file` + -- enables the option which keeps the renamed source. + hieFile <- mkHieFile mod_summary tc_result (fromJust rn_info) + let out_file = ml_hie_file $ ms_location mod_summary + liftIO $ writeHieFile out_file hieFile + liftIO $ putDumpFileMaybe logger Opt_D_dump_hie "HIE AST" FormatHaskell (ppr $ hie_asts hieFile) + + -- Validate HIE files + when (gopt Opt_ValidateHie dflags) $ do + hs_env <- getHscEnv + liftIO $ do + -- Validate Scopes + case validateScopes (hie_module hieFile) $ getAsts $ hie_asts hieFile of + [] -> putMsg logger $ text "Got valid scopes" + xs -> do + putMsg logger $ text "Got invalid scopes" + mapM_ (putMsg logger) xs + -- Roundtrip testing + file' <- readHieFile (hsc_NC hs_env) out_file + case diffFile hieFile (hie_file_result file') of + [] -> + putMsg logger $ text "Got no roundtrip errors" + xs -> do + putMsg logger $ text "Got roundtrip errors" + let logger' = updateLogFlags logger (log_set_dopt Opt_D_ppr_debug) + mapM_ (putMsg logger') xs + return rn_info + + +-- ----------------------------------------------------------------------------- +-- | Rename and typecheck a module, additionally returning the renamed syntax +hscTypecheckRename :: HscEnv -> ModSummary -> HsParsedModule + -> IO (TcGblEnv, RenamedStuff) +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 +hscTypecheckAndGetWarnings :: HscEnv -> ModSummary -> IO (FrontendResult, WarningMessages) +hscTypecheckAndGetWarnings hsc_env summary = runHsc' hsc_env $ do + case hscFrontendHook (hsc_hooks hsc_env) of + Nothing -> FrontendTypecheck . fst <$> hsc_typecheck False summary Nothing + Just h -> h summary + +-- | A bunch of logic piled around @tcRnModule'@, concerning a) backpack +-- b) concerning dumping rename info and hie files. It would be nice to further +-- separate this stuff out, probably in conjunction better separating renaming +-- and type checking (#17781). +hsc_typecheck :: Bool -- ^ Keep renamed source? + -> ModSummary -> Maybe HsParsedModule + -> Hsc (TcGblEnv, RenamedStuff) +hsc_typecheck keep_rn mod_summary mb_rdr_module = do + hsc_env <- getHscEnv + let hsc_src = ms_hsc_src mod_summary + dflags = hsc_dflags hsc_env + home_unit = hsc_home_unit hsc_env + outer_mod = ms_mod mod_summary + mod_name = moduleName outer_mod + outer_mod' = mkHomeModule home_unit mod_name + inner_mod = homeModuleNameInstantiation home_unit mod_name + src_filename = ms_hspp_file mod_summary + real_loc = realSrcLocSpan $ mkRealSrcLoc (mkFastString src_filename) 1 1 + keep_rn' = gopt Opt_WriteHie dflags || keep_rn + massert (isHomeModule home_unit outer_mod) + tc_result <- if hsc_src == HsigFile && not (isHoleModule inner_mod) + then ioMsgMaybe $ hoistTcRnMessage $ tcRnInstantiateSignature hsc_env outer_mod' real_loc + else + do hpm <- case mb_rdr_module of + Just hpm -> return hpm + Nothing -> hscParse' mod_summary + tc_result0 <- tcRnModule' mod_summary keep_rn' hpm + if hsc_src == HsigFile + then do (iface, _) <- liftIO $ hscSimpleIface hsc_env Nothing tc_result0 mod_summary + ioMsgMaybe $ hoistTcRnMessage $ + tcRnMergeSignatures hsc_env hpm tc_result0 iface + else return tc_result0 + -- TODO are we extracting anything when we merely instantiate a signature? + -- If not, try to move this into the "else" case above. + rn_info <- extract_renamed_stuff mod_summary tc_result + return (tc_result, rn_info) + +-- wrapper around tcRnModule to handle safe haskell extras +tcRnModule' :: ModSummary -> Bool -> HsParsedModule + -> Hsc TcGblEnv +tcRnModule' sum save_rn_syntax mod = do + hsc_env <- getHscEnv + dflags <- getDynFlags + + let diag_opts = initDiagOpts dflags + -- -Wmissing-safe-haskell-mode + when (not (safeHaskellModeEnabled dflags) + && wopt Opt_WarnMissingSafeHaskellMode dflags) $ + logDiagnostics $ singleMessage $ + mkPlainMsgEnvelope diag_opts (getLoc (hpm_module mod)) $ + GhcDriverMessage $ DriverMissingSafeHaskellMode (ms_mod sum) + + tcg_res <- {-# SCC "Typecheck-Rename" #-} + ioMsgMaybe $ hoistTcRnMessage $ + tcRnModule hsc_env sum + save_rn_syntax mod + + -- See Note [Safe Haskell Overlapping Instances Implementation] + -- although this is used for more than just that failure case. + tcSafeOK <- liftIO $ readIORef (tcg_safe_infer tcg_res) + whyUnsafe <- liftIO $ readIORef (tcg_safe_infer_reasons tcg_res) + let allSafeOK = safeInferred dflags && tcSafeOK + + -- end of the safe haskell line, how to respond to user? + if not (safeHaskellOn dflags) + || (safeInferOn dflags && not allSafeOK) + -- if safe Haskell off or safe infer failed, mark unsafe + then markUnsafeInfer tcg_res whyUnsafe + + -- module (could be) safe, throw warning if needed + else do + tcg_res' <- hscCheckSafeImports tcg_res + safe <- liftIO $ readIORef (tcg_safe_infer tcg_res') + when safe $ + case wopt Opt_WarnSafe dflags of + True + | safeHaskell dflags == Sf_Safe -> return () + | otherwise -> (logDiagnostics $ singleMessage $ + mkPlainMsgEnvelope diag_opts (warnSafeOnLoc dflags) $ + GhcDriverMessage $ DriverInferredSafeModule (tcg_mod tcg_res')) + False | safeHaskell dflags == Sf_Trustworthy && + wopt Opt_WarnTrustworthySafe dflags -> + (logDiagnostics $ singleMessage $ + mkPlainMsgEnvelope diag_opts (trustworthyOnLoc dflags) $ + GhcDriverMessage $ DriverMarkedTrustworthyButInferredSafe (tcg_mod tcg_res')) + False -> return () + return tcg_res' + +-- | Convert a typechecked module to Core +hscDesugar :: HscEnv -> ModSummary -> TcGblEnv -> IO ModGuts +hscDesugar hsc_env mod_summary tc_result = + runHsc hsc_env $ hscDesugar' (ms_location mod_summary) tc_result + +hscDesugar' :: ModLocation -> TcGblEnv -> Hsc ModGuts +hscDesugar' mod_location tc_result = do + hsc_env <- getHscEnv + ioMsgMaybe $ hoistDsMessage $ + {-# SCC "deSugar" #-} + deSugar hsc_env mod_location tc_result + +-- | Make a 'ModDetails' from the results of typechecking. Used when +-- typechecking only, as opposed to full compilation. +makeSimpleDetails :: Logger -> TcGblEnv -> IO ModDetails +makeSimpleDetails logger tc_result = mkBootModDetailsTc logger tc_result + + +{- ********************************************************************** +%* * + The main compiler pipeline +%* * +%********************************************************************* -} + +{- + -------------------------------- + The compilation proper + -------------------------------- + +It's the task of the compilation proper to compile Haskell, hs-boot and core +files to either byte-code, hard-code (C, asm, LLVM, etc.) or to nothing at all +(the module is still parsed and type-checked. This feature is mostly used by +IDE's and the likes). Compilation can happen in either 'one-shot', 'batch', +'nothing', or 'interactive' mode. 'One-shot' mode targets hard-code, 'batch' +mode targets hard-code, 'nothing' mode targets nothing and 'interactive' mode +targets byte-code. + +The modes are kept separate because of their different types and meanings: + + * In 'one-shot' mode, we're only compiling a single file and can therefore + discard the new ModIface and ModDetails. This is also the reason it only + targets hard-code; compiling to byte-code or nothing doesn't make sense when + we discard the result. + + * 'Batch' mode is like 'one-shot' except that we keep the resulting ModIface + and ModDetails. 'Batch' mode doesn't target byte-code since that require us to + return the newly compiled byte-code. + + * 'Nothing' mode has exactly the same type as 'batch' mode but they're still + kept separate. This is because compiling to nothing is fairly special: We + don't output any interface files, we don't run the simplifier and we don't + generate any code. + + * 'Interactive' mode is similar to 'batch' mode except that we return the + compiled byte-code together with the ModIface and ModDetails. + +Trying to compile a hs-boot file to byte-code will result in a run-time error. +This is the only thing that isn't caught by the type-system. +-} + + + +-- | 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 +-- recompile a module or not! +hscRecompStatus :: Maybe Messager + -> HscEnv + -> ModSummary + -> Maybe ModIface + -> HomeModLinkable + -> (Int,Int) + -> IO HscRecompStatus +hscRecompStatus + mHscMessage hsc_env mod_summary mb_old_iface old_linkable mod_index + = do + let + msg what = case mHscMessage of + 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 + -- source file. + -- + -- Save the interface that comes back from checkOldIface. + -- In one-shot mode we don't have the old iface until this + -- point, when checkOldIface reads it from the disk. + recomp_if_result + <- {-# SCC "checkOldIface" #-} + liftIO $ checkOldIface hsc_env mod_summary mb_old_iface + case recomp_if_result of + OutOfDateItem reason mb_checked_iface -> do + msg $ NeedsRecompile reason + 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 + -- No need for a linkable, we're good to go + msg UpToDate + return $ HscUpToDate checked_iface emptyHomeModInfoLinkable + | not (backendGeneratesCodeForHsBoot (backend lcl_dflags)) + , IsBoot <- isBootSummary mod_summary -> do + msg UpToDate + return $ HscUpToDate checked_iface emptyHomeModInfoLinkable + + -- Always recompile with the JS backend when TH is enabled until + -- #23013 is fixed. + | ArchJavaScript <- platformArch (targetPlatform lcl_dflags) + , xopt LangExt.TemplateHaskell lcl_dflags + -> do + msg $ needsRecompileBecause THWithJS + return $ HscRecompNeeded $ Just $ mi_iface_hash $ checked_iface + + | otherwise -> do + -- Do need linkable + -- 1. Just check whether we have bytecode/object linkables and then + -- we will decide if we need them or not. + bc_linkable <- checkByteCode checked_iface mod_summary (homeMod_bytecode old_linkable) + obj_linkable <- liftIO $ checkObjects lcl_dflags (homeMod_object old_linkable) mod_summary + trace_if (hsc_logger hsc_env) (vcat [text "BCO linkable", nest 2 (ppr bc_linkable), text "Object Linkable", ppr obj_linkable]) + + let just_bc = justBytecode <$> bc_linkable + just_o = justObjects <$> obj_linkable + _maybe_both_os = case (bc_linkable, obj_linkable) of + (UpToDateItem bc, UpToDateItem o) -> UpToDateItem (bytecodeAndObjects bc o) + -- If missing object code, just say we need to recompile because of object code. + (_, OutOfDateItem reason _) -> OutOfDateItem reason Nothing + -- If just missing byte code, just use the object code + -- so you should use -fprefer-byte-code with -fwrite-if-simplified-core or you'll + -- end up using bytecode on recompilation + (_, UpToDateItem {} ) -> just_o + + definitely_both_os = case (bc_linkable, obj_linkable) of + (UpToDateItem bc, UpToDateItem o) -> UpToDateItem (bytecodeAndObjects bc o) + -- If missing object code, just say we need to recompile because of object code. + (_, OutOfDateItem reason _) -> OutOfDateItem reason Nothing + -- If just missing byte code, just use the object code + -- so you should use -fprefer-byte-code with -fwrite-if-simplified-core or you'll + -- end up using bytecode on recompilation + (OutOfDateItem reason _, _ ) -> OutOfDateItem reason Nothing + +-- pprTraceM "recomp" (ppr just_bc <+> ppr just_o) + -- 2. Decide which of the products we will need + let recomp_linkable_result = case () of + _ | backendCanReuseLoadedCode (backend lcl_dflags) -> + case bc_linkable of + -- If bytecode is available for Interactive then don't load object code + UpToDateItem _ -> just_bc + _ -> case obj_linkable of + -- If o is availabe, then just use that + UpToDateItem _ -> just_o + _ -> outOfDateItemBecause MissingBytecode Nothing + -- Need object files for making object files + | backendWritesFiles (backend lcl_dflags) -> + if gopt Opt_ByteCodeAndObjectCode lcl_dflags + -- We say we are going to write both, so recompile unless we have both + then definitely_both_os + -- Only load the object file unless we are saying we need to produce both. + -- Unless we do this then you can end up using byte-code for a module you specify -fobject-code for. + else just_o + | otherwise -> pprPanic "hscRecompStatus" (text $ show $ backend lcl_dflags) + case recomp_linkable_result of + UpToDateItem linkable -> do + msg $ UpToDate + return $ HscUpToDate checked_iface $ linkable + OutOfDateItem reason _ -> do + msg $ NeedsRecompile reason + return $ HscRecompNeeded $ Just $ mi_iface_hash $ checked_iface + +-- | Check that the .o files produced by compilation are already up-to-date +-- or not. +checkObjects :: DynFlags -> Maybe Linkable -> ModSummary -> IO (MaybeValidated Linkable) +checkObjects dflags mb_old_linkable summary = do + let + dt_enabled = gopt Opt_BuildDynamicToo dflags + this_mod = ms_mod summary + mb_obj_date = ms_obj_date summary + mb_dyn_obj_date = ms_dyn_obj_date summary + mb_if_date = ms_iface_date summary + obj_fn = ml_obj_file (ms_location summary) + -- dynamic-too *also* produces the dyn_o_file, so have to check + -- that's there, and if it's not, regenerate both .o and + -- .dyn_o + checkDynamicObj k = if dt_enabled + then case (>=) <$> mb_dyn_obj_date <*> mb_if_date of + Just True -> k + _ -> return $ outOfDateItemBecause MissingDynObjectFile Nothing + -- Not in dynamic-too mode + else k + + checkDynamicObj $ + case (,) <$> mb_obj_date <*> mb_if_date of + Just (obj_date, if_date) + | obj_date >= if_date -> + case mb_old_linkable of + Just old_linkable + | linkableIsNativeCodeOnly old_linkable, linkableTime old_linkable == obj_date + -> return $ UpToDateItem old_linkable + _ -> UpToDateItem <$> findObjectLinkable this_mod obj_fn obj_date + _ -> return $ outOfDateItemBecause MissingObjectFile Nothing + +-- | Check to see if we can reuse the old linkable, by this point we will +-- have just checked that the old interface matches up with the source hash, so +-- no need to check that again here +checkByteCode :: ModIface -> ModSummary -> Maybe Linkable -> IO (MaybeValidated Linkable) +checkByteCode iface mod_sum mb_old_linkable = + case mb_old_linkable of + Just old_linkable + | not (linkableIsNativeCodeOnly old_linkable) + -> return $ (UpToDateItem old_linkable) + _ -> loadByteCode iface mod_sum + +loadByteCode :: ModIface -> ModSummary -> IO (MaybeValidated Linkable) +loadByteCode iface mod_sum = do + let + this_mod = ms_mod mod_sum + if_date = fromJust $ ms_iface_date mod_sum + 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 + 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 + +-- | 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 + 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] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +An interface file consists of two parts + +* The `ModIface` which ends up getting written to disk. + The `ModIface` is a completely acyclic tree, which can be serialised + and de-serialised completely straightforwardly. The `ModIface` is + also the structure that is finger-printed for recompilation control. + +* The `ModDetails` which provides a more structured view that is suitable + for usage during compilation. The `ModDetails` is heavily cyclic: + An `Id` contains a `Type`, which mentions a `TyCon` that contains kind + that mentions other `TyCons`; the `Id` also includes an unfolding that + in turn mentions more `Id`s; And so on. + +The `ModIface` can be created from the `ModDetails` and the `ModDetails` from +a `ModIface`. + +During tidying, just before interfaces are written to disk, +the ModDetails is calculated and then converted into a ModIface (see GHC.Iface.Make.mkIface_). +Then when GHC needs to restart typechecking from a certain point it can read the +interface file, and regenerate the ModDetails from the ModIface (see GHC.IfaceToCore.typecheckIface). +The key part about the loading is that the ModDetails is regenerated lazily +from the ModIface, so that there's only a detailed in-memory representation +for declarations which are actually used from the interface. This mode is +also used when reading interface files from external packages. + +In the old --make mode implementation, the interface was written after compiling a module +but the in-memory ModDetails which was used to compute the ModIface was retained. +The result was that --make mode used much more memory than `-c` mode, because a large amount of +information about a module would be kept in the ModDetails but never used. + +The new idea is that even in `--make` mode, when there is an in-memory `ModDetails` +at hand, we re-create the `ModDetails` from the `ModIface`. Doing this means that +we only have to keep the `ModIface` decls in memory and then lazily load +detailed representations if needed. It turns out this makes a really big difference +to memory usage, halving maximum memory used in some cases. + +See !5492 and #13586 +-} + +-- Runs the post-typechecking frontend (desugar and simplify). We want to +-- generate most of the interface as late as possible. This gets us up-to-date +-- and good unfoldings and other info in the interface file. +-- +-- We might create a interface right away, in which case we also return the +-- updated HomeModInfo. But we might also need to run the backend first. In the +-- later case Status will be HscRecomp and we return a function from ModIface -> +-- HomeModInfo. +-- +-- HscRecomp in turn will carry the information required to compute a interface +-- when passed the result of the code generator. So all this can and is done at +-- the call site of the backend code gen if it is run. +hscDesugarAndSimplify :: ModSummary + -> FrontendResult + -> Messages GhcMessage + -> Maybe Fingerprint + -> Hsc HscBackendAction +hscDesugarAndSimplify summary (FrontendTypecheck tc_result) tc_warnings mb_old_hash = do + hsc_env <- getHscEnv + dflags <- getDynFlags + logger <- getLogger + let bcknd = backend dflags + hsc_src = ms_hsc_src summary + diag_opts = initDiagOpts dflags + print_config = initPrintConfig dflags + + -- Desugar, if appropriate + -- + -- We usually desugar even when we are not generating code, otherwise we + -- would miss errors thrown by the desugaring (see #10600). The only + -- 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 + liftIO $ printOrThrowDiagnostics logger print_config diag_opts (unionMessages tc_warnings w) + clearDiagnostics + + -- Simplify, if appropriate, and (whether we simplified or not) generate an + -- interface file. + case mb_desugar of + -- Just cause we desugared doesn't mean we are generating code, see above. + Just desugared_guts | backendGeneratesCode bcknd -> do + plugins <- liftIO $ readIORef (tcg_th_coreplugins tc_result) + simplified_guts <- hscSimplify' plugins desugared_guts + + (cg_guts, details) <- + liftIO $ hscTidy hsc_env simplified_guts + + !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. + 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, + hscs_partial_iface = partial_iface, + hscs_old_iface_hash = mb_old_hash + } + + Just desugared_guts | gopt Opt_WriteIfSimplifiedCore dflags -> do + -- If -fno-code is enabled (hence we fall through to this case) + -- Running the simplifier once is necessary before doing byte code generation + -- in order to inline data con wrappers but we honour whatever level of simplificication the + -- user requested. See #22008 for some discussion. + plugins <- liftIO $ readIORef (tcg_th_coreplugins tc_result) + simplified_guts <- hscSimplify' plugins desugared_guts + (cg_guts, _) <- + liftIO $ hscTidy hsc_env simplified_guts + + (iface, _details) <- liftIO $ + hscSimpleIface hsc_env (Just $ cg_binds cg_guts) tc_result summary + + liftIO $ hscMaybeWriteIface logger dflags True iface mb_old_hash (ms_location summary) + + -- 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 + -- and generate a simple interface. + _ -> do + (iface, _details) <- liftIO $ + hscSimpleIface hsc_env Nothing tc_result summary + + liftIO $ hscMaybeWriteIface logger dflags True iface mb_old_hash (ms_location summary) + + -- 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] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We write one interface file per module and per compilation, except with +-dynamic-too where we write two interface files (non-dynamic and dynamic). + +We can write two kinds of interfaces (see Note [Interface file stages] in +"GHC.Driver.Types"): + + * simple interface: interface generated after the core pipeline + + * full interface: simple interface completed with information from the + backend + +Depending on the situation, we write one or the other (using +`hscMaybeWriteIface`). We must be careful with `-dynamic-too` because only the +backend is run twice, so if we write a simple interface we need to write both +the non-dynamic and the dynamic interfaces at the same time (with the same +contents). + +Cases for which we generate simple interfaces: + + * GHC.Driver.Main.hscDesugarAndSimplify: when a compilation does NOT require (re)compilation + of the hard code + + * GHC.Driver.Pipeline.compileOne': when we run in One Shot mode and target + bytecode (if interface writing is forced). + + * GHC.Driver.Backpack uses simple interfaces for indefinite units + (units with module holes). It writes them indirectly by forcing the + -fwrite-interface flag while setting backend to NoBackend. + +Cases for which we generate full interfaces: + + * GHC.Driver.Pipeline.runPhase: when we must be compiling to regular hard + code and/or require recompilation. + +By default interface file names are derived from module file names by adding +suffixes. The interface file name can be overloaded with "-ohi", except when +`-dynamic-too` is used. + +-} + +-- | Write interface files +hscMaybeWriteIface + :: Logger + -> DynFlags + -> Bool + -- ^ Is this a simple interface generated after the core pipeline, or one + -- with information from the backend? See: Note [Writing interface files] + -> ModIface + -> Maybe Fingerprint + -- ^ The old interface hash, used to decide if we need to actually write the + -- new interface. + -> ModLocation + -> IO () +hscMaybeWriteIface logger dflags is_simple iface old_iface mod_location = do + let force_write_interface = gopt Opt_WriteInterface dflags + write_interface = backendWritesFiles (backend dflags) + + write_iface dflags' iface = + let !iface_name = if dynamicNow dflags' then ml_dyn_hi_file mod_location else ml_hi_file mod_location + profile = targetProfile dflags' + in + {-# SCC "writeIface" #-} + withTiming logger + (text "WriteIface"<+>brackets (text iface_name)) + (const ()) + (writeIface logger profile (flagsToIfCompression dflags) iface_name iface) + + if (write_interface || force_write_interface) then do + + -- FIXME: with -dynamic-too, "change" is only meaningful for the + -- non-dynamic interface, not for the dynamic one. We should have another + -- flag for the dynamic interface. In the meantime: + -- + -- * when we write a single full interface, we check if we are + -- currently writing the dynamic interface due to -dynamic-too, in + -- which case we ignore "change". + -- + -- * when we write two simple interfaces at once because of + -- dynamic-too, we use "change" both for the non-dynamic and the + -- dynamic interfaces. Hopefully both the dynamic and the non-dynamic + -- interfaces stay in sync... + -- + let change = old_iface /= Just (mi_iface_hash iface) + + let dt = dynamicTooState dflags + + when (logHasDumpFlag logger Opt_D_dump_if_trace) $ putMsg logger $ + hang (text "Writing interface(s):") 2 $ vcat + [ text "Kind:" <+> if is_simple then text "simple" else text "full" + , text "Hash change:" <+> ppr change + , text "DynamicToo state:" <+> text (show dt) + ] + + if is_simple + then when change $ do -- FIXME: see 'change' comment above + write_iface dflags iface + case dt of + DT_Dont -> return () + DT_Dyn -> panic "Unexpected DT_Dyn state when writing simple interface" + DT_OK -> write_iface (setDynamicNow dflags) iface + else case dt of + DT_Dont | change -> write_iface dflags iface + DT_OK | change -> write_iface dflags iface + -- FIXME: see change' comment above + DT_Dyn -> write_iface dflags iface + _ -> return () + + when (gopt Opt_WriteHie dflags) $ do + -- This is slightly hacky. A hie file is considered to be up to date + -- if its modification time on disk is greater than or equal to that + -- of the .hi file (since we should always write a .hi file if we are + -- writing a .hie file). However, with the way this code is + -- structured at the moment, the .hie file is often written before + -- the .hi file; by touching the file here, we ensure that it is + -- correctly considered up-to-date. + -- + -- The file should exist by the time we get here, but we check for + -- existence just in case, so that we don't accidentally create empty + -- .hie files. + let hie_file = ml_hie_file mod_location + whenM (doesFileExist hie_file) $ + GHC.Utils.Touch.touch hie_file + else + -- See Note [Strictness in ModIface] + forceModIface iface + +-------------------------------------------------------------- +-- NoRecomp handlers +-------------------------------------------------------------- + + +-- | genModDetails is used to initialise 'ModDetails' at the end of compilation. +-- This has two main effects: +-- 1. Increases memory usage by unloading a lot of the TypeEnv +-- 2. Globalising certain parts (DFunIds) in the TypeEnv (which used to be achieved using UpdateIdInfos) +-- For the second part to work, it's critical that we use 'initIfaceLoadModule' here rather than +-- 'initIfaceCheck' as 'initIfaceLoadModule' removes the module from the KnotVars, otherwise name lookups +-- succeed by hitting the old TypeEnv, which missing out the critical globalisation step for DFuns. + +-- After the DFunIds are globalised, it's critical to overwrite the old TypeEnv with the new +-- more compact and more correct version. This reduces memory usage whilst compiling the rest of +-- the module loop. +genModDetails :: HscEnv -> ModIface -> IO ModDetails +genModDetails hsc_env old_iface + = do + -- CRITICAL: To use initIfaceLoadModule as that removes the current module from the KnotVars and + -- hence properly globalises DFunIds. + new_details <- {-# SCC "tcRnIface" #-} + initIfaceLoadModule hsc_env (mi_module old_iface) (typecheckIface old_iface) + case lookupKnotVars (hsc_type_env_vars hsc_env) (mi_module old_iface) of + Nothing -> return () + Just te_var -> writeIORef te_var (md_types new_details) + dumpIfaceStats hsc_env + return new_details + + +-------------------------------------------------------------- +-- Safe Haskell +-------------------------------------------------------------- + +-- Note [Safe Haskell Trust Check] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- Safe Haskell checks that an import is trusted according to the following +-- rules for an import of module M that resides in Package P: +-- +-- * If M is recorded as Safe and all its trust dependencies are OK +-- then M is considered safe. +-- * If M is recorded as Trustworthy and P is considered trusted and +-- all M's trust dependencies are OK then M is considered safe. +-- +-- By trust dependencies we mean that the check is transitive. So if +-- a module M that is Safe relies on a module N that is trustworthy, +-- importing module M will first check (according to the second case) +-- that N is trusted before checking M is trusted. +-- +-- This is a minimal description, so please refer to the user guide +-- for more details. The user guide is also considered the authoritative +-- source in this matter, not the comments or code. + + +-- Note [Safe Haskell Inference] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- Safe Haskell does Safe inference on modules that don't have any specific +-- safe haskell mode flag. The basic approach to this is: +-- * When deciding if we need to do a Safe language check, treat +-- an unmarked module as having -XSafe mode specified. +-- * For checks, don't throw errors but return them to the caller. +-- * Caller checks if there are errors: +-- * For modules explicitly marked -XSafe, we throw the errors. +-- * For unmarked modules (inference mode), we drop the errors +-- and mark the module as being Unsafe. +-- +-- It used to be that we only did safe inference on modules that had no Safe +-- Haskell flags, but now we perform safe inference on all modules as we want +-- to allow users to set the `-Wsafe`, `-Wunsafe` and +-- `-Wtrustworthy-safe` flags on Trustworthy and Unsafe modules so that a +-- user can ensure their assumptions are correct and see reasons for why a +-- module is safe or unsafe. +-- +-- This is tricky as we must be careful when we should throw an error compared +-- to just warnings. For checking safe imports we manage it as two steps. First +-- we check any imports that are required to be safe, then we check all other +-- imports to see if we can infer them to be safe. + + +-- | Check that the safe imports of the module being compiled are valid. +-- If not we either issue a compilation error if the module is explicitly +-- using Safe Haskell, or mark the module as unsafe if we're in safe +-- inference mode. +hscCheckSafeImports :: TcGblEnv -> Hsc TcGblEnv +hscCheckSafeImports tcg_env = do + dflags <- getDynFlags + tcg_env' <- checkSafeImports tcg_env + checkRULES dflags tcg_env' + + where + checkRULES dflags tcg_env' = + let diag_opts = initDiagOpts dflags + in case safeLanguageOn dflags of + True -> do + -- XSafe: we nuke user written RULES + logDiagnostics $ fmap GhcDriverMessage $ warns diag_opts (tcg_rules tcg_env') + return tcg_env' { tcg_rules = [] } + False + -- SafeInferred: user defined RULES, so not safe + | safeInferOn dflags && not (null $ tcg_rules tcg_env') + -> markUnsafeInfer tcg_env' $ warns diag_opts (tcg_rules tcg_env') + + -- Trustworthy OR SafeInferred: with no RULES + | otherwise + -> return tcg_env' + + warns diag_opts rules = mkMessages $ listToBag $ map (warnRules diag_opts) rules + + warnRules :: DiagOpts -> LRuleDecl GhcTc -> MsgEnvelope DriverMessage + warnRules diag_opts (L loc rule) = + mkPlainMsgEnvelope diag_opts (locA loc) $ DriverUserDefinedRuleIgnored rule + +-- | Validate that safe imported modules are actually safe. For modules in the +-- HomePackage (the package the module we are compiling in resides) this just +-- involves checking its trust type is 'Safe' or 'Trustworthy'. For modules +-- that reside in another package we also must check that the external package +-- is trusted. See the Note [Safe Haskell Trust Check] above for more +-- information. +-- +-- The code for this is quite tricky as the whole algorithm is done in a few +-- distinct phases in different parts of the code base. See +-- 'GHC.Rename.Names.rnImportDecl' for where package trust dependencies for a +-- module are collected and unioned. Specifically see the Note [Tracking Trust +-- Transitively] in "GHC.Rename.Names" and the Note [Trust Own Package] in +-- "GHC.Rename.Names". +checkSafeImports :: TcGblEnv -> Hsc TcGblEnv +checkSafeImports tcg_env + = do + dflags <- getDynFlags + imps <- mapM condense imports' + let (safeImps, regImps) = partition (\(_,_,s) -> s) imps + + -- We want to use the warning state specifically for detecting if safe + -- inference has failed, so store and clear any existing warnings. + oldErrs <- getDiagnostics + clearDiagnostics + + -- Check safe imports are correct + safePkgs <- S.fromList <$> mapMaybeM checkSafe safeImps + safeErrs <- getDiagnostics + clearDiagnostics + + -- Check non-safe imports are correct if inferring safety + -- See the Note [Safe Haskell Inference] + (infErrs, infPkgs) <- case (safeInferOn dflags) of + False -> return (emptyMessages, S.empty) + True -> do infPkgs <- S.fromList <$> mapMaybeM checkSafe regImps + infErrs <- getDiagnostics + clearDiagnostics + return (infErrs, infPkgs) + + -- restore old errors + logDiagnostics oldErrs + + diag_opts <- initDiagOpts <$> getDynFlags + print_config <- initPrintConfig <$> getDynFlags + logger <- getLogger + + -- Will throw if failed safe check + liftIO $ printOrThrowDiagnostics logger print_config diag_opts safeErrs + + -- No fatal warnings or errors: passed safe check + let infPassed = isEmptyMessages infErrs + tcg_env' <- case (not infPassed) of + True -> markUnsafeInfer tcg_env infErrs + False -> return tcg_env + when (packageTrustOn dflags) $ checkPkgTrust pkgReqs + let newTrust = pkgTrustReqs dflags safePkgs infPkgs infPassed + return tcg_env' { tcg_imports = impInfo `plusImportAvails` newTrust } + + where + impInfo = tcg_imports tcg_env -- ImportAvails + imports = imp_mods impInfo -- ImportedMods + imports1 = M.toList imports -- (Module, [ImportedBy]) + imports' = map (fmap importedByUser) imports1 -- (Module, [ImportedModsVal]) + pkgReqs = imp_trust_pkgs impInfo -- [Unit] + + condense :: (Module, [ImportedModsVal]) -> Hsc (Module, SrcSpan, IsSafeImport) + condense (_, []) = panic "GHC.Driver.Main.condense: Pattern match failure!" + condense (m, x:xs) = do imv <- foldlM cond' x xs + return (m, imv_span imv, imv_is_safe imv) + + -- ImportedModsVal = (ModuleName, Bool, SrcSpan, IsSafeImport) + cond' :: ImportedModsVal -> ImportedModsVal -> Hsc ImportedModsVal + cond' v1 v2 + | imv_is_safe v1 /= imv_is_safe v2 + = throwOneError $ + mkPlainErrorMsgEnvelope (imv_span v1) $ + GhcDriverMessage $ DriverMixedSafetyImport (imv_name v1) + | otherwise + = return v1 + + -- easier interface to work with + checkSafe :: (Module, SrcSpan, a) -> Hsc (Maybe UnitId) + checkSafe (m, l, _) = fst `fmap` hscCheckSafe' m l + + -- what pkg's to add to our trust requirements + pkgTrustReqs :: DynFlags -> Set UnitId -> Set UnitId -> + Bool -> ImportAvails + pkgTrustReqs dflags req inf infPassed | safeInferOn dflags + && not (safeHaskellModeEnabled dflags) && infPassed + = emptyImportAvails { + imp_trust_pkgs = req `S.union` inf + } + pkgTrustReqs dflags _ _ _ | safeHaskell dflags == Sf_Unsafe + = emptyImportAvails + pkgTrustReqs _ req _ _ = emptyImportAvails { imp_trust_pkgs = req } + +-- | Check that a module is safe to import. +-- +-- We return True to indicate the import is safe and False otherwise +-- although in the False case an exception may be thrown first. +hscCheckSafe :: HscEnv -> Module -> SrcSpan -> IO Bool +hscCheckSafe hsc_env m l = runHsc hsc_env $ do + dflags <- getDynFlags + pkgs <- snd `fmap` hscCheckSafe' m l + when (packageTrustOn dflags) $ checkPkgTrust pkgs + errs <- getDiagnostics + return $ isEmptyMessages errs + +-- | Return if a module is trusted and the pkgs it depends on to be trusted. +hscGetSafe :: HscEnv -> Module -> SrcSpan -> IO (Bool, Set UnitId) +hscGetSafe hsc_env m l = runHsc hsc_env $ do + (self, pkgs) <- hscCheckSafe' m l + good <- isEmptyMessages `fmap` getDiagnostics + clearDiagnostics -- don't want them printed... + let pkgs' | Just p <- self = S.insert p pkgs + | otherwise = pkgs + return (good, pkgs') + +-- | Is a module trusted? If not, throw or log errors depending on the type. +-- Return (regardless of trusted or not) if the trust type requires the modules +-- own package be trusted and a list of other packages required to be trusted +-- (these later ones haven't been checked) but the own package trust has been. +hscCheckSafe' :: Module -> SrcSpan + -> Hsc (Maybe UnitId, Set UnitId) +hscCheckSafe' m l = do + hsc_env <- getHscEnv + let home_unit = hsc_home_unit hsc_env + (tw, pkgs) <- isModSafe home_unit m l + case tw of + False -> return (Nothing, pkgs) + True | isHomeModule home_unit m -> return (Nothing, pkgs) + -- TODO: do we also have to check the trust of the instantiation? + -- Not necessary if that is reflected in dependencies + | otherwise -> return (Just $ toUnitId (moduleUnit m), pkgs) + where + isModSafe :: HomeUnit -> Module -> SrcSpan -> Hsc (Bool, Set UnitId) + isModSafe home_unit m l = do + hsc_env <- getHscEnv + dflags <- getDynFlags + iface <- lookup' m + let diag_opts = initDiagOpts dflags + case iface of + -- can't load iface to check trust! + Nothing -> throwOneError $ + mkPlainErrorMsgEnvelope l $ + GhcDriverMessage $ DriverCannotLoadInterfaceFile m + + -- got iface, check trust + Just iface' -> + let trust = getSafeMode $ mi_trust iface' + trust_own_pkg = mi_trust_pkg iface' + -- check module is trusted + safeM = trust `elem` [Sf_Safe, Sf_SafeInferred, Sf_Trustworthy] + -- check package is trusted + safeP = packageTrusted dflags (hsc_units hsc_env) home_unit trust trust_own_pkg m + -- pkg trust reqs + pkgRs = dep_trusted_pkgs $ mi_deps iface' + -- warn if Safe module imports Safe-Inferred module. + warns = if wopt Opt_WarnInferredSafeImports dflags + && safeLanguageOn dflags + && trust == Sf_SafeInferred + then inferredImportWarn diag_opts + else emptyMessages + -- General errors we throw but Safe errors we log + errs = case (safeM, safeP) of + (True, True ) -> emptyMessages + (True, False) -> pkgTrustErr + (False, _ ) -> modTrustErr + in do + logDiagnostics warns + logDiagnostics errs + return (trust == Sf_Trustworthy, pkgRs) + + where + state = hsc_units hsc_env + inferredImportWarn diag_opts = singleMessage + $ mkMsgEnvelope diag_opts l (pkgQual state) + $ GhcDriverMessage $ DriverInferredSafeImport m + pkgTrustErr = singleMessage + $ mkErrorMsgEnvelope l (pkgQual state) + $ GhcDriverMessage $ DriverCannotImportFromUntrustedPackage state m + modTrustErr = singleMessage + $ mkErrorMsgEnvelope l (pkgQual state) + $ GhcDriverMessage $ DriverCannotImportUnsafeModule m + + -- Check the package a module resides in is trusted. Safe compiled + -- modules are trusted without requiring that their package is trusted. For + -- trustworthy modules, modules in the home package are trusted but + -- otherwise we check the package trust flag. + packageTrusted :: DynFlags -> UnitState -> HomeUnit -> SafeHaskellMode -> Bool -> Module -> Bool + packageTrusted dflags unit_state home_unit safe_mode trust_own_pkg mod = + case safe_mode of + Sf_None -> False -- shouldn't hit these cases + Sf_Ignore -> False -- shouldn't hit these cases + Sf_Unsafe -> False -- prefer for completeness. + _ | not (packageTrustOn dflags) -> True + Sf_Safe | not trust_own_pkg -> True + Sf_SafeInferred | not trust_own_pkg -> True + _ | isHomeModule home_unit mod -> True + _ -> unitIsTrusted $ unsafeLookupUnit unit_state (moduleUnit m) + + lookup' :: Module -> Hsc (Maybe ModIface) + lookup' m = do + hsc_env <- getHscEnv + 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 + case iface of + Just _ -> return iface + Nothing -> snd `fmap` (liftIO $ getModuleInterface hsc_env m) + + +-- | Check the list of packages are trusted. +checkPkgTrust :: Set UnitId -> Hsc () +checkPkgTrust pkgs = do + hsc_env <- getHscEnv + let errors = S.foldr go emptyBag pkgs + state = hsc_units hsc_env + go pkg acc + | unitIsTrusted $ unsafeLookupUnitId state pkg + = acc + | otherwise + = (`consBag` acc) + $ mkErrorMsgEnvelope noSrcSpan (pkgQual state) + $ GhcDriverMessage + $ DriverPackageNotTrusted state pkg + if isEmptyBag errors + then return () + else liftIO $ throwErrors $ mkMessages errors + +-- | Set module to unsafe and (potentially) wipe trust information. +-- +-- Make sure to call this method to set a module to inferred unsafe, it should +-- be a central and single failure method. We only wipe the trust information +-- when we aren't in a specific Safe Haskell mode. +-- +-- While we only use this for recording that a module was inferred unsafe, we +-- may call it on modules using Trustworthy or Unsafe flags so as to allow +-- warning flags for safety to function correctly. See Note [Safe Haskell +-- Inference]. +markUnsafeInfer :: forall e . Diagnostic e => TcGblEnv -> Messages e -> Hsc TcGblEnv +markUnsafeInfer tcg_env whyUnsafe = do + dflags <- getDynFlags + + let reason = WarningWithFlag Opt_WarnUnsafe + let diag_opts = initDiagOpts dflags + when (diag_wopt Opt_WarnUnsafe diag_opts) + (logDiagnostics $ singleMessage $ + mkPlainMsgEnvelope diag_opts (warnUnsafeOnLoc dflags) $ + GhcDriverMessage $ DriverUnknownMessage $ + mkSimpleUnknownDiagnostic $ + mkPlainDiagnostic reason noHints $ + whyUnsafe' dflags) + + liftIO $ writeIORef (tcg_safe_infer tcg_env) False + liftIO $ writeIORef (tcg_safe_infer_reasons tcg_env) emptyMessages + -- NOTE: Only wipe trust when not in an explicitly safe haskell mode. Other + -- times inference may be on but we are in Trustworthy mode -- so we want + -- to record safe-inference failed but not wipe the trust dependencies. + case not (safeHaskellModeEnabled dflags) of + True -> return $ tcg_env { tcg_imports = wiped_trust } + False -> return tcg_env + + where + wiped_trust = (tcg_imports tcg_env) { imp_trust_pkgs = S.empty } + pprMod = ppr $ moduleName $ tcg_mod tcg_env + whyUnsafe' df = vcat [ quotes pprMod <+> text "has been inferred as unsafe!" + , text "Reason:" + , nest 4 $ (vcat $ badFlags df) $+$ + -- MP: Using defaultDiagnosticOpts here is not right but it's also not right to handle these + -- unsafety error messages in an unstructured manner. + (vcat $ pprMsgEnvelopeBagWithLoc (defaultDiagnosticOpts @e) (getMessages whyUnsafe)) $+$ + (vcat $ badInsts $ tcg_insts tcg_env) + ] + badFlags df = concatMap (badFlag df) unsafeFlagsForInfer + badFlag df (ext,loc,on,_) + | on df = [mkLocMessage MCOutput (loc df) $ + text "-X" <> ppr ext <+> text "is not allowed in Safe Haskell"] + | otherwise = [] + badInsts insts = concatMap badInst insts + + checkOverlap (NoOverlap _) = False + checkOverlap _ = True + + badInst ins | checkOverlap (overlapMode (is_flag ins)) + = [mkLocMessage MCOutput (nameSrcSpan $ getName $ is_dfun ins) $ + ppr (overlapMode $ is_flag ins) <+> + text "overlap mode isn't allowed in Safe Haskell"] + | otherwise = [] + +-- | Figure out the final correct safe haskell mode +hscGetSafeMode :: TcGblEnv -> Hsc SafeHaskellMode +hscGetSafeMode tcg_env = do + dflags <- getDynFlags + liftIO $ finalSafeMode dflags tcg_env + +-------------------------------------------------------------- +-- Simplifiers +-------------------------------------------------------------- + +-- | Run Core2Core simplifier. The list of String is a list of (Core) plugin +-- module names added via TH (cf 'addCorePlugin'). +hscSimplify :: HscEnv -> [String] -> ModGuts -> IO ModGuts +hscSimplify hsc_env plugins modguts = + runHsc hsc_env $ hscSimplify' plugins modguts + +-- | Run Core2Core simplifier. The list of String is a list of (Core) plugin +-- module names added via TH (cf 'addCorePlugin'). +hscSimplify' :: [String] -> ModGuts -> Hsc ModGuts +hscSimplify' plugins ds_result = do + hsc_env <- getHscEnv + hsc_env_with_plugins <- if null plugins -- fast path + then return hsc_env + else liftIO $ initializePlugins + $ hscUpdateFlags (\dflags -> foldr addPluginModuleName dflags plugins) + hsc_env + {-# SCC "Core2Core" #-} + liftIO $ core2core hsc_env_with_plugins ds_result + +-------------------------------------------------------------- +-- Interface generators +-------------------------------------------------------------- + +-- | Generate a stripped down interface file, e.g. for boot files or when ghci +-- generates interface files. See Note [simpleTidyPgm - mkBootModDetailsTc] +hscSimpleIface :: HscEnv + -> Maybe CoreProgram + -> TcGblEnv + -> ModSummary + -> IO (ModIface, ModDetails) +hscSimpleIface hsc_env mb_core_program tc_result summary + = runHsc hsc_env $ hscSimpleIface' mb_core_program tc_result summary + +hscSimpleIface' :: Maybe CoreProgram + -> TcGblEnv + -> ModSummary + -> Hsc (ModIface, ModDetails) +hscSimpleIface' mb_core_program tc_result summary = do + hsc_env <- getHscEnv + logger <- getLogger + details <- liftIO $ mkBootModDetailsTc logger tc_result + safe_mode <- hscGetSafeMode tc_result + new_iface + <- {-# SCC "MkFinalIface" #-} + liftIO $ + mkIfaceTc hsc_env safe_mode details summary mb_core_program tc_result + -- And the answer is ... + liftIO $ dumpIfaceStats hsc_env + return (new_iface, details) + +-------------------------------------------------------------- +-- BackEnd combinators +-------------------------------------------------------------- + +-- | Compile to hard-code. +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 mod_loc output_filename = do + let CgGuts{ cg_module = this_mod, + cg_binds = core_binds, + cg_ccs = local_ccs + } = cgguts + dflags = hsc_dflags hsc_env + logger = hsc_logger hsc_env + + ------------------- + -- ADD IMPLICIT BINDINGS + -- NB: we must feed mkImplicitBinds through corePrep too + -- so that they are suitably cloned and eta-expanded + let cp_pgm_cfg :: CorePrepPgmConfig + cp_pgm_cfg = initCorePrepPgmConfig (hsc_dflags hsc_env) + (interactiveInScope $ hsc_IC hsc_env) + binds_with_implicits <- addImplicitBinds cp_pgm_cfg mod_loc (cg_tycons cgguts) core_binds + + ------------------- + -- INSERT LATE COST CENTRES, based on the provided flags. + -- + -- 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 + 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 + 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) + <- {-# SCC "CoreToStg" #-} + withTiming logger + (text "CoreToStg"<+>brackets (ppr this_mod)) + (\(a, b, (c,d), tag_env) -> + a `seqList` + b `seq` + c `seqList` + d `seqList` + (seqEltsUFM (seqTagSig) tag_env)) + (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 + + let cost_centre_info = + (late_local_ccs ++ caf_ccs, caf_cc_stacks) + platform = targetPlatform dflags + prof_init + | sccProfilingEnabled dflags = profilingInitCode platform this_mod cost_centre_info + | otherwise = mempty + + ------------------ Code generation ------------------ + -- The back-end is streamed: each top-level function goes + -- from Stg all the way to asm before dealing with the next + -- top-level function, so withTiming isn't very useful here. + -- Hence we have one withTiming for the whole backend, the + -- next withTiming after this will be "Assembler" (hard code only). + withTiming logger (text "CodeGen"<+>brackets (ppr this_mod)) (const ()) + $ case backendCodeOutput (backend dflags) of + JSCodeOutput -> + do + let js_config = initStgToJSConfig dflags + + -- The JavaScript backend does not create CmmCgInfos like the Cmm backend, + -- but it is needed for writing the interface file. Here we compute a very + -- conservative but correct value. + lf_infos (StgTopLifted (StgNonRec b _)) = [(idName b, LFUnknown True)] + lf_infos (StgTopLifted (StgRec bs)) = map (\(b,_) -> (idName b, LFUnknown True)) bs + lf_infos (StgTopStringLit b _) = [(idName b, LFUnlifted)] + + cmm_cg_infos = CmmCgInfos + { cgNonCafs = mempty + , cgLFInfos = mkNameEnv (concatMap lf_infos stg_binds) + , cgIPEStub = mempty + } + stub_c_exists = Nothing + foreign_fps = [] + + putDumpFileMaybe logger Opt_D_dump_stg_final "Final STG:" FormatSTG + (pprGenStgTopBindings (initStgPprOpts dflags) stg_binds) + + -- do the unfortunately effectual business + stgToJS logger js_config stg_binds this_mod spt_entries foreign_stubs0 cost_centre_info output_filename + return (output_filename, stub_c_exists, foreign_fps, Just stg_cg_infos, Just cmm_cg_infos) + + _ -> + do + cmms <- {-# SCC "StgToCmm" #-} + doCodeGen hsc_env this_mod denv tycons + cost_centre_info + stg_binds + + ------------------ Code output ----------------------- + rawcmms0 <- {-# SCC "cmmToRawCmm" #-} + case cmmToRawCmmHook hooks of + Nothing -> cmmToRawCmm logger profile cmms + Just h -> h dflags (Just this_mod) cmms + + 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 (liftIO . dump) rawcmms0 + + let foreign_stubs st = foreign_stubs0 + `appendStubC` prof_init + `appendStubC` cgIPEStub st + + (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 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) + + +-- The part of CgGuts that we need for HscInteractive +data CgInteractiveGuts = CgInteractiveGuts { cgi_module :: Module + , 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_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) -- ^ .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 + let CgInteractiveGuts{ -- This is the last use of the ModGuts in a compilation. + -- From now on, we just use the bits we need. + cgi_module = this_mod, + cgi_binds = core_binds, + cgi_tycons = tycons, + cgi_foreign = foreign_stubs, + cgi_modBreaks = mod_breaks, + cgi_spt_entries = spt_entries } = cgguts + + ------------------- + -- 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 + 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 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 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 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 (CompiledByteCode, [FilePath]) +generateByteCode hsc_env cgguts mod_location = do + (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 + -> CgInteractiveGuts + -> ModLocation + -> IO Linkable +generateFreshByteCode hsc_env mod_name cgguts mod_location = do + 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) +hscCompileCmmFile hsc_env original_filename filename output_filename = runHsc hsc_env $ do + let dflags = hsc_dflags hsc_env + logger = hsc_logger hsc_env + hooks = hsc_hooks hsc_env + tmpfs = hsc_tmpfs hsc_env + profile = targetProfile dflags + home_unit = hsc_home_unit hsc_env + platform = targetPlatform dflags + llvm_config = hsc_llvm_config hsc_env + cmm_config = initCmmConfig dflags + do_info_table = gopt Opt_InfoTableMap dflags + -- Make up a module name to give the NCG. We can't pass bottom here + -- lest we reproduce #11784. + mod_name = mkModuleName $ "Cmm$" ++ original_filename + cmm_mod = mkHomeModule home_unit mod_name + cmmpConfig = initCmmParserConfig dflags + (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) + + -- Compile decls in Cmm files one decl at a time, to avoid re-ordering + -- them in SRT analysis. + -- + -- 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] + ((_,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) + + 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 + in NoStubs `appendStubC` ip_init + | 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 + dus1 rawCmms + return stub_c_exists + where + 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 --------------------- + +{- +Note [Forcing of stg_binds] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The two last steps in the STG pipeline are: + +* Sorting the bindings in dependency order. +* Annotating them with free variables. + +We want to make sure we do not keep references to unannotated STG bindings +alive, nor references to bindings which have already been compiled to Cmm. + +We explicitly force the bindings to avoid this. + +This reduces residency towards the end of the CodeGen phase significantly +(5-10%). +-} + +doCodeGen :: HscEnv -> Module -> InfoTableProvMap -> [TyCon] + -> CollectedCCs + -> [CgStgTopBinding] -- ^ Bindings come already annotated with fvs + -> 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 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 + tmpfs = hsc_tmpfs hsc_env + platform = targetPlatform dflags + stg_ppr_opts = (initStgPprOpts dflags) + + putDumpFileMaybe logger Opt_D_dump_stg_final "Final STG:" FormatSTG + (pprGenStgTopBindings stg_ppr_opts stg_binds_w_fvs) + + 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 :: 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 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 + -- CmmGroup on input may produce many CmmGroups on output due + -- to proc-point splitting). + + let dump1 a = do + unless (null a) $ + putDumpFileMaybe logger Opt_D_dump_cmm_from_stg + "Cmm produced by codegen" FormatCMM (pdoc platform a) + return a + + ppr_stream1 = Stream.mapM (liftIO . dump1) cmm_stream + + cmm_config = initCmmConfig dflags + + pipeline_stream :: CgStream CmmGroupSRTs CmmCgInfos + pipeline_stream = do + ((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) + + -- 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 + :: Logger + -> CmmConfig + -> (ModuleSRTInfo, Map CmmInfoTable (Maybe IpeSourceLocation), IPEStats) + -> CmmGroup + -> 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) <- 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 + liftIO $ lookupEstimatedTicks hsc_env ipes stats cmm_srts + else + return (ipes, stats) + + return ((mod_srt_info', ipes', stats'), cmm_srts) + + dump2 a = do + unless (null a) $ + putDumpFileMaybe logger Opt_D_dump_cmm "Output Cmm" FormatCMM (pdoc platform a) + return a + + return $ Stream.mapM (liftIO . dump2) pipeline_stream + +myCoreToStg :: Logger -> DynFlags -> [Var] + -> Bool + -> Module -> ModLocation -> CoreProgram + -> IO ( [(CgStgTopBinding,IdSet)] -- output program and its dependencies + , InfoTableProvMap + , CollectedCCs -- CAF cost centre info (declared and used) + , StgCgInfos ) +myCoreToStg logger dflags ic_inscope for_bytecode this_mod ml prepd_binds = do + let (stg_binds, denv, cost_centre_info) + = {-# SCC "Core2Stg" #-} + coreToStg (initCoreToStgOpts dflags) this_mod ml prepd_binds + + (stg_binds_with_fvs,stg_cg_info) + <- {-# SCC "Stg2Stg" #-} + stg2stg logger ic_inscope (initStgPipelineOpts dflags for_bytecode) + this_mod stg_binds + + putDumpFileMaybe logger Opt_D_dump_stg_cg "CodeGenInput STG:" FormatSTG + (pprGenStgTopBindings (initStgPprOpts dflags) (fmap fst stg_binds_with_fvs)) + + return (stg_binds_with_fvs, denv, cost_centre_info, stg_cg_info) + +{- ********************************************************************** +%* * +\subsection{Compiling a do-statement} +%* * +%********************************************************************* -} + +{- +When the UnlinkedBCOExpr is linked you get an HValue of type *IO [HValue]* When +you run it you get a list of HValues that should be the same length as the list +of names; add them to the ClosureEnv. + +A naked expression returns a singleton Name [it]. The stmt is lifted into the +IO monad as explained in Note [Interactively-bound Ids in GHCi] in GHC.Runtime.Context +-} + +-- | Compile a stmt all the way to an HValue, but don't run it +-- +-- We return Nothing to indicate an empty statement (or comment only), not a +-- parse error. +hscStmt :: HscEnv -> String -> IO (Maybe ([Id], ForeignHValue, FixityEnv)) +hscStmt hsc_env stmt = hscStmtWithLocation hsc_env stmt "" 1 + +-- | Compile a stmt all the way to an HValue, but don't run it +-- +-- We return Nothing to indicate an empty statement (or comment only), not a +-- parse error. +hscStmtWithLocation :: HscEnv + -> String -- ^ The statement + -> String -- ^ The source + -> Int -- ^ Starting line + -> IO ( Maybe ([Id] + , ForeignHValue {- IO [HValue] -} + , FixityEnv)) +hscStmtWithLocation hsc_env0 stmt source linenumber = + runInteractiveHsc hsc_env0 $ do + maybe_stmt <- hscParseStmtWithLocation source linenumber stmt + case maybe_stmt of + Nothing -> return Nothing + + Just parsed_stmt -> do + hsc_env <- getHscEnv + liftIO $ hscParsedStmt hsc_env parsed_stmt + +hscParsedStmt :: HscEnv + -> GhciLStmt GhcPs -- ^ The parsed statement + -> IO ( Maybe ([Id] + , ForeignHValue {- IO [HValue] -} + , FixityEnv)) +hscParsedStmt hsc_env stmt = runInteractiveHsc hsc_env $ do + -- Rename and typecheck it + (ids, tc_expr, fix_env) <- ioMsgMaybe $ hoistTcRnMessage $ tcRnStmt hsc_env stmt + + -- Desugar it + ds_expr <- ioMsgMaybe $ hoistDsMessage $ deSugarExpr hsc_env tc_expr + liftIO (lintInteractiveExpr (text "desugar expression") hsc_env ds_expr) + handleWarnings + + -- Then code-gen, and link it + -- It's important NOT to have package 'interactive' as thisUnitId + -- for linking, else we try to link 'main' and can't find it. + -- Whereas the linker already knows to ignore 'interactive' + let src_span = srcLocSpan interactiveSrcLoc + (hval,_,_) <- liftIO $ hscCompileCoreExpr hsc_env src_span ds_expr + + return $ Just (ids, hval, fix_env) + +hscParseModuleWithLocation :: HscEnv -> String -> Int -> String -> IO (HsModule GhcPs) +hscParseModuleWithLocation hsc_env source line_num str = do + L _ mod <- + runInteractiveHsc hsc_env $ + hscParseThingWithLocation source line_num parseModule str + return mod + +hscParseDeclsWithLocation :: HscEnv -> String -> Int -> String -> IO [LHsDecl GhcPs] +hscParseDeclsWithLocation hsc_env source line_num str = do + HsModule { hsmodDecls = decls } <- hscParseModuleWithLocation hsc_env source line_num str + return decls + +hscParsedDecls :: HscEnv -> [LHsDecl GhcPs] -> IO ([TyThing], InteractiveContext) +hscParsedDecls hsc_env decls = runInteractiveHsc hsc_env $ do + hsc_env <- getHscEnv + let interp = hscInterp hsc_env + + {- Rename and typecheck it -} + tc_gblenv <- ioMsgMaybe $ hoistTcRnMessage $ tcRnDeclsi hsc_env decls + + {- Grab the new instances -} + -- We grab the whole environment because of the overlapping that may have + -- been done. See the notes at the definition of InteractiveContext + -- (ic_instances) for more details. + let defaults = tcg_default tc_gblenv + + {- Desugar it -} + -- We use a basically null location for iNTERACTIVE + 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 -} + simpl_mg <- liftIO $ do + plugins <- readIORef (tcg_th_coreplugins tc_gblenv) + hscSimplify hsc_env plugins ds_result + + {- Tidy -} + (tidy_cg, mod_details) <- liftIO $ hscTidy hsc_env simpl_mg + + let !CgGuts{ cg_module = this_mod, + 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 + + {- 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 linkable + + {- Load static pointer table entries -} + liftIO $ hscAddSptEntries hsc_env (cg_spt_entries tidy_cg) + + let tcs = filterOut isImplicitTyCon (mg_tcs simpl_mg) + patsyns = mg_patsyns simpl_mg + + ext_ids = [ id | id <- bindersOfBinds core_binds + , isExternalName (idName id) + , not (isDFunId id || isImplicitId id) ] + -- We only need to keep around the external bindings + -- (as decided by GHC.Iface.Tidy), since those are the only ones + -- that might later be looked up by name. But we can exclude + -- - DFunIds, which are in 'cls_insts' (see Note [ic_tythings] in GHC.Runtime.Context + -- - Implicit Ids, which are implicit in tcs + -- c.f. GHC.Tc.Module.runTcInteractive, which reconstructs the TypeEnv + + new_tythings = map AnId ext_ids ++ map ATyCon tcs ++ map (AConLike . PatSynCon) patsyns + ictxt = hsc_IC hsc_env + -- See Note [Fixity declarations in GHCi] + fix_env = tcg_fix_env tc_gblenv + new_ictxt = extendInteractiveContext ictxt new_tythings cls_insts + fam_insts defaults fix_env + return (new_tythings, new_ictxt) + +-- | Load the given static-pointer table entries into the interpreter. +-- See Note [Grand plan for static forms] in "GHC.Iface.Tidy.StaticPtrTable". +hscAddSptEntries :: HscEnv -> [SptEntry] -> IO () +hscAddSptEntries hsc_env entries = do + let interp = hscInterp hsc_env + let add_spt_entry :: SptEntry -> IO () + add_spt_entry (SptEntry i fpr) = do + -- These are only names from the current module + (val, _, _) <- loadName interp hsc_env (idName i) + addSptEntry interp fpr val + mapM_ add_spt_entry entries + +{- + Note [Fixity declarations in GHCi] + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + To support fixity declarations on types defined within GHCi (as requested + in #10018) we record the fixity environment in InteractiveContext. + When we want to evaluate something GHC.Tc.Module.runTcInteractive pulls out this + fixity environment and uses it to initialize the global typechecker environment. + After the typechecker has finished its business, an updated fixity environment + (reflecting whatever fixity declarations were present in the statements we + passed it) will be returned from hscParsedStmt. This is passed to + updateFixityEnv, which will stuff it back into InteractiveContext, to be + used in evaluating the next statement. + +-} + +hscImport :: HscEnv -> String -> IO (ImportDecl GhcPs) +hscImport hsc_env str = runInteractiveHsc hsc_env $ do + -- Use >>= \case instead of MonadFail desugaring to take into + -- consideration `instance XXModule p = DataConCantHappen`. + -- Tracked in #15681 + hscParseThing parseModule str >>= \case + (L _ (HsModule{hsmodImports=is})) -> + case is of + [L _ i] -> return i + _ -> liftIO $ throwOneError $ + mkPlainErrorMsgEnvelope noSrcSpan $ + GhcPsMessage $ PsUnknownMessage $ + mkSimpleUnknownDiagnostic $ + mkPlainError noHints $ + text "parse error in import declaration" + +-- | Typecheck an expression (but don't run it) +hscTcExpr :: HscEnv + -> TcRnExprMode + -> String -- ^ The expression + -> IO Type +hscTcExpr hsc_env0 mode expr = runInteractiveHsc hsc_env0 $ do + hsc_env <- getHscEnv + parsed_expr <- hscParseExpr expr + ioMsgMaybe $ hoistTcRnMessage $ tcRnExpr hsc_env mode parsed_expr + +-- | Find the kind of a type, after generalisation +hscKcType + :: HscEnv + -> Bool -- ^ Normalise the type + -> String -- ^ The type as a string + -> IO (Type, Kind) -- ^ Resulting type (possibly normalised) and kind +hscKcType hsc_env0 normalise str = runInteractiveHsc hsc_env0 $ do + hsc_env <- getHscEnv + ty <- hscParseType str + ioMsgMaybe $ hoistTcRnMessage $ tcRnType hsc_env DefaultFlexi normalise ty + +hscParseExpr :: String -> Hsc (LHsExpr GhcPs) +hscParseExpr expr = do + maybe_stmt <- hscParseStmt expr + case maybe_stmt of + Just (L _ (BodyStmt _ expr _ _)) -> return expr + _ -> throwOneError $ + mkPlainErrorMsgEnvelope noSrcSpan $ + GhcPsMessage $ PsUnknownMessage + $ mkSimpleUnknownDiagnostic + $ mkPlainError noHints $ + text "not an expression:" <+> quotes (text expr) + +hscParseStmt :: String -> Hsc (Maybe (GhciLStmt GhcPs)) +hscParseStmt = hscParseThing parseStmt + +hscParseStmtWithLocation :: String -> Int -> String + -> Hsc (Maybe (GhciLStmt GhcPs)) +hscParseStmtWithLocation source linenumber stmt = + hscParseThingWithLocation source linenumber parseStmt stmt + +hscParseType :: String -> Hsc (LHsType GhcPs) +hscParseType = hscParseThing parseType + +hscParseIdentifier :: HscEnv -> String -> IO (LocatedN RdrName) +hscParseIdentifier hsc_env str = + runInteractiveHsc hsc_env $ hscParseThing parseIdentifier str + +hscParseThing :: (Outputable thing, Data thing) + => Lexer.P thing -> String -> Hsc thing +hscParseThing = hscParseThingWithLocation "" 1 + +hscParseThingWithLocation :: (Outputable thing, Data thing) => String -> Int + -> Lexer.P thing -> String -> Hsc thing +hscParseThingWithLocation source linenumber parser str = do + dflags <- getDynFlags + logger <- getLogger + withTiming logger + (text "Parser [source]") + (const ()) $ {-# SCC "Parser" #-} do + + let buf = stringToStringBuffer str + loc = mkRealSrcLoc (fsLit source) linenumber 1 + + case unP parser (initParserState (initParserOpts dflags) buf loc) of + PFailed pst -> + handleWarningsThrowErrors (getPsMessages pst) + POk pst thing -> do + logWarningsReportErrors (getPsMessages pst) + liftIO $ putDumpFileMaybe logger Opt_D_dump_parsed "Parser" + FormatHaskell (ppr thing) + liftIO $ putDumpFileMaybe logger Opt_D_dump_parsed_ast "Parser AST" + FormatHaskell (showAstData NoBlankSrcSpan NoBlankEpAnnotations thing) + return thing + +hscTidy :: HscEnv -> ModGuts -> IO (CgGuts, ModDetails) +hscTidy hsc_env guts = do + let logger = hsc_logger hsc_env + let this_mod = mg_module guts + + opts <- initTidyOpts hsc_env + (cgguts, details) <- withTiming logger + (text "CoreTidy"<+>brackets (ppr this_mod)) + (const ()) + $! {-# SCC "CoreTidy" #-} tidyProgram opts guts + + -- post tidy pretty-printing and linting... + let tidy_rules = md_rules details + let all_tidy_binds = cg_binds cgguts + let name_ppr_ctx = mkNamePprCtx ptc (hsc_unit_env hsc_env) (mg_rdr_env guts) + ptc = initPromotionTickContext (hsc_dflags hsc_env) + + endPassHscEnvIO hsc_env name_ppr_ctx CoreTidy all_tidy_binds tidy_rules + + -- If the endPass didn't print the rules, but ddump-rules is + -- on, print now + unless (logHasDumpFlag logger Opt_D_dump_simpl) $ + putDumpFileMaybe logger Opt_D_dump_rules + "Tidy Core rules" + FormatText + (pprRulesForUser tidy_rules) + + -- Print one-line size info + let cs = coreBindsStats all_tidy_binds + putDumpFileMaybe logger Opt_D_dump_core_stats "Core Stats" + FormatText + (text "Tidy size (terms,types,coercions)" + <+> ppr (moduleName this_mod) <> colon + <+> int (cs_tm cs) + <+> int (cs_ty cs) + <+> int (cs_co cs)) + + pure (cgguts, details) + + +{- ********************************************************************** +%* * + Desugar, simplify, convert to bytecode, and link an expression +%* * +%********************************************************************* -} + +hscCompileCoreExpr :: HscEnv -> SrcSpan -> CoreExpr -> IO (ForeignHValue, [Linkable], PkgsLoaded) +hscCompileCoreExpr hsc_env loc expr = + case hscCompileCoreExprHook (hsc_hooks hsc_env) of + Nothing -> hscCompileCoreExpr' hsc_env loc expr + Just h -> h hsc_env loc expr + +hscCompileCoreExpr' :: HscEnv -> SrcSpan -> CoreExpr -> IO (ForeignHValue, [Linkable], PkgsLoaded) +hscCompileCoreExpr' hsc_env srcspan ds_expr = do + {- Simplify it -} + -- Question: should we call SimpleOpt.simpleOptExpr here instead? + -- It is, well, simpler, and does less inlining etc. + let dflags = hsc_dflags hsc_env + let logger = hsc_logger hsc_env + let ic = hsc_IC hsc_env + let unit_env = hsc_unit_env hsc_env + let simplify_expr_opts = initSimplifyExprOpts dflags ic + + simpl_expr <- simplifyExpr logger (ue_eps unit_env) simplify_expr_opts ds_expr + + -- Create a unique temporary binding + -- + -- The id has to be exported for the JS backend. This isn't required for the + -- byte-code interpreter but it does no harm to always do it. + u <- uniqFromTag 'I' + let binding_name = mkSystemVarName u (fsLit ("BCO_toplevel")) + let binding_id = mkExportedVanillaId binding_name (exprType simpl_expr) + + {- Tidy it (temporary, until coreSat does cloning) -} + let tidy_occ_env = initTidyOccEnv [occName binding_id] + let tidy_env = mkEmptyTidyEnv tidy_occ_env + let tidy_expr = tidyExpr tidy_env simpl_expr + + {- Prepare for codegen -} + cp_cfg <- initCorePrepConfig hsc_env + prepd_expr <- corePrepExpr + logger cp_cfg + tidy_expr + + {- Lint if necessary -} + lintInteractiveExpr (text "hscCompileCoreExpr") hsc_env prepd_expr + 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 + -- relationship between modules and object files, i.e. we get different object + -- files for the same module and the JS linker doesn't support this. + -- + -- Note that we can't use icInteractiveModule because the ic_mod_index value + -- isn't bumped between invocations of hscCompileCoreExpr, so uniqueness isn't + -- guaranteed. + -- + -- We reuse the unique we obtained for the binding, but any unique would do. + let this_mod = mkInteractiveModule (show u) + let for_bytecode = True + + (stg_binds_with_deps, _prov_map, _collected_ccs, _stg_cg_infos) <- + myCoreToStg logger + dflags + (interactiveInScope (hsc_IC hsc_env)) + for_bytecode + this_mod + this_loc + [NonRec binding_id prepd_expr] + + let (stg_binds, _stg_deps) = unzip stg_binds_with_deps + + let interp = hscInterp hsc_env + + case interp of + -- always generate JS code for the JS interpreter (no bytecode!) + Interp (ExternalInterp (ExtJS i)) _ _ -> + jsCodeGen hsc_env srcspan i this_mod stg_binds_with_deps binding_id + + _ -> do + {- Convert to BCOs -} + bcos <- byteCodeGen hsc_env + this_mod + stg_binds + [] + Nothing -- modbreaks + [] -- spt entries + + {- load it -} + 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 $ lookup (idName binding_id) fv_hvs, mods_needed, units_needed) + + + +-- | Generate JS code for the given bindings and return the HValue for the given id +jsCodeGen + :: HscEnv + -> SrcSpan + -> JSInterp + -> Module + -> [(CgStgTopBinding,IdSet)] + -> Id + -> IO (ForeignHValue, [Linkable], PkgsLoaded) +jsCodeGen hsc_env srcspan i this_mod stg_binds_with_deps binding_id = do + let logger = hsc_logger hsc_env + tmpfs = hsc_tmpfs hsc_env + dflags = hsc_dflags hsc_env + interp = hscInterp hsc_env + tmp_dir = tmpDir dflags + unit_env = hsc_unit_env hsc_env + js_config = initStgToJSConfig dflags + + -- We need to load all the dependencies first. + -- + -- We get all the imported names from the Stg bindings and load their modules. + -- + -- (logic adapted from GHC.Linker.Loader.loadDecls for the JS linker) + let + (stg_binds, stg_deps) = unzip stg_binds_with_deps + imported_ids = nonDetEltsUniqSet (unionVarSets stg_deps) + imported_names = map idName imported_ids + + needed_mods :: [Module] + needed_mods = [ nameModule n | n <- imported_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. + + -- Initialise the linker (if it's not been done already) + initLoaderState interp hsc_env + + -- Take lock for the actual work. + (dep_linkables, dep_units) <- modifyLoaderState interp $ \pls -> do + let link_opts = initLinkDepsOpts hsc_env + + -- Find what packages and linkables are required + 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 = 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. + + -- FIXME: we don't report needed units because we would have to find a way + -- to build a meaningful LoadedPkgInfo (see the mess in + -- GHC.Linker.Loader.{loadPackage,loadPackages'}). Detecting what to load + -- and actually loading (using the native interpreter) are intermingled, so + -- we can't directly reuse this code. + let pls' = pls { objs_loaded = objs_loaded' } + pure (pls', (ldAllLinkables deps, emptyUDFM {- ldNeededUnits deps -}) ) + + + let foreign_stubs = NoStubs + spt_entries = mempty + cost_centre_info = mempty + + -- codegen into object file whose path is in out_obj + out_obj <- newTempName logger tmpfs tmp_dir TFL_CurrentModule "o" + stgToJS logger js_config stg_binds this_mod spt_entries foreign_stubs cost_centre_info out_obj + + let TxtI id_sym = makeIdentForId binding_id Nothing IdPlain this_mod + -- link code containing binding "id_sym = expr", using id_sym as root + withJSInterp i $ \inst -> do + let roots = mkExportedModFuns this_mod [id_sym] + 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 (IFaststringSymbol id_sym) >>= \case + Nothing -> pprPanic "Couldn't find just linked TH closure" (ppr id_sym) + Just r -> pure r + + binding_fref <- withJSInterp i $ \inst -> + mkForeignRef href (freeReallyRemoteRef inst href) + + return (castForeignRef binding_fref, dep_linkables, dep_units) + + +{- ********************************************************************** +%* * + Statistics on reading interfaces +%* * +%********************************************************************* -} + +dumpIfaceStats :: HscEnv -> IO () +dumpIfaceStats hsc_env = do + eps <- hscEPS hsc_env + let + logger = hsc_logger hsc_env + dump_rn_stats = logHasDumpFlag logger Opt_D_dump_rn_stats + dump_if_trace = logHasDumpFlag logger Opt_D_dump_if_trace + when (dump_if_trace || dump_rn_stats) $ + logDumpMsg logger "Interface statistics" (ifaceStats eps) + + 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,3002 +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', 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.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.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.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.Map -import GHC.Types.Unique - -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 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 -> LoadHowMuch -> m SuccessFlag -loadWithCache cache how_much = do - (errs, mod_graph) <- depanalE [] False -- #17459 - msg <- mkBatchMsg <$> getSession - success <- load' cache how_much (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 - - -- 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 ( - filter (\ms -> homeUnitId_ dflags == ms_unitid ms) (mgModSummaries mod_graph)) - - 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 = 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 - --- | 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 -> Maybe Messager -> ModuleGraph -> m SuccessFlag -load' mhmi_cache how_much 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'. - initializeSessionPlugins - modifySession $ \hsc_env -> hsc_env { hsc_mod_graph = mod_graph } - guessOutputFile - hsc_env <- getSession - - 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)) - - n_jobs <- case parMakeCount (hsc_dflags hsc_env) of - Nothing -> liftIO getNumProcessors - Just n -> return n - - (upsweep_ok, new_deps) <- withDeferredDiagnostics $ do - hsc_env <- getSession - liftIO $ upsweep n_jobs hsc_env mhmi_cache 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 - - --- | Abstraction over the operations of a semaphore which allows usage with the --- -j1 case -data AbstractSem = AbstractSem { acquireSem :: IO () - , releaseSem :: IO () } - -withAbstractSem :: AbstractSem -> IO b -> IO b -withAbstractSem sem = MC.bracket_ (acquireSem sem) (releaseSem sem) - --- | 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) - } - -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 - :: Int -- ^ 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 - -> Maybe Messager - -> M.Map ModNodeKeyWithUid HomeModInfo - -> [BuildPlan] - -> IO (SuccessFlag, [HomeModInfo]) -upsweep n_jobs hsc_env hmi_cache 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 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) - $ listToUniqMap $ Map.toList - $ 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 $ - DriverUnknownMessage $ UnknownDiagnostic $ mkPlainError noHints $ - cannotFindModule hsc_env wanted_mod err - -{- -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 :: HscEnv -> IO a -> IO (Maybe a) -wrapAction 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) (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 - lift $ MaybeT $ withLoggerHsc k env $ \hsc_env -> - let lcl_hsc_env = setHUG deps hsc_env - in wrapAction 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 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_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 :: Int -> HscEnv -> Maybe Messager -> [MakeAction] -> IO () --- Don't even initialise plugins if there are no pipelines -runPipelines _ _ _ [] = return () -runPipelines n_job hsc_env mHscMessager all_pipelines = do - liftIO $ label_self "main --make thread" - case n_job of - 1 -> runSeqPipelines hsc_env mHscMessager all_pipelines - _n -> runParPipelines n_job hsc_env mHscMessager all_pipelines - -runSeqPipelines :: HscEnv -> Maybe Messager -> [MakeAction] -> IO () -runSeqPipelines plugin_hsc_env mHscMessager all_pipelines = - let env = MakeEnv { hsc_env = plugin_hsc_env - , withLogger = \_ k -> k id - , compile_sem = AbstractSem (return ()) (return ()) - , env_messager = mHscMessager - } - in runAllPipelines 1 env all_pipelines - - --- | Build and run a pipeline -runParPipelines :: Int -- ^ How many capabilities to use - -> HscEnv -- ^ The basic HscEnv which is augmented with specific info for each module - -> Maybe Messager -- ^ Optional custom messager to use to report progress - -> [MakeAction] -- ^ The build plan for all the module nodes - -> IO () -runParPipelines n_jobs plugin_hsc_env 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 n_jobs (length all_pipelines) (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 } - - let updNumCapabilities = liftIO $ do - n_capabilities <- getNumCapabilities - n_cpus <- getNumProcessors - -- Setting number of capabilities more than - -- CPU count usually leads to high userspace - -- lock contention. #9221 - let n_caps = min n_jobs n_cpus - unless (n_capabilities /= 1) $ setNumCapabilities n_caps - return n_capabilities - - let resetNumCapabilities orig_n = do - liftIO $ setNumCapabilities orig_n - atomically $ writeTVar stopped_var True - wait_log_thread - - compile_sem <- newQSem n_jobs - let abstract_sem = AbstractSem (waitQSem compile_sem) (signalQSem compile_sem) - -- Reset the number of capabilities once the upsweep ends. - let env = MakeEnv { hsc_env = thread_safe_hsc_env - , withLogger = withParLog log_queue_queue_var - , compile_sem = abstract_sem - , env_messager = mHscMessager - } - - MC.bracket updNumCapabilities resetNumCapabilities $ \_ -> - runAllPipelines n_jobs env all_pipelines - -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 :: Int -> MakeEnv -> [MakeAction] -> IO () -runAllPipelines n_jobs env acts = do - let spawn_actions :: IO [ThreadId] - spawn_actions = if n_jobs == 1 - 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,24 +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.Session -import GHC.Driver.Ppr +import GHC.Driver.DynFlags 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.Error (UnknownDiagnostic(..)) import GHC.Types.SourceError import GHC.Types.SrcLoc import GHC.Types.PkgQual @@ -53,6 +53,8 @@ import Data.Maybe ( isJust ) 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 @@ -307,9 +314,8 @@ fail -> throwOneError $ mkPlainErrorMsgEnvelope srcloc $ - GhcDriverMessage $ DriverUnknownMessage $ - UnknownDiagnostic $ mkPlainError noHints $ - cannotFindModule hsc_env imp fail + GhcDriverMessage $ DriverInterfaceError $ + (Can'tFindInterface (cannotFindModule hsc_env imp fail) (LookingForModule imp is_boot)) ----------------------------- writeDependency :: FilePath -> Handle -> [FilePath] -> FilePath -> IO () @@ -405,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 new file mode 100644 --- /dev/null +++ b/GHC/Driver/MakeSem.hs @@ -0,0 +1,545 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE NumericUnderscores #-} + +-- | Implementation of a jobserver using system semaphores. +-- +-- +module GHC.Driver.MakeSem + ( -- * JSem: parallelism semaphore backed + -- by a system semaphore (Posix/Windows) + runJSemAbstractSem + + -- * System semaphores + , Semaphore, SemaphoreName(..) + + -- * Abstract semaphores + , AbstractSem(..) + , withAbstractSem + ) + where + +import GHC.Prelude +import GHC.Conc +import GHC.Data.OrdList +import GHC.IO.Exception +import GHC.Utils.Outputable +import GHC.Utils.Panic +import GHC.Utils.Json + +import System.Semaphore + +import Control.Monad +import qualified Control.Monad.Catch as MC +import Control.Concurrent.MVar +import Control.Concurrent.STM +import Data.Foldable +import Data.Functor +import GHC.Stack +import Debug.Trace + +--------------------------------------- +-- Semaphore jobserver + +-- | A jobserver based off a system 'Semaphore'. +-- +-- Keeps track of the pending jobs and resources +-- available from the semaphore. +data Jobserver + = Jobserver + { jSemaphore :: !Semaphore + -- ^ The semaphore which controls available resources + , jobs :: !(TVar JobResources) + -- ^ The currently pending jobs, and the resources + -- obtained from the semaphore + } + +data JobserverOptions + = JobserverOptions + { releaseDebounce :: !Int + -- ^ Minimum delay, in milliseconds, between acquiring a token + -- and releasing a token. + , setNumCapsDebounce :: !Int + -- ^ Minimum delay, in milliseconds, between two consecutive + -- calls of 'setNumCapabilities'. + } + +defaultJobserverOptions :: JobserverOptions +defaultJobserverOptions = + JobserverOptions + { releaseDebounce = 1000 -- 1 second + , setNumCapsDebounce = 1000 -- 1 second + } + +-- | Resources available for running jobs, i.e. +-- tokens obtained from the parallelism semaphore. +data JobResources + = Jobs + { tokensOwned :: !Int + -- ^ How many tokens have been claimed from the semaphore + , tokensFree :: !Int + -- ^ How many tokens are not currently being used + , jobsWaiting :: !(OrdList (TMVar ())) + -- ^ Pending jobs waiting on a token, the job will be blocked on the TMVar so putting into + -- the TMVar will allow the job to continue. + } + +instance Outputable JobResources where + ppr Jobs{..} + = text "JobResources" <+> + ( braces $ hsep + [ text "owned=" <> ppr tokensOwned + , text "free=" <> ppr tokensFree + , text "num_waiting=" <> ppr (length jobsWaiting) + ] ) + +-- | Add one new token. +addToken :: JobResources -> JobResources +addToken jobs@( Jobs { tokensOwned = owned, tokensFree = free }) + = jobs { tokensOwned = owned + 1, tokensFree = free + 1 } + +-- | Free one token. +addFreeToken :: JobResources -> JobResources +addFreeToken jobs@( Jobs { tokensFree = free }) + = assertPpr (tokensOwned jobs > free) + (text "addFreeToken:" <+> ppr (tokensOwned jobs) <+> ppr free) + $ jobs { tokensFree = free + 1 } + +-- | Use up one token. +removeFreeToken :: JobResources -> JobResources +removeFreeToken jobs@( Jobs { tokensFree = free }) + = assertPpr (free > 0) + (text "removeFreeToken:" <+> ppr free) + $ jobs { tokensFree = free - 1 } + +-- | Return one owned token. +removeOwnedToken :: JobResources -> JobResources +removeOwnedToken jobs@( Jobs { tokensOwned = owned }) + = assertPpr (owned > 1) + (text "removeOwnedToken:" <+> ppr owned) + $ jobs { tokensOwned = owned - 1 } + +-- | Add one new job to the end of the list of pending jobs. +addJob :: TMVar () -> JobResources -> JobResources +addJob job jobs@( Jobs { jobsWaiting = wait }) + = jobs { jobsWaiting = wait `SnocOL` job } + +-- | The state of the semaphore job server. +data JobserverState + = JobserverState + { jobserverAction :: !JobserverAction + -- ^ The current action being performed by the + -- job server. + , canChangeNumCaps :: !(TVar Bool) + -- ^ A TVar that signals whether it has been long + -- enough since we last changed 'numCapabilities'. + , canReleaseToken :: !(TVar Bool) + -- ^ A TVar that signals whether we last acquired + -- a token long enough ago that we can now release + -- a token. + } +data JobserverAction + -- | The jobserver is idle: no thread is currently + -- interacting with the semaphore. + = Idle + -- | A thread is waiting for a token on the semaphore. + | Acquiring + { activeWaitId :: WaitId + , threadFinished :: TMVar (Maybe MC.SomeException) } + +-- | Retrieve the 'TMVar' that signals if the current thread has finished, +-- if any thread is currently active in the jobserver. +activeThread_maybe :: JobserverAction -> Maybe (TMVar (Maybe MC.SomeException)) +activeThread_maybe Idle = Nothing +activeThread_maybe (Acquiring { threadFinished = tmvar }) = Just tmvar + +-- | Whether we should try to acquire a new token from the semaphore: +-- there is a pending job and no free tokens. +guardAcquire :: JobResources -> Bool +guardAcquire ( Jobs { tokensFree, jobsWaiting } ) + = tokensFree == 0 && not (null jobsWaiting) + +-- | Whether we should release a token from the semaphore: +-- there are no pending jobs and we can release a token. +guardRelease :: JobResources -> Bool +guardRelease ( Jobs { tokensFree, tokensOwned, jobsWaiting } ) + = null jobsWaiting && tokensFree > 0 && tokensOwned > 1 + +--------------------------------------- +-- Semaphore jobserver implementation + +-- | Add one pending job to the jobserver. +-- +-- Blocks, waiting on the jobserver to supply a free token. +acquireJob :: TVar JobResources -> IO () +acquireJob jobs_tvar = do + (job_tmvar, _jobs0) <- tracedAtomically "acquire" $ + modifyJobResources jobs_tvar \ jobs -> do + job_tmvar <- newEmptyTMVar + return ((job_tmvar, jobs), addJob job_tmvar jobs) + atomically $ takeTMVar job_tmvar + +-- | Signal to the job server that one job has completed, +-- releasing its corresponding token. +releaseJob :: TVar JobResources -> IO () +releaseJob jobs_tvar = do + tracedAtomically "release" do + modifyJobResources jobs_tvar \ jobs -> do + massertPpr (tokensFree jobs < tokensOwned jobs) + (text "releaseJob: more free jobs than owned jobs!") + return ((), addFreeToken jobs) + + +-- | Release all tokens owned from the semaphore (to clean up +-- the jobserver at the end). +cleanupJobserver :: Jobserver -> IO () +cleanupJobserver (Jobserver { jSemaphore = sem + , jobs = jobs_tvar }) + = do + Jobs { tokensOwned = owned } <- readTVarIO jobs_tvar + let toks_to_release = owned - 1 + -- Subtract off the implicit token: whoever spawned the ghc process + -- in the first place is responsible for that token. + releaseSemaphore sem toks_to_release + +-- | Dispatch the available tokens acquired from the semaphore +-- to the pending jobs in the job server. +dispatchTokens :: JobResources -> STM JobResources +dispatchTokens jobs@( Jobs { tokensFree = toks_free, jobsWaiting = wait } ) + | toks_free > 0 + , next `ConsOL` rest <- wait + -- There's a pending job and a free token: + -- pass on the token to that job, and recur. + = do + putTMVar next () + let jobs' = jobs { tokensFree = toks_free - 1, jobsWaiting = rest } + dispatchTokens jobs' + | otherwise + = return jobs + +-- | Update the available resources used from a semaphore, dispatching +-- any newly acquired resources. +-- +-- Invariant: if the number of available resources decreases, there +-- must be no pending jobs. +-- +-- All modifications should go through this function to ensure the contents +-- of the 'TVar' remains in normal form. +modifyJobResources :: HasCallStack => TVar JobResources + -> (JobResources -> STM (a, JobResources)) + -> STM (a, Maybe JobResources) +modifyJobResources jobs_tvar action = do + old_jobs <- readTVar jobs_tvar + (a, jobs) <- action old_jobs + + -- Check the invariant: if the number of free tokens has decreased, + -- there must be no pending jobs. + massertPpr (null (jobsWaiting jobs) || tokensFree jobs >= tokensFree old_jobs) $ + vcat [ text "modiyJobResources: pending jobs but fewer free tokens" ] + dispatched_jobs <- dispatchTokens jobs + writeTVar jobs_tvar dispatched_jobs + return (a, Just dispatched_jobs) + + +tracedAtomically_ :: String -> STM (Maybe JobResources) -> IO () +tracedAtomically_ s act = tracedAtomically s (((),) <$> act) + +tracedAtomically :: String -> STM (a, Maybe JobResources) -> IO a +tracedAtomically origin act = do + (a, mjr) <- atomically act + forM_ mjr $ \ jr -> do + -- Use the "jsem:" prefix to identify where the write traces are + traceEventIO ("jsem:" ++ renderJobResources origin jr) + return a + +renderJobResources :: String -> JobResources -> String +renderJobResources origin (Jobs own free pending) = showSDocUnsafe $ renderJSON $ + JSObject [ ("name", JSString origin) + , ("owned", JSInt own) + , ("free", JSInt free) + , ("pending", JSInt (length pending) ) + ] + + +-- | Spawn a new thread that waits on the semaphore in order to acquire +-- an additional token. +acquireThread :: Jobserver -> IO JobserverAction +acquireThread (Jobserver { jSemaphore = sem, jobs = jobs_tvar }) = do + threadFinished_tmvar <- newEmptyTMVarIO + let + wait_result_action :: Either MC.SomeException Bool -> IO () + wait_result_action wait_res = + tracedAtomically_ "acquire_thread" do + (r, jb) <- case wait_res of + Left (e :: MC.SomeException) -> do + return $ (Just e, Nothing) + Right success -> do + if success + then do + modifyJobResources jobs_tvar \ jobs -> + return (Nothing, addToken jobs) + else + return (Nothing, Nothing) + putTMVar threadFinished_tmvar r + return jb + wait_id <- forkWaitOnSemaphoreInterruptible sem wait_result_action + labelThread (waitingThreadId wait_id) "acquire_thread" + return $ Acquiring { activeWaitId = wait_id + , threadFinished = threadFinished_tmvar } + +-- | Spawn a thread to release ownership of one resource from the semaphore, +-- provided we have spare resources and no pending jobs. +releaseThread :: Jobserver -> IO JobserverAction +releaseThread (Jobserver { jSemaphore = sem, jobs = jobs_tvar }) = do + threadFinished_tmvar <- newEmptyTMVarIO + MC.mask_ do + -- Pre-release the resource so that another thread doesn't take control of it + -- just as we release the lock on the semaphore. + still_ok_to_release + <- tracedAtomically "pre_release" $ + modifyJobResources jobs_tvar \ jobs -> + if guardRelease jobs + -- TODO: should this also debounce? + then return (True , removeOwnedToken $ removeFreeToken jobs) + else return (False, jobs) + if not still_ok_to_release + then return Idle + else do + tid <- forkIO $ do + x <- MC.try $ releaseSemaphore sem 1 + tracedAtomically_ "post-release" $ do + (r, jobs) <- case x of + Left (e :: MC.SomeException) -> do + modifyJobResources jobs_tvar \ jobs -> + return (Just e, addToken jobs) + Right _ -> do + return (Nothing, Nothing) + putTMVar threadFinished_tmvar r + return jobs + labelThread tid "release_thread" + return Idle + +-- | When there are pending jobs but no free tokens, +-- spawn a thread to acquire a new token from the semaphore. +-- +-- See 'acquireThread'. +tryAcquire :: JobserverOptions + -> Jobserver + -> JobserverState + -> STM (IO JobserverState) +tryAcquire opts js@( Jobserver { jobs = jobs_tvar }) + st@( JobserverState { jobserverAction = Idle } ) + = do + jobs <- readTVar jobs_tvar + guard $ guardAcquire jobs + return do + action <- acquireThread js + -- Set a debounce after acquiring a token. + can_release_tvar <- registerDelay $ (releaseDebounce opts * 1000) + return $ st { jobserverAction = action + , canReleaseToken = can_release_tvar } +tryAcquire _ _ _ = retry + +-- | When there are free tokens and no pending jobs, +-- spawn a thread to release a token from the semaphore. +-- +-- See 'releaseThread'. +tryRelease :: Jobserver + -> JobserverState + -> STM (IO JobserverState) +tryRelease sjs@( Jobserver { jobs = jobs_tvar } ) + st@( JobserverState + { jobserverAction = Idle + , canReleaseToken = can_release_tvar } ) + = do + jobs <- readTVar jobs_tvar + guard $ guardRelease jobs + can_release <- readTVar can_release_tvar + guard can_release + return do + action <- releaseThread sjs + return $ st { jobserverAction = action } +tryRelease _ _ = retry + +-- | Wait for an active thread to finish. Once it finishes: +-- +-- - set the 'JobserverAction' to 'Idle', +-- - update the number of capabilities to reflect the number +-- of owned tokens from the semaphore. +tryNoticeIdle :: JobserverOptions + -> TVar JobResources + -> JobserverState + -> STM (IO JobserverState) +tryNoticeIdle opts jobs_tvar jobserver_state + | Just threadFinished_tmvar <- activeThread_maybe $ jobserverAction jobserver_state + = sync_num_caps (canChangeNumCaps jobserver_state) threadFinished_tmvar + | otherwise + = retry -- no active thread: wait until jobserver isn't idle + where + sync_num_caps :: TVar Bool + -> TMVar (Maybe MC.SomeException) + -> STM (IO JobserverState) + sync_num_caps can_change_numcaps_tvar threadFinished_tmvar = do + mb_ex <- takeTMVar threadFinished_tmvar + for_ mb_ex MC.throwM + Jobs { tokensOwned } <- readTVar jobs_tvar + can_change_numcaps <- readTVar can_change_numcaps_tvar + guard can_change_numcaps + return do + x <- getNumCapabilities + can_change_numcaps_tvar_2 <- + if x == tokensOwned + then return can_change_numcaps_tvar + else do + setNumCapabilities tokensOwned + registerDelay $ (setNumCapsDebounce opts * 1000) + return $ + jobserver_state + { jobserverAction = Idle + , canChangeNumCaps = can_change_numcaps_tvar_2 } + +-- | Try to stop the current thread which is acquiring/releasing resources +-- if that operation is no longer relevant. +tryStopThread :: TVar JobResources + -> JobserverState + -> STM (IO JobserverState) +tryStopThread jobs_tvar jsj = do + case jobserverAction jsj of + Acquiring { activeWaitId = wait_id } -> do + jobs <- readTVar jobs_tvar + guard $ null (jobsWaiting jobs) + return do + interruptWaitOnSemaphore wait_id + return $ jsj { jobserverAction = Idle } + _ -> retry + +-- | Main jobserver loop: acquire/release resources as +-- needed for the pending jobs and available semaphore tokens. +jobserverLoop :: JobserverOptions -> Jobserver -> IO () +jobserverLoop opts sjs@(Jobserver { jobs = jobs_tvar }) + = do + true_tvar <- newTVarIO True + let init_state :: JobserverState + init_state = + JobserverState + { jobserverAction = Idle + , canChangeNumCaps = true_tvar + , canReleaseToken = true_tvar } + loop init_state + where + loop s = do + action <- atomically $ asum $ (\x -> x s) <$> + [ tryRelease sjs + , tryAcquire opts sjs + , tryNoticeIdle opts jobs_tvar + , tryStopThread jobs_tvar + ] + s <- action + loop s + +-- | Create a new jobserver using the given semaphore handle. +makeJobserver :: SemaphoreName -> IO (AbstractSem, IO ()) +makeJobserver sem_name = do + semaphore <- openSemaphore sem_name + let + init_jobs = + Jobs { tokensOwned = 1 + , tokensFree = 1 + , jobsWaiting = NilOL + } + jobs_tvar <- newTVarIO init_jobs + let + opts = defaultJobserverOptions -- TODO: allow this to be configured + sjs = Jobserver { jSemaphore = semaphore + , jobs = jobs_tvar } + loop_finished_mvar <- newEmptyMVar + loop_tid <- forkIOWithUnmask \ unmask -> do + r <- try $ unmask $ jobserverLoop opts sjs + putMVar loop_finished_mvar $ + case r of + Left e + | Just ThreadKilled <- fromException e + -> Nothing + | otherwise + -> Just e + Right () -> Nothing + labelThread loop_tid "job_server" + let + acquireSem = acquireJob jobs_tvar + releaseSem = releaseJob jobs_tvar + cleanupSem = do + -- this is interruptible + cleanupJobserver sjs + killThread loop_tid + mb_ex <- takeMVar loop_finished_mvar + for_ mb_ex MC.throwM + + return (AbstractSem{..}, cleanupSem) + +-- | Implement an abstract semaphore using a semaphore 'Jobserver' +-- which queries the system semaphore of the given name for resources. +runJSemAbstractSem :: SemaphoreName -- ^ the system semaphore to use + -> (AbstractSem -> IO a) -- ^ the operation to run + -- which requires a semaphore + -> IO a +runJSemAbstractSem sem action = MC.mask \ unmask -> do + (abs, cleanup) <- makeJobserver sem + r <- try $ unmask $ action abs + case r of + Left (e1 :: MC.SomeException) -> do + (_ :: Either MC.SomeException ()) <- MC.try cleanup + MC.throwM e1 + Right x -> cleanup $> x + +{- Note [Architecture of the Job Server] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In `-jsem` mode, the amount of parallelism that GHC can use is controlled by a +system semaphore. We take resources from the semaphore when we need them, and +give them back if we don't have enough to do. + +A naive implementation would just take and release the semaphore around performing +the action, but this leads to two issues: + +* When taking a token in the semaphore, we must call `setNumCapabilities` in order + to adjust how many capabilities are available for parallel garbage collection. + This causes unnecessary synchronisations. +* We want to implement a debounce, so that whilst there is pending work in the + current process we prefer to keep hold of resources from the semaphore. + This reduces overall memory usage, as there are fewer live GHC processes at once. + +Therefore, the obtention of semaphore resources is separated away from the +request for the resource in the driver. + +A token from the semaphore is requested using `acquireJob`. This creates a pending +job, which is a MVar that can be filled in to signal that the requested token is ready. + +When the job is finished, the token is released by calling `releaseJob`, which just +increases the number of `free` jobs. If there are more pending jobs when the free count +is increased, the token is immediately reused (see `modifyJobResources`). + +The `jobServerLoop` interacts with the system semaphore: when there are pending +jobs, `acquireThread` blocks, waiting for a token from the semaphore. Once a +token is obtained, it increases the owned count. + +When GHC has free tokens (tokens from the semaphore that it is not using), +no pending jobs, and the debounce has expired, then `releaseThread` will +release tokens back to the global semaphore. + +`tryStopThread` attempts to kill threads which are waiting to acquire a resource +when we no longer need it. For example, consider that we attempt to acquire two +tokens, but the first job finishes before we acquire the second token. +This second token is no longer needed, so we should cancel the wait +(as it would not be used to do any work, and not be returned until the debounce). +We only need to kill `acquireJob`, because `releaseJob` never blocks. + +Note [Eventlog Messages for jsem] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +It can be tricky to verify that the work is shared adequately across different +processes. To help debug this, we output the values of `JobResource` to the +eventlog whenever the global state changes. There are some scripts which can be used +to analyse this output and report statistics about core saturation in the +GitHub repo (https://github.com/mpickering/ghc-jsem-analyse). + +-} 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, @@ -34,7 +36,7 @@ import GHC.Prelude -import GHC.Driver.Session +import GHC.Driver.DynFlags import GHC.Driver.Env import GHC.Driver.Errors ( printOrThrowDiagnostics, printMessages ) import GHC.Driver.Errors.Types @@ -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, UnknownDiagnostic (..) ) +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 @@ -111,12 +106,11 @@ import GHC.Unit import GHC.Unit.Env ---import GHC.Unit.Finder ---import GHC.Unit.State +import GHC.Unit.Finder 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 @@ -163,7 +158,7 @@ handler (ProgramError msg) = return $ Left $ singleMessage $ mkPlainErrorMsgEnvelope srcspan $ - DriverUnknownMessage $ UnknownDiagnostic $ mkPlainError noHints $ text msg + DriverUnknownMessage $ mkSimpleUnknownDiagnostic $ mkPlainError noHints $ text msg handler ex = throwGhcExceptionIO ex to_driver_messages :: Messages GhcMessage -> Messages DriverMessage @@ -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 @@ -352,6 +347,7 @@ link :: GhcLink -- ^ interactive or batch -> Logger -- ^ Logger -> TmpFs + -> FinderCache -> Hooks -> DynFlags -- ^ dynamic flags -> UnitEnv -- ^ unit environment @@ -367,7 +363,7 @@ -- exports main, i.e., we have good reason to believe that linking -- will succeed. -link ghcLink logger tmpfs hooks dflags unit_env batch_attempt_linking mHscMessage hpt = +link ghcLink logger tmpfs fc hooks dflags unit_env batch_attempt_linking mHscMessage hpt = case linkHook hooks of Nothing -> case ghcLink of NoLink -> return Succeeded @@ -383,7 +379,7 @@ -> panicBadLink LinkInMemory Just h -> h ghcLink dflags batch_attempt_linking hpt where - normal_link = link' logger tmpfs dflags unit_env batch_attempt_linking mHscMessage hpt + normal_link = link' logger tmpfs fc dflags unit_env batch_attempt_linking mHscMessage hpt panicBadLink :: GhcLink -> a @@ -392,6 +388,7 @@ link' :: Logger -> TmpFs + -> FinderCache -> DynFlags -- ^ dynamic flags -> UnitEnv -- ^ unit environment -> Bool -- ^ attempt linking in batch mode? @@ -399,7 +396,7 @@ -> HomePackageTable -- ^ what to link -> IO SuccessFlag -link' logger tmpfs dflags unit_env batch_attempt_linking mHscMessager hpt +link' logger tmpfs fc dflags unit_env batch_attempt_linking mHscMessager hpt | batch_attempt_linking = do let @@ -407,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)) @@ -428,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) @@ -446,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 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 @@ -463,14 +459,13 @@ return Succeeded -linkJSBinary :: Logger -> DynFlags -> UnitEnv -> [FilePath] -> [UnitId] -> IO () -linkJSBinary logger 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 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 @@ -478,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 @@ -487,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 @@ -512,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 @@ -542,6 +534,7 @@ -- In oneshot mode, initialise plugins specified on command line -- we also initialise in ghc/Main but this might be used as an entry point by API clients who -- should initialise their own plugins but may not. + -- See Note [Timing of plugin initialization] hsc_env <- initializePlugins orig_hsc_env o_files <- mapMaybeM (compileFile hsc_env stop_phase) srcs case stop_phase of @@ -584,12 +577,13 @@ logger = hsc_logger hsc_env unit_env = hsc_unit_env hsc_env tmpfs = hsc_tmpfs hsc_env + fc = hsc_FC hsc_env case ghcLink dflags of NoLink -> return () LinkBinary | backendUseJSLinker (backend dflags) - -> linkJSBinary logger 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 [] @@ -624,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 @@ -747,7 +738,7 @@ let print_config = initPrintConfig dflags3 liftIO (printOrThrowDiagnostics (hsc_logger hsc_env) print_config (initDiagOpts dflags3) (GhcPsMessage <$> p_warns3)) - liftIO (handleFlagWarnings (hsc_logger hsc_env) print_config (initDiagOpts dflags3) warns3) + liftIO (printOrThrowDiagnostics (hsc_logger hsc_env) print_config (initDiagOpts dflags3) (GhcDriverMessage <$> warns3)) return (dflags3, pp_fn) @@ -791,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 @@ -819,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) @@ -855,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 @@ -879,9 +888,8 @@ use (T_ForeignJs pipe_env hsc_env location input_fn) hscPostBackendPipeline :: P m => PipeEnv -> HscEnv -> HscSource -> Backend -> Maybe ModLocation -> FilePath -> m (Maybe FilePath) -hscPostBackendPipeline _ _ HsBootFile _ _ _ = return Nothing -hscPostBackendPipeline _ _ HsigFile _ _ _ = return Nothing -hscPostBackendPipeline pipe_env hsc_env _ bcknd ml input_fn = +hscPostBackendPipeline _ _ (HsBootOrSig _) _ _ _ = return Nothing +hscPostBackendPipeline pipe_env hsc_env HsSrcFile bcknd ml input_fn = applyPostHscPipeline (backendPostHscPipeline bcknd) pipe_env hsc_env ml input_fn applyPostHscPipeline @@ -928,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,18 +20,20 @@ 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 import GHC.Driver.Backend import GHC.Driver.Session -import GHC.Driver.CmdLine import GHC.Unit.Module.ModSummary 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 @@ -47,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 @@ -60,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 @@ -73,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 @@ -122,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 @@ -147,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) = @@ -284,21 +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, get_asm_info) = - ( applyAssemblerProg $ backendAssemblerProg (backend dflags) - , applyAssemblerInfoGetter $ backendAssemblerInfoGetter (backend dflags) - ) - asmInfo <- get_asm_info logger dflags platform - let cmdline_include_paths = includePaths dflags let pic_c_flags = picCCOpts dflags @@ -308,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] @@ -331,9 +331,6 @@ ++ [ GHC.SysTools.Option "-Wa,--no-type-check" | platformArch (targetPlatform dflags) == ArchWasm32] - ++ (if any (asmInfo ==) [Clang, AppleClang, AppleClang51] - then [GHC.SysTools.Option "-Qunused-arguments"] - else []) ++ [ GHC.SysTools.Option "-x" , if with_cpp then GHC.SysTools.Option "assembler-with-cpp" @@ -342,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] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -- @@ -378,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) @@ -400,41 +404,12 @@ embedJsFile logger dflags tmpfs unit_env input_fn output_fn return output_fn - -applyAssemblerInfoGetter - :: DefunctionalizedAssemblerInfoGetter - -> Logger -> DynFlags -> Platform -> IO CompilerInfo -applyAssemblerInfoGetter StandardAssemblerInfoGetter logger dflags _platform = - getAssemblerInfo logger dflags -applyAssemblerInfoGetter JSAssemblerInfoGetter _ _ _ = - pure Emscripten -applyAssemblerInfoGetter DarwinClangAssemblerInfoGetter logger dflags platform = - if platformOS platform == OSDarwin then - pure Clang - else - getAssemblerInfo logger dflags - -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 @@ -456,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 @@ -516,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 ( @@ -534,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) @@ -554,10 +525,9 @@ else []) ++ verbFlags ++ cc_opt - ++ [ "-include", ghcVersionH ] + ++ ghcVersionH ++ framework_paths ++ include_paths - ++ more_preprocessor_opts ++ pkg_extra_cc_opts )) @@ -590,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 @@ -616,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 @@ -646,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") @@ -661,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 @@ -683,13 +655,14 @@ return output_fn -getFileArgs :: HscEnv -> FilePath -> IO ((DynFlags, Messages PsMessage, [Warn])) +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) @@ -700,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 @@ -731,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 @@ -764,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 @@ -780,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 } @@ -789,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) @@ -807,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 @@ -837,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 @@ -989,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) @@ -1002,24 +972,32 @@ ++ [("", "-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 - - align :: Int - align = case platformArch platform of - ArchX86_64 | isAvxEnabled dflags -> 32 - _ -> 0 + arch = platformArch platform attrs :: String attrs = intercalate "," $ mattr - ++ ["+sse42" | isSse4_2Enabled dflags ] + ++ ["+sse4.2" | isSse4_2Enabled dflags ] + ++ ["+popcnt" | isSse4_2Enabled dflags ] + -- 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 ] @@ -1028,6 +1006,8 @@ ++ ["+avx512cd"| isAvx512cdEnabled dflags ] ++ ["+avx512er"| isAvx512erEnabled dflags ] ++ ["+avx512pf"| isAvx512pfEnabled dflags ] + -- For Arch64 +fma is not a option (it's unconditionally available). + ++ ["+fma" | isFmaEnabled dflags && (arch /= ArchAArch64) ] ++ ["+bmi" | isBmiEnabled dflags ] ++ ["+bmi2" | isBmi2Enabled dflags ] @@ -1039,9 +1019,8 @@ -- | What phase to run after one of the backend code generators has run hscPostBackendPhase :: HscSource -> Backend -> Phase -hscPostBackendPhase HsBootFile _ = StopLn -hscPostBackendPhase HsigFile _ = StopLn -hscPostBackendPhase _ bcknd = backendNormalSuccessorPhase bcknd +hscPostBackendPhase (HsBootOrSig _) _ = StopLn +hscPostBackendPhase HsSrcFile bcknd = backendNormalSuccessorPhase bcknd compileStub :: HscEnv -> FilePath -> IO FilePath @@ -1196,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/LogQueue.hs b/GHC/Driver/Pipeline/LogQueue.hs --- a/GHC/Driver/Pipeline/LogQueue.hs +++ b/GHC/Driver/Pipeline/LogQueue.hs @@ -100,10 +100,10 @@ Just ((k, v), lqq') | k == n -> Just (v, LogQueueQueue (n + 1) lqq') _ -> Nothing -logThread :: Int -> Int -> Logger -> TVar Bool -- Signal that no more new logs will be added, clear the queue and exit +logThread :: Logger -> TVar Bool -- Signal that no more new logs will be added, clear the queue and exit -> TVar LogQueueQueue -- Queue for logs -> IO (IO ()) -logThread _ _ logger stopped lqq_var = do +logThread logger stopped lqq_var = do finished_var <- newEmptyMVar _ <- forkIO $ print_logs *> putMVar finished_var () return (takeMVar finished_var) 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 @@ -6,8 +6,7 @@ import GHC.Prelude import GHC.Driver.Pipeline.Monad import GHC.Driver.Env.Types -import GHC.Driver.Session -import GHC.Driver.CmdLine +import GHC.Driver.DynFlags import GHC.Types.SourceFile import GHC.Unit.Module.ModSummary import GHC.Unit.Module.Status @@ -29,7 +28,7 @@ -- phase if the inputs have been modified. data TPhase res where T_Unlit :: PipeEnv -> HscEnv -> FilePath -> TPhase FilePath - T_FileArgs :: HscEnv -> FilePath -> TPhase (DynFlags, Messages PsMessage, [Warn]) + T_FileArgs :: HscEnv -> FilePath -> TPhase (DynFlags, Messages PsMessage, Messages DriverMessage) T_Cpp :: PipeEnv -> HscEnv -> FilePath -> TPhase FilePath T_HsPp :: PipeEnv -> HscEnv -> FilePath -> FilePath -> TPhase FilePath T_HscRecomp :: PipeEnv -> HscEnv -> FilePath -> HscSource -> TPhase (HscEnv, ModSummary, HscRecompStatus) @@ -48,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' @@ -82,15 +86,17 @@ import qualified GHC.Tc.Types import GHC.Tc.Types ( TcGblEnv, IfM, TcM, tcg_rn_decls, tcg_rn_exports ) -import GHC.Tc.Errors.Hole.FitTypes ( HoleFitPluginR ) +import GHC.Tc.Errors.Hole.Plugin ( HoleFitPluginR ) import GHC.Core.Opt.Monad ( CoreM ) import GHC.Core.Opt.Pipeline.Types ( CoreToDo ) 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 @@ -405,12 +422,12 @@ loadExternalPluginLib path = do -- load library loadDLL path >>= \case - Just errmsg -> pprPanic "loadExternalPluginLib" - (vcat [ text "Can't load plugin library" - , text " Library path: " <> text path - , text " Error : " <> text errmsg - ]) - Nothing -> do + Left errmsg -> pprPanic "loadExternalPluginLib" + (vcat [ text "Can't load plugin library" + , text " Library path: " <> text path + , text " Error : " <> text errmsg + ]) + Right _ -> do -- resolve objects resolveObjs >>= \case True -> return () diff --git a/GHC/Driver/Ppr.hs b/GHC/Driver/Ppr.hs --- a/GHC/Driver/Ppr.hs +++ b/GHC/Driver/Ppr.hs @@ -6,12 +6,13 @@ , showPpr , showPprUnsafe , printForUser + , printForUserColoured ) where import GHC.Prelude -import GHC.Driver.Session +import GHC.Driver.DynFlags import GHC.Unit.State import GHC.Utils.Outputable @@ -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,5072 +17,3805 @@ -- ------------------------------------------------------------------------------- -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} - -module GHC.Driver.Session ( - -- * Dynamic flags and associated configuration types - DumpFlag(..), - GeneralFlag(..), - WarningFlag(..), DiagnosticReason(..), - Language(..), - FatalMessager, FlushOut(..), - ProfAuto(..), - glasgowExtsFlags, - hasPprDebug, hasNoDebugOutput, hasNoStateHack, hasNoOptCoercion, - dopt, dopt_set, dopt_unset, - gopt, gopt_set, gopt_unset, setGeneralFlag', unSetGeneralFlag', - wopt, wopt_set, wopt_unset, - wopt_fatal, wopt_set_fatal, wopt_unset_fatal, - xopt, xopt_set, xopt_unset, - xopt_set_unlessExplSpec, - xopt_DuplicateRecordFields, - xopt_FieldSelectors, - lang_set, - DynamicTooState(..), dynamicTooState, setDynamicNow, - sccProfilingEnabled, - needSourceNotes, - OnOff(..), - DynFlags(..), - outputFile, objectSuf, ways, - FlagSpec(..), - HasDynFlags(..), ContainsDynFlags(..), - RtsOptsEnabled(..), - GhcMode(..), isOneShot, - GhcLink(..), isNoLink, - PackageFlag(..), PackageArg(..), ModRenaming(..), - packageFlagsChanged, - IgnorePackageFlag(..), TrustFlag(..), - PackageDBFlag(..), PkgDbRef(..), - Option(..), showOpt, - DynLibLoader(..), - fFlags, fLangFlags, xFlags, - wWarningFlags, - makeDynFlagsConsistent, - positionIndependent, - optimisationFlags, - codeGenFlags, - setFlagsFromEnvFile, - pprDynFlagsDiff, - flagSpecOf, - - targetProfile, - - -- ** Safe Haskell - safeHaskellOn, safeHaskellModeEnabled, - safeImportsOn, safeLanguageOn, safeInferOn, - packageTrustOn, - safeDirectImpsReq, safeImplicitImpsReq, - unsafeFlags, unsafeFlagsForInfer, - - -- ** System tool settings and locations - Settings(..), - sProgramName, - sProjectVersion, - sGhcUsagePath, - sGhciUsagePath, - sToolDir, - sTopDir, - sGlobalPackageDatabasePath, - sLdSupportsCompactUnwind, - sLdSupportsFilelist, - sLdIsGnuLd, - sGccSupportsNoPie, - sPgm_L, - sPgm_P, - sPgm_F, - sPgm_c, - sPgm_cxx, - sPgm_a, - sPgm_l, - sPgm_lm, - sPgm_dll, - sPgm_T, - sPgm_windres, - sPgm_ar, - sPgm_ranlib, - sPgm_lo, - sPgm_lc, - sPgm_lcc, - sPgm_i, - sOpt_L, - sOpt_P, - sOpt_P_fingerprint, - sOpt_F, - sOpt_c, - sOpt_cxx, - sOpt_a, - sOpt_l, - sOpt_lm, - sOpt_windres, - sOpt_lo, - sOpt_lc, - sOpt_lcc, - sOpt_i, - sExtraGccViaCFlags, - sTargetPlatformString, - sGhcWithInterpreter, - sLibFFI, - GhcNameVersion(..), - FileSettings(..), - PlatformMisc(..), - settings, - programName, projectVersion, - 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, - updatePlatformConstants, - - -- ** Manipulating DynFlags - addPluginModuleName, - defaultDynFlags, -- Settings -> DynFlags - initDynFlags, -- DynFlags -> IO DynFlags - defaultFatalMessager, - defaultFlushOut, - setOutputFile, setDynOutputFile, setOutputHi, setDynOutputHi, - augmentByWorkingDirectory, - - getOpts, -- DynFlags -> (DynFlags -> [a]) -> [a] - getVerbFlags, - updOptLevel, - setTmpDir, - setUnitId, - - TurnOnFlag, - turnOn, - turnOff, - impliedGFlags, - impliedOffGFlags, - impliedXFlags, - - -- ** State - CmdLineP(..), runCmdLineP, - getCmdLineState, putCmdLineState, - processCmdLineP, - - -- ** Parsing DynFlags - parseDynamicFlagsCmdLine, - parseDynamicFilePragma, - parseDynamicFlagsFull, - - -- ** Available DynFlags - allNonDeprecatedFlags, - flagsAll, - flagsDynamic, - flagsPackage, - flagsForCompletion, - - supportedLanguagesAndExtensions, - languageExtensions, - - -- ** DynFlags C compiler options - picCCOpts, picPOpts, - - -- ** DynFlags C linker options - pieCCLDOpts, - - -- * Compiler configuration suitable for display to the user - compilerInfo, - - wordAlignment, - - setUnsafeGlobalDynFlags, - - -- * SSE and AVX - isSse4_2Enabled, - isBmiEnabled, - isBmi2Enabled, - isAvxEnabled, - isAvx2Enabled, - isAvx512cdEnabled, - isAvx512erEnabled, - isAvx512fEnabled, - isAvx512pfEnabled, - - -- * Linker/compiler information - LinkerInfo(..), - CompilerInfo(..), - useXLinkerRPath, - - -- * Include specifications - IncludeSpecs(..), addGlobalInclude, addQuoteInclude, flattenIncludes, - addImplicitQuoteInclude, - - -- * SDoc - initSDocContext, initDefaultSDocContext, - initPromotionTickContext, - ) where - -import GHC.Prelude - -import GHC.Platform -import GHC.Platform.Ways -import GHC.Platform.Profile - -import GHC.UniqueSubdir (uniqueSubdir) -import GHC.Unit.Types -import GHC.Unit.Parser -import GHC.Unit.Module -import GHC.Builtin.Names ( mAIN_NAME ) -import GHC.Driver.Phases ( Phase(..), phaseInputExt ) -import GHC.Driver.Flags -import GHC.Driver.Backend -import GHC.Driver.Plugins.External -import GHC.Settings.Config -import GHC.Utils.CliOption -import GHC.Core.Unfold -import GHC.Driver.CmdLine -import GHC.Settings.Constants -import GHC.Utils.Panic -import qualified GHC.Utils.Ppr.Colour as Col -import GHC.Utils.Misc -import GHC.Utils.Constants (debugIsOn) -import GHC.Utils.GlobalVars -import GHC.Data.Maybe -import GHC.Data.Bool -import GHC.Utils.Monad -import GHC.Types.Error (DiagnosticReason(..)) -import GHC.Types.SrcLoc -import GHC.Types.SafeHaskell -import GHC.Types.Basic ( IntWithInf, treatZeroAsInf ) -import GHC.Types.ProfAuto -import qualified GHC.Types.FieldLabel as FieldLabel -import GHC.Data.FastString -import GHC.Utils.TmpFs -import GHC.Utils.Fingerprint -import GHC.Utils.Outputable -import GHC.Settings -import GHC.CmmToAsm.CFG.Weight -import {-# SOURCE #-} GHC.Core.Opt.CallerCC - -import GHC.SysTools.Terminal ( stderrSupportsAnsiColors ) -import GHC.SysTools.BaseDir ( expandToolDir, expandTopDir ) - -import Data.IORef -import Control.Arrow ((&&&)) -import Control.Monad -import Control.Monad.Trans.Class -import Control.Monad.Trans.Writer -import Control.Monad.Trans.Reader -import Control.Monad.Trans.Except -import Control.Monad.Trans.State as State -import Data.Functor.Identity - -import Data.Ord -import Data.Char -import Data.List (intercalate, sortBy) -import qualified Data.List.NonEmpty as NE -import qualified Data.Map as Map -import qualified Data.Set as Set -import Data.Word -import System.FilePath -import System.Directory -import System.Environment (lookupEnv) -import System.IO -import System.IO.Error -import Text.ParserCombinators.ReadP hiding (char) -import Text.ParserCombinators.ReadP as R - -import GHC.Data.EnumSet (EnumSet) -import qualified GHC.Data.EnumSet as EnumSet - -import GHC.Foreign (withCString, peekCString) -import qualified GHC.LanguageExtensions as LangExt - --- Note [Updating flag description in the User's Guide] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- --- If you modify anything in this file please make sure that your changes are --- described in the User's Guide. Please update the flag description in the --- users guide (docs/users_guide) whenever you add or change a flag. --- Please make sure you add ":since:" information to new flags. - --- Note [Supporting CLI completion] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- --- The command line interface completion (in for example bash) is an easy way --- for the developer to learn what flags are available from GHC. --- GHC helps by separating which flags are available when compiling with GHC, --- and which flags are available when using GHCi. --- A flag is assumed to either work in both these modes, or only in one of them. --- When adding or changing a flag, please consider for which mode the flag will --- have effect, and annotate it accordingly. For Flags use defFlag, defGhcFlag, --- defGhciFlag, and for FlagSpec use flagSpec or flagGhciSpec. - --- Note [Adding a language extension] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- --- There are a few steps to adding (or removing) a language extension, --- --- * Adding the extension to GHC.LanguageExtensions --- --- The Extension type in libraries/ghc-boot-th/GHC/LanguageExtensions/Type.hs --- is the canonical list of language extensions known by GHC. --- --- * Adding a flag to DynFlags.xFlags --- --- This is fairly self-explanatory. The name should be concise, memorable, --- and consistent with any previous implementations of the similar idea in --- other Haskell compilers. --- --- * Adding the flag to the documentation --- --- This is the same as any other flag. See --- Note [Updating flag description in the User's Guide] --- --- * Adding the flag to Cabal --- --- The Cabal library has its own list of all language extensions supported --- by all major compilers. This is the list that user code being uploaded --- to Hackage is checked against to ensure language extension validity. --- Consequently, it is very important that this list remains up-to-date. --- --- To this end, there is a testsuite test (testsuite/tests/driver/T4437.hs) --- whose job it is to ensure these GHC's extensions are consistent with --- Cabal. --- --- The recommended workflow is, --- --- 1. Temporarily add your new language extension to the --- expectedGhcOnlyExtensions list in T4437 to ensure the test doesn't --- break while Cabal is updated. --- --- 2. After your GHC change is accepted, submit a Cabal pull request adding --- your new extension to Cabal's list (found in --- Cabal/Language/Haskell/Extension.hs). --- --- 3. After your Cabal change is accepted, let the GHC developers know so --- they can update the Cabal submodule and remove the extensions from --- expectedGhcOnlyExtensions. --- --- * Adding the flag to the GHC Wiki --- --- There is a change log tracking language extension additions and removals --- on the GHC wiki: https://gitlab.haskell.org/ghc/ghc/wikis/language-pragma-history --- --- See #4437 and #8176. - --- ----------------------------------------------------------------------------- --- DynFlags - --- | 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 - -{- Note [Implicit include paths] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - The compile driver adds the path to the folder containing the source file being - compiled to the 'IncludeSpecs', and this change gets recorded in the 'DynFlags' - that are used later to compute the interface file. Because of this, - the flags fingerprint derived from these 'DynFlags' and recorded in the - interface file will end up containing the absolute path to the source folder. - - Build systems with a remote cache like Bazel or Buck (or Shake, see #16956) - store the build artifacts produced by a build BA for reuse in subsequent builds. - - Embedding source paths in interface fingerprints will thwart these attempts and - lead to unnecessary recompilations when the source paths in BA differ from the - source paths in subsequent builds. - -} - - --- | Contains not only a collection of 'GeneralFlag's but also a plethora of --- information relating to the compilation of a single file or GHC session -data DynFlags = DynFlags { - ghcMode :: GhcMode, - ghcLink :: GhcLink, - backend :: !Backend, - -- ^ The backend to use (if any). - -- - -- Whenever you change the backend, also make sure to set 'ghcLink' to - -- something sensible. - -- - -- 'NoBackend' can be used to avoid generating any output, however, note that: - -- - -- * If a program uses Template Haskell the typechecker may need to run code - -- from an imported module. To facilitate this, code generation is enabled - -- for modules imported by modules that use template haskell, using the - -- default backend for the platform. - -- See Note [-fno-code mode]. - - - -- formerly Settings - ghcNameVersion :: {-# UNPACK #-} !GhcNameVersion, - fileSettings :: {-# UNPACK #-} !FileSettings, - targetPlatform :: Platform, -- Filled in by SysTools - toolSettings :: {-# UNPACK #-} !ToolSettings, - platformMisc :: {-# UNPACK #-} !PlatformMisc, - rawSettings :: [(String, String)], - tmpDir :: TempDir, - - llvmOptLevel :: Int, -- ^ LLVM optimisation level - verbosity :: Int, -- ^ Verbosity level: see Note [Verbosity levels] - debugLevel :: Int, -- ^ How much debug information to produce - simplPhases :: Int, -- ^ Number of simplifier phases - maxSimplIterations :: Int, -- ^ Max simplifier iterations - ruleCheck :: Maybe String, - strictnessBefore :: [Int], -- ^ Additional demand analysis - - parMakeCount :: Maybe Int, -- ^ The number of modules to compile in parallel - -- in --make mode, where Nothing ==> compile as - -- many in parallel as there are CPUs. - - enableTimeStats :: Bool, -- ^ Enable RTS timing statistics? - ghcHeapSize :: Maybe Int, -- ^ The heap size to set. - - maxRelevantBinds :: Maybe Int, -- ^ Maximum number of bindings from the type envt - -- to show in type error messages - maxValidHoleFits :: Maybe Int, -- ^ Maximum number of hole fits to show - -- in typed hole error messages - maxRefHoleFits :: Maybe Int, -- ^ Maximum number of refinement hole - -- fits to show in typed hole error - -- messages - refLevelHoleFits :: Maybe Int, -- ^ Maximum level of refinement for - -- refinement hole fits in typed hole - -- error messages - maxUncoveredPatterns :: Int, -- ^ Maximum number of unmatched patterns to show - -- in non-exhaustiveness warnings - maxPmCheckModels :: Int, -- ^ Soft limit on the number of models - -- the pattern match checker checks - -- a pattern against. A safe guard - -- against exponential blow-up. - simplTickFactor :: Int, -- ^ Multiplier for simplifier ticks - dmdUnboxWidth :: !Int, -- ^ Whether DmdAnal should optimistically put an - -- Unboxed demand on returned products with at most - -- this number of fields - 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 - -- Not optional; otherwise ForceSpecConstr can diverge. - binBlobThreshold :: Maybe Word, -- ^ Binary literals (e.g. strings) whose size is above - -- this threshold will be dumped in a binary file - -- by the assembler code generator. 0 and Nothing disables - -- this feature. See 'GHC.StgToCmm.Config'. - liberateCaseThreshold :: Maybe Int, -- ^ Threshold for LiberateCase - floatLamArgs :: Maybe Int, -- ^ Arg count for lambda floating - -- See 'GHC.Core.Opt.Monad.FloatOutSwitches' - - liftLamsRecArgs :: Maybe Int, -- ^ Maximum number of arguments after lambda lifting a - -- recursive function. - liftLamsNonRecArgs :: Maybe Int, -- ^ Maximum number of arguments after lambda lifting a - -- non-recursive function. - liftLamsKnown :: Bool, -- ^ Lambda lift even when this turns a known call - -- into an unknown call. - - cmmProcAlignment :: Maybe Int, -- ^ Align Cmm functions at this boundary or use default. - - historySize :: Int, -- ^ Simplification history size - - importPaths :: [FilePath], - mainModuleNameIs :: ModuleName, - mainFunIs :: Maybe String, - reductionDepth :: IntWithInf, -- ^ Typechecker maximum stack depth - solverIterations :: IntWithInf, -- ^ Number of iterations in the constraints solver - -- Typically only 1 is needed - - homeUnitId_ :: UnitId, -- ^ Target home unit-id - homeUnitInstanceOf_ :: Maybe UnitId, -- ^ Id of the unit to instantiate - homeUnitInstantiations_ :: [(ModuleName, Module)], -- ^ Module instantiations - - -- Note [Filepaths and Multiple Home Units] - workingDirectory :: Maybe FilePath, - thisPackageName :: Maybe String, -- ^ What the package is called, use with multiple home units - hiddenModules :: Set.Set ModuleName, - reexportedModules :: Set.Set ModuleName, - - -- ways - targetWays_ :: Ways, -- ^ Target way flags from the command line - - -- For object splitting - splitInfo :: Maybe (String,Int), - - -- paths etc. - objectDir :: Maybe String, - dylibInstallName :: Maybe String, - hiDir :: Maybe String, - hieDir :: Maybe String, - stubDir :: Maybe String, - dumpDir :: Maybe String, - - objectSuf_ :: String, - hcSuf :: String, - hiSuf_ :: String, - hieSuf :: String, - - dynObjectSuf_ :: String, - dynHiSuf_ :: String, - - outputFile_ :: Maybe String, - dynOutputFile_ :: Maybe String, - outputHi :: Maybe String, - dynOutputHi :: Maybe String, - dynLibLoader :: DynLibLoader, - - dynamicNow :: !Bool, -- ^ Indicate if we are now generating dynamic output - -- because of -dynamic-too. This predicate is - -- used to query the appropriate fields - -- (outputFile/dynOutputFile, ways, etc.) - - -- | This defaults to 'non-module'. It can be set by - -- 'GHC.Driver.Pipeline.setDumpPrefix' or 'ghc.GHCi.UI.runStmt' based on - -- where its output is going. - dumpPrefix :: FilePath, - - -- | Override the 'dumpPrefix' set by 'GHC.Driver.Pipeline.setDumpPrefix' - -- or 'ghc.GHCi.UI.runStmt'. - -- Set by @-ddump-file-prefix@ - dumpPrefixForce :: Maybe FilePath, - - ldInputs :: [Option], - - includePaths :: IncludeSpecs, - libraryPaths :: [String], - frameworkPaths :: [String], -- used on darwin only - cmdlineFrameworks :: [String], -- ditto - - rtsOpts :: Maybe String, - rtsOptsEnabled :: RtsOptsEnabled, - rtsOptsSuggestions :: Bool, - - hpcDir :: String, -- ^ Path to store the .mix files - - -- Plugins - pluginModNames :: [ModuleName], - -- ^ the @-fplugin@ flags given on the command line, in *reverse* - -- order that they're specified on the command line. - pluginModNameOpts :: [(ModuleName,String)], - frontendPluginOpts :: [String], - -- ^ the @-ffrontend-opt@ flags given on the command line, in *reverse* - -- order that they're specified on the command line. - - externalPluginSpecs :: [ExternalPluginSpec], - -- ^ External plugins loaded from shared libraries - - -- For ghc -M - depMakefile :: FilePath, - depIncludePkgDeps :: Bool, - depIncludeCppDeps :: Bool, - depExcludeMods :: [ModuleName], - depSuffixes :: [String], - - -- Package flags - packageDBFlags :: [PackageDBFlag], - -- ^ The @-package-db@ flags given on the command line, In - -- *reverse* order that they're specified on the command line. - -- This is intended to be applied with the list of "initial" - -- package databases derived from @GHC_PACKAGE_PATH@; see - -- 'getUnitDbRefs'. - - ignorePackageFlags :: [IgnorePackageFlag], - -- ^ The @-ignore-package@ flags from the command line. - -- In *reverse* order that they're specified on the command line. - packageFlags :: [PackageFlag], - -- ^ The @-package@ and @-hide-package@ flags from the command-line. - -- In *reverse* order that they're specified on the command line. - pluginPackageFlags :: [PackageFlag], - -- ^ The @-plugin-package-id@ flags from command line. - -- In *reverse* order that they're specified on the command line. - trustFlags :: [TrustFlag], - -- ^ The @-trust@ and @-distrust@ flags. - -- In *reverse* order that they're specified on the command line. - packageEnv :: Maybe FilePath, - -- ^ Filepath to the package environment file (if overriding default) - - - -- hsc dynamic flags - dumpFlags :: EnumSet DumpFlag, - generalFlags :: EnumSet GeneralFlag, - warningFlags :: EnumSet WarningFlag, - fatalWarningFlags :: EnumSet WarningFlag, - -- Don't change this without updating extensionFlags: - language :: Maybe Language, - -- | Safe Haskell mode - safeHaskell :: SafeHaskellMode, - safeInfer :: Bool, - safeInferred :: Bool, - -- We store the location of where some extension and flags were turned on so - -- we can produce accurate error messages when Safe Haskell fails due to - -- them. - thOnLoc :: SrcSpan, - newDerivOnLoc :: SrcSpan, - deriveViaOnLoc :: SrcSpan, - overlapInstLoc :: SrcSpan, - incoherentOnLoc :: SrcSpan, - pkgTrustOnLoc :: SrcSpan, - warnSafeOnLoc :: SrcSpan, - warnUnsafeOnLoc :: SrcSpan, - trustworthyOnLoc :: SrcSpan, - -- Don't change this without updating extensionFlags: - -- Here we collect the settings of the language extensions - -- from the command line, the ghci config file and - -- from interactive :set / :seti commands. - extensions :: [OnOff LangExt.Extension], - -- extensionFlags should always be equal to - -- flattenExtensionFlags language extensions - -- LangExt.Extension is defined in libraries/ghc-boot so that it can be used - -- by template-haskell - extensionFlags :: EnumSet LangExt.Extension, - - -- | Unfolding control - -- See Note [Discounts and thresholds] in GHC.Core.Unfold - unfoldingOpts :: !UnfoldingOpts, - - maxWorkerArgs :: Int, - - ghciHistSize :: Int, - - flushOut :: FlushOut, - - ghcVersionFile :: Maybe FilePath, - haddockOptions :: Maybe String, - - -- | GHCi scripts specified by -ghci-script, in reverse order - ghciScripts :: [String], - - -- Output style options - pprUserLength :: Int, - pprCols :: Int, - - useUnicode :: Bool, - useColor :: OverridingBool, - canUseColor :: Bool, - colScheme :: Col.Scheme, - - -- | what kind of {-# SCC #-} to add automatically - profAuto :: ProfAuto, - callerCcFilters :: [CallerCcFilter], - - interactivePrint :: Maybe String, - - -- | Machine dependent flags (-m\ stuff) - sseVersion :: Maybe SseVersion, - bmiVersion :: Maybe BmiVersion, - avx :: Bool, - avx2 :: Bool, - avx512cd :: Bool, -- Enable AVX-512 Conflict Detection Instructions. - avx512er :: Bool, -- Enable AVX-512 Exponential and Reciprocal Instructions. - avx512f :: Bool, -- Enable AVX-512 instructions. - avx512pf :: Bool, -- Enable AVX-512 PreFetch 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. - maxInlineAllocSize :: Int, - - -- | Only inline memcpy if it generates no more than this many - -- pseudo (roughly: Cmm) instructions. - maxInlineMemcpyInsns :: Int, - - -- | Only inline memset if it generates no more than this many - -- pseudo (roughly: Cmm) instructions. - maxInlineMemsetInsns :: Int, - - -- | Reverse the order of error messages in GHC/GHCi - reverseErrors :: Bool, - - -- | Limit the maximum number of errors to show - maxErrors :: Maybe Int, - - -- | Unique supply configuration for testing build determinism - initialUnique :: Word64, - uniqueIncrement :: Int, - -- 'Int' because it can be used to test uniques in decreasing order. - - -- | Temporary: CFG Edge weights for fast iterations - cfgWeights :: Weights -} - -{- Note [RHS Floating] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - We provide both 'Opt_LocalFloatOut' and 'Opt_LocalFloatOutTopLevel' to correspond to - 'doFloatFromRhs'; with this we can control floating out with GHC flags. - - This addresses https://gitlab.haskell.org/ghc/ghc/-/issues/13663 and - allows for experimentation. --} - -class HasDynFlags m where - getDynFlags :: m DynFlags - -{- It would be desirable to have the more generalised - - instance (MonadTrans t, Monad m, HasDynFlags m) => HasDynFlags (t m) where - getDynFlags = lift getDynFlags - -instance definition. However, that definition would overlap with the -`HasDynFlags (GhcT m)` instance. Instead we define instances for a -couple of common Monad transformers explicitly. -} - -instance (Monoid a, Monad m, HasDynFlags m) => HasDynFlags (WriterT a m) where - getDynFlags = lift getDynFlags - -instance (Monad m, HasDynFlags m) => HasDynFlags (ReaderT a m) where - getDynFlags = lift getDynFlags - -instance (Monad m, HasDynFlags m) => HasDynFlags (MaybeT m) where - getDynFlags = lift getDynFlags - -instance (Monad m, HasDynFlags m) => HasDynFlags (ExceptT e m) where - getDynFlags = lift getDynFlags - -class ContainsDynFlags t where - extractDynFlags :: t -> DynFlags - ------------------------------------------------------------------------------ --- Accessors from 'DynFlags' - --- | "unbuild" a 'Settings' from a 'DynFlags'. This shouldn't be needed in the --- vast majority of code. But GHCi questionably uses this to produce a default --- 'DynFlags' from which to compute a flags diff for printing. -settings :: DynFlags -> Settings -settings dflags = Settings - { sGhcNameVersion = ghcNameVersion dflags - , sFileSettings = fileSettings dflags - , sTargetPlatform = targetPlatform dflags - , sToolSettings = toolSettings dflags - , sPlatformMisc = platformMisc dflags - , sRawSettings = rawSettings dflags - } - -programName :: DynFlags -> String -programName dflags = ghcNameVersion_programName $ ghcNameVersion dflags -projectVersion :: DynFlags -> String -projectVersion dflags = ghcNameVersion_projectVersion (ghcNameVersion dflags) -ghcUsagePath :: DynFlags -> FilePath -ghcUsagePath dflags = fileSettings_ghcUsagePath $ fileSettings dflags -ghciUsagePath :: DynFlags -> FilePath -ghciUsagePath dflags = fileSettings_ghciUsagePath $ fileSettings dflags -toolDir :: DynFlags -> Maybe FilePath -toolDir dflags = fileSettings_toolDir $ fileSettings dflags -topDir :: DynFlags -> FilePath -topDir dflags = fileSettings_topDir $ fileSettings dflags -extraGccViaCFlags :: DynFlags -> [String] -extraGccViaCFlags dflags = toolSettings_extraGccViaCFlags $ toolSettings dflags -globalPackageDatabasePath :: DynFlags -> FilePath -globalPackageDatabasePath dflags = fileSettings_globalPackageDatabase $ fileSettings dflags -pgm_L :: DynFlags -> String -pgm_L dflags = toolSettings_pgm_L $ toolSettings dflags -pgm_P :: DynFlags -> (String,[Option]) -pgm_P dflags = toolSettings_pgm_P $ 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_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 -pgm_ranlib dflags = toolSettings_pgm_ranlib $ toolSettings dflags -pgm_lo :: DynFlags -> (String,[Option]) -pgm_lo dflags = toolSettings_pgm_lo $ toolSettings dflags -pgm_lc :: DynFlags -> (String,[Option]) -pgm_lc dflags = toolSettings_pgm_lc $ toolSettings dflags -pgm_i :: DynFlags -> String -pgm_i dflags = toolSettings_pgm_i $ toolSettings dflags -opt_L :: DynFlags -> [String] -opt_L dflags = toolSettings_opt_L $ toolSettings dflags -opt_P :: DynFlags -> [String] -opt_P dflags = concatMap (wayOptP (targetPlatform dflags)) (ways dflags) - ++ toolSettings_opt_P (toolSettings dflags) - --- This function packages everything that's needed to fingerprint opt_P --- flags. See Note [Repeated -optP hashing]. -opt_P_signature :: DynFlags -> ([String], Fingerprint) -opt_P_signature dflags = - ( concatMap (wayOptP (targetPlatform dflags)) (ways dflags) - , toolSettings_opt_P_fingerprint $ toolSettings dflags - ) - -opt_F :: DynFlags -> [String] -opt_F dflags= toolSettings_opt_F $ toolSettings dflags -opt_c :: DynFlags -> [String] -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_a :: DynFlags -> [String] -opt_a dflags= toolSettings_opt_a $ toolSettings dflags -opt_l :: DynFlags -> [String] -opt_l dflags = concatMap (wayOptl (targetPlatform dflags)) (ways dflags) - ++ toolSettings_opt_l (toolSettings dflags) -opt_lm :: DynFlags -> [String] -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_i :: DynFlags -> [String] -opt_i dflags= toolSettings_opt_i $ toolSettings dflags - --- | The directory for this version of ghc in the user's app directory --- The appdir used to be in ~/.ghc but to respect the XDG specification --- we want to move it under $XDG_DATA_HOME/ --- However, old tooling (like cabal) might still write package environments --- to the old directory, so we prefer that if a subdirectory of ~/.ghc --- with the correct target and GHC version suffix exists. --- --- i.e. if ~/.ghc/$UNIQUE_SUBDIR exists we use that --- otherwise we use $XDG_DATA_HOME/$UNIQUE_SUBDIR --- --- UNIQUE_SUBDIR is typically a combination of the target platform and GHC version -versionedAppDir :: String -> ArchOS -> MaybeT IO FilePath -versionedAppDir appname platform = do - -- Make sure we handle the case the HOME isn't set (see #11678) - -- We need to fallback to the old scheme if the subdirectory exists. - msum $ map (checkIfExists <=< fmap ( versionedFilePath platform)) - [ tryMaybeT $ getAppUserDataDirectory appname -- this is ~/.ghc/ - , tryMaybeT $ getXdgDirectory XdgData appname -- this is $XDG_DATA_HOME/ - ] - where - checkIfExists dir = tryMaybeT (doesDirectoryExist dir) >>= \case - True -> pure dir - False -> MaybeT (pure Nothing) - -versionedFilePath :: ArchOS -> FilePath -versionedFilePath platform = uniqueSubdir platform - --- | 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 --- the "GHC.Unit.Finder": in one-shot mode we look for interface files for --- imported modules, but in multi-module mode we look for source files --- in order to check whether they need to be recompiled. -data GhcMode - = CompManager -- ^ @\-\-make@, GHCi, etc. - | OneShot -- ^ @ghc -c Foo.hs@ - | MkDepend -- ^ @ghc -M@, see "GHC.Unit.Finder" for why we need this - deriving Eq - -instance Outputable GhcMode where - ppr CompManager = text "CompManager" - ppr OneShot = text "OneShot" - ppr MkDepend = text "MkDepend" - -isOneShot :: GhcMode -> Bool -isOneShot OneShot = True -isOneShot _other = False - --- | What to do in the link step, if there is one. -data GhcLink - = NoLink -- ^ Don't link at all - | LinkBinary -- ^ Link object code into a binary - | LinkInMemory -- ^ Use the in-memory dynamic linker (works for both - -- bytecode and object code). - | LinkDynLib -- ^ Link objects into a dynamic lib (DLL on Windows, DSO on ELF platforms) - | LinkStaticLib -- ^ Link objects into a static lib - | LinkMergedObj -- ^ Link objects into a merged "GHCi object" - deriving (Eq, Show) - -isNoLink :: GhcLink -> Bool -isNoLink NoLink = True -isNoLink _ = False - --- | We accept flags which make packages visible, but how they select --- the package varies; this data type reflects what selection criterion --- is used. -data PackageArg = - PackageArg String -- ^ @-package@, by 'PackageName' - | UnitIdArg Unit -- ^ @-package-id@, by 'Unit' - deriving (Eq, Show) - -instance Outputable PackageArg where - ppr (PackageArg pn) = text "package" <+> text pn - ppr (UnitIdArg uid) = text "unit" <+> ppr uid - --- | Represents the renaming that may be associated with an exposed --- package, e.g. the @rns@ part of @-package "foo (rns)"@. --- --- Here are some example parsings of the package flags (where --- a string literal is punned to be a 'ModuleName': --- --- * @-package foo@ is @ModRenaming True []@ --- * @-package foo ()@ is @ModRenaming False []@ --- * @-package foo (A)@ is @ModRenaming False [("A", "A")]@ --- * @-package foo (A as B)@ is @ModRenaming False [("A", "B")]@ --- * @-package foo with (A as B)@ is @ModRenaming True [("A", "B")]@ -data ModRenaming = ModRenaming { - modRenamingWithImplicit :: Bool, -- ^ Bring all exposed modules into scope? - modRenamings :: [(ModuleName, ModuleName)] -- ^ Bring module @m@ into scope - -- under name @n@. - } deriving (Eq) -instance Outputable ModRenaming where - ppr (ModRenaming b rns) = ppr b <+> parens (ppr rns) - --- | Flags for manipulating the set of non-broken packages. -newtype IgnorePackageFlag = IgnorePackage String -- ^ @-ignore-package@ - deriving (Eq) - --- | Flags for manipulating package trust. -data TrustFlag - = TrustPackage String -- ^ @-trust@ - | DistrustPackage String -- ^ @-distrust@ - deriving (Eq) - --- | Flags for manipulating packages visibility. -data PackageFlag - = ExposePackage String PackageArg ModRenaming -- ^ @-package@, @-package-id@ - | HidePackage String -- ^ @-hide-package@ - deriving (Eq) -- NB: equality instance is used by packageFlagsChanged - -data PackageDBFlag - = PackageDB PkgDbRef - | NoUserPackageDB - | NoGlobalPackageDB - | ClearPackageDBs - deriving (Eq) - -packageFlagsChanged :: DynFlags -> DynFlags -> Bool -packageFlagsChanged idflags1 idflags0 = - packageFlags idflags1 /= packageFlags idflags0 || - ignorePackageFlags idflags1 /= ignorePackageFlags idflags0 || - pluginPackageFlags idflags1 /= pluginPackageFlags idflags0 || - trustFlags idflags1 /= trustFlags idflags0 || - packageDBFlags idflags1 /= packageDBFlags idflags0 || - packageGFlags idflags1 /= packageGFlags idflags0 - where - packageGFlags dflags = map (`gopt` dflags) - [ Opt_HideAllPackages - , Opt_HideAllPluginPackages - , Opt_AutoLinkPackages ] - -instance Outputable PackageFlag where - ppr (ExposePackage n arg rn) = text n <> braces (ppr arg <+> ppr rn) - ppr (HidePackage str) = text "-hide-package" <+> text str - -data DynLibLoader - = Deployable - | SystemDependent - deriving Eq - -data RtsOptsEnabled - = RtsOptsNone | RtsOptsIgnore | RtsOptsIgnoreAll | RtsOptsSafeOnly - | RtsOptsAll - deriving (Show) - --- | Are we building with @-fPIE@ or @-fPIC@ enabled? -positionIndependent :: DynFlags -> Bool -positionIndependent dflags = gopt Opt_PIC dflags || gopt Opt_PIE dflags - --- Note [-dynamic-too business] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- --- With -dynamic-too flag, we try to build both the non-dynamic and dynamic --- objects in a single run of the compiler: the pipeline is the same down to --- Core optimisation, then the backend (from Core to object code) is executed --- twice. --- --- The implementation is currently rather hacky, for example, we don't clearly separate non-dynamic --- and dynamic loaded interfaces (#9176). --- --- To make matters worse, we automatically enable -dynamic-too when some modules --- need Template-Haskell and GHC is dynamically linked (cf --- GHC.Driver.Pipeline.compileOne'). --- --- We used to try and fall back from a dynamic-too failure but this feature --- didn't work as expected (#20446) so it was removed to simplify the --- implementation and not obscure latent bugs. - -data DynamicTooState - = DT_Dont -- ^ Don't try to build dynamic objects too - | DT_OK -- ^ Will still try to generate dynamic objects - | DT_Dyn -- ^ Currently generating dynamic objects (in the backend) - deriving (Eq,Show,Ord) - -dynamicTooState :: DynFlags -> DynamicTooState -dynamicTooState dflags - | not (gopt Opt_BuildDynamicToo dflags) = DT_Dont - | dynamicNow dflags = DT_Dyn - | otherwise = DT_OK - -setDynamicNow :: DynFlags -> DynFlags -setDynamicNow dflags0 = - dflags0 - { dynamicNow = True - } - ------------------------------------------------------------------------------ - --- | Used by 'GHC.runGhc' to partially initialize a new 'DynFlags' value -initDynFlags :: DynFlags -> IO DynFlags -initDynFlags dflags = do - let - refRtldInfo <- newIORef Nothing - refRtccInfo <- newIORef Nothing - refRtasmInfo <- newIORef Nothing - canUseUnicode <- do let enc = localeEncoding - str = "‘’" - (withCString enc str $ \cstr -> - do str' <- peekCString enc cstr - return (str == str')) - `catchIOError` \_ -> return False - ghcNoUnicodeEnv <- lookupEnv "GHC_NO_UNICODE" - let useUnicode' = isNothing ghcNoUnicodeEnv && canUseUnicode - maybeGhcColorsEnv <- lookupEnv "GHC_COLORS" - maybeGhcColoursEnv <- lookupEnv "GHC_COLOURS" - let adjustCols (Just env) = Col.parseScheme env - adjustCols Nothing = id - let (useColor', colScheme') = - (adjustCols maybeGhcColoursEnv . adjustCols maybeGhcColorsEnv) - (useColor dflags, colScheme dflags) - tmp_dir <- normalise <$> getTemporaryDirectory - return dflags{ - useUnicode = useUnicode', - useColor = useColor', - canUseColor = stderrSupportsAnsiColors, - colScheme = colScheme', - rtldInfo = refRtldInfo, - rtccInfo = refRtccInfo, - rtasmInfo = refRtasmInfo, - tmpDir = TempDir tmp_dir - } - --- | The normal 'DynFlags'. Note that they are not suitable for use in this form --- and must be fully initialized by 'GHC.runGhc' first. -defaultDynFlags :: Settings -> DynFlags -defaultDynFlags mySettings = --- See Note [Updating flag description in the User's Guide] - DynFlags { - ghcMode = CompManager, - ghcLink = LinkBinary, - backend = platformDefaultBackend (sTargetPlatform mySettings), - verbosity = 0, - debugLevel = 0, - simplPhases = 2, - maxSimplIterations = 4, - ruleCheck = Nothing, - binBlobThreshold = Just 500000, -- 500K is a good default (see #16190) - maxRelevantBinds = Just 6, - maxValidHoleFits = Just 6, - maxRefHoleFits = Just 6, - refLevelHoleFits = Nothing, - maxUncoveredPatterns = 4, - maxPmCheckModels = 30, - simplTickFactor = 100, - dmdUnboxWidth = 3, -- Default: Assume an unboxed demand on function bodies returning a triple - specConstrThreshold = Just 2000, - specConstrCount = Just 3, - specConstrRecursive = 3, - liberateCaseThreshold = Just 2000, - floatLamArgs = Just 0, -- Default: float only if no fvs - liftLamsRecArgs = Just 5, -- Default: the number of available argument hardware registers on x86_64 - liftLamsNonRecArgs = Just 5, -- Default: the number of available argument hardware registers on x86_64 - liftLamsKnown = False, -- Default: don't turn known calls into unknown ones - cmmProcAlignment = Nothing, - - historySize = 20, - strictnessBefore = [], - - parMakeCount = Just 1, - - enableTimeStats = False, - ghcHeapSize = Nothing, - - importPaths = ["."], - mainModuleNameIs = mAIN_NAME, - mainFunIs = Nothing, - reductionDepth = treatZeroAsInf mAX_REDUCTION_DEPTH, - solverIterations = treatZeroAsInf mAX_SOLVER_ITERATIONS, - - homeUnitId_ = mainUnitId, - homeUnitInstanceOf_ = Nothing, - homeUnitInstantiations_ = [], - - workingDirectory = Nothing, - thisPackageName = Nothing, - hiddenModules = Set.empty, - reexportedModules = Set.empty, - - objectDir = Nothing, - dylibInstallName = Nothing, - hiDir = Nothing, - hieDir = Nothing, - stubDir = Nothing, - dumpDir = Nothing, - - objectSuf_ = phaseInputExt StopLn, - hcSuf = phaseInputExt HCc, - hiSuf_ = "hi", - hieSuf = "hie", - - dynObjectSuf_ = "dyn_" ++ phaseInputExt StopLn, - dynHiSuf_ = "dyn_hi", - dynamicNow = False, - - pluginModNames = [], - pluginModNameOpts = [], - frontendPluginOpts = [], - - externalPluginSpecs = [], - - outputFile_ = Nothing, - dynOutputFile_ = Nothing, - outputHi = Nothing, - dynOutputHi = Nothing, - dynLibLoader = SystemDependent, - dumpPrefix = "non-module.", - dumpPrefixForce = Nothing, - ldInputs = [], - includePaths = IncludeSpecs [] [] [], - libraryPaths = [], - frameworkPaths = [], - cmdlineFrameworks = [], - rtsOpts = Nothing, - rtsOptsEnabled = RtsOptsSafeOnly, - rtsOptsSuggestions = True, - - hpcDir = ".hpc", - - packageDBFlags = [], - packageFlags = [], - pluginPackageFlags = [], - ignorePackageFlags = [], - trustFlags = [], - packageEnv = Nothing, - targetWays_ = Set.empty, - splitInfo = Nothing, - - ghcNameVersion = sGhcNameVersion mySettings, - fileSettings = sFileSettings mySettings, - toolSettings = sToolSettings mySettings, - targetPlatform = sTargetPlatform mySettings, - platformMisc = sPlatformMisc mySettings, - rawSettings = sRawSettings mySettings, - - tmpDir = panic "defaultDynFlags: uninitialized tmpDir", - - llvmOptLevel = 0, - - -- ghc -M values - depMakefile = "Makefile", - depIncludePkgDeps = False, - depIncludeCppDeps = False, - depExcludeMods = [], - depSuffixes = [], - -- end of ghc -M values - ghcVersionFile = Nothing, - haddockOptions = Nothing, - dumpFlags = EnumSet.empty, - generalFlags = EnumSet.fromList (defaultFlags mySettings), - warningFlags = EnumSet.fromList standardWarnings, - fatalWarningFlags = EnumSet.empty, - ghciScripts = [], - language = Nothing, - safeHaskell = Sf_None, - safeInfer = True, - safeInferred = True, - thOnLoc = noSrcSpan, - newDerivOnLoc = noSrcSpan, - deriveViaOnLoc = noSrcSpan, - overlapInstLoc = noSrcSpan, - incoherentOnLoc = noSrcSpan, - pkgTrustOnLoc = noSrcSpan, - warnSafeOnLoc = noSrcSpan, - warnUnsafeOnLoc = noSrcSpan, - trustworthyOnLoc = noSrcSpan, - extensions = [], - extensionFlags = flattenExtensionFlags Nothing [], - - unfoldingOpts = defaultUnfoldingOpts, - maxWorkerArgs = 10, - - ghciHistSize = 50, -- keep a log of length 50 by default - - flushOut = defaultFlushOut, - pprUserLength = 5, - pprCols = 100, - useUnicode = False, - useColor = Auto, - canUseColor = False, - colScheme = Col.defaultScheme, - profAuto = NoProfAuto, - callerCcFilters = [], - interactivePrint = Nothing, - sseVersion = Nothing, - bmiVersion = Nothing, - avx = False, - avx2 = False, - avx512cd = False, - avx512er = False, - avx512f = False, - avx512pf = False, - rtldInfo = panic "defaultDynFlags: no rtldInfo", - rtccInfo = panic "defaultDynFlags: no rtccInfo", - rtasmInfo = panic "defaultDynFlags: no rtasmInfo", - - maxInlineAllocSize = 128, - maxInlineMemcpyInsns = 32, - maxInlineMemsetInsns = 32, - - initialUnique = 0, - uniqueIncrement = 1, - - reverseErrors = False, - maxErrors = Nothing, - cfgWeights = defaultWeights - } - -type FatalMessager = String -> IO () - -defaultFatalMessager :: FatalMessager -defaultFatalMessager = hPutStrLn stderr - - -newtype FlushOut = FlushOut (IO ()) - -defaultFlushOut :: FlushOut -defaultFlushOut = FlushOut $ hFlush stdout - -{- -Note [Verbosity levels] -~~~~~~~~~~~~~~~~~~~~~~~ - 0 | print errors & warnings only - 1 | minimal verbosity: print "compiling M ... done." for each module. - 2 | equivalent to -dshow-passes - 3 | equivalent to existing "ghc -v" - 4 | "ghc -v -ddump-most" - 5 | "ghc -v -ddump-all" --} - -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 -flattenExtensionFlags ml = foldr f defaultExtensionFlags - where f (On f) flags = EnumSet.insert f flags - f (Off f) flags = EnumSet.delete f flags - defaultExtensionFlags = EnumSet.fromList (languageExtensions ml) - --- | The language extensions implied by the various language variants. --- When updating this be sure to update the flag documentation in --- @docs/users_guide/exts@. -languageExtensions :: Maybe Language -> [LangExt.Extension] - --- Nothing: the default case -languageExtensions Nothing = languageExtensions (Just GHC2021) - -languageExtensions (Just Haskell98) - = [LangExt.ImplicitPrelude, - -- See Note [When is StarIsType enabled] - LangExt.StarIsType, - LangExt.CUSKs, - LangExt.MonomorphismRestriction, - LangExt.NPlusKPatterns, - LangExt.DatatypeContexts, - LangExt.TraditionalRecordSyntax, - LangExt.FieldSelectors, - LangExt.NondecreasingIndentation, - -- strictly speaking non-standard, but we always had this - -- on implicitly before the option was added in 7.1, and - -- 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 - -- Non-standard but enabled for backwards compatability (see GHC proposal #511) - ] - -languageExtensions (Just Haskell2010) - = [LangExt.ImplicitPrelude, - -- See Note [When is StarIsType enabled] - LangExt.StarIsType, - LangExt.CUSKs, - LangExt.MonomorphismRestriction, - LangExt.DatatypeContexts, - LangExt.TraditionalRecordSyntax, - LangExt.EmptyDataDecls, - LangExt.ForeignFunctionInterface, - LangExt.PatternGuards, - LangExt.DoAndIfThenElse, - LangExt.FieldSelectors, - LangExt.RelaxedPolyRec, - LangExt.DeepSubsumption ] - -languageExtensions (Just GHC2021) - = [LangExt.ImplicitPrelude, - -- See Note [When is StarIsType enabled] - LangExt.StarIsType, - LangExt.MonomorphismRestriction, - LangExt.TraditionalRecordSyntax, - LangExt.EmptyDataDecls, - LangExt.ForeignFunctionInterface, - LangExt.PatternGuards, - LangExt.DoAndIfThenElse, - LangExt.FieldSelectors, - LangExt.RelaxedPolyRec, - -- Now the new extensions (not in Haskell2010) - LangExt.BangPatterns, - LangExt.BinaryLiterals, - LangExt.ConstrainedClassMethods, - LangExt.ConstraintKinds, - LangExt.DeriveDataTypeable, - LangExt.DeriveFoldable, - LangExt.DeriveFunctor, - LangExt.DeriveGeneric, - LangExt.DeriveLift, - LangExt.DeriveTraversable, - LangExt.EmptyCase, - LangExt.EmptyDataDeriving, - LangExt.ExistentialQuantification, - LangExt.ExplicitForAll, - LangExt.FlexibleContexts, - LangExt.FlexibleInstances, - LangExt.GADTSyntax, - LangExt.GeneralizedNewtypeDeriving, - LangExt.HexFloatLiterals, - LangExt.ImportQualifiedPost, - LangExt.InstanceSigs, - LangExt.KindSignatures, - LangExt.MultiParamTypeClasses, - LangExt.NamedFieldPuns, - LangExt.NamedWildCards, - LangExt.NumericUnderscores, - LangExt.PolyKinds, - LangExt.PostfixOperators, - LangExt.RankNTypes, - LangExt.ScopedTypeVariables, - LangExt.StandaloneDeriving, - LangExt.StandaloneKindSignatures, - LangExt.TupleSections, - LangExt.TypeApplications, - LangExt.TypeOperators, - LangExt.TypeSynonymInstances] - -hasPprDebug :: DynFlags -> Bool -hasPprDebug = dopt Opt_D_ppr_debug - -hasNoDebugOutput :: DynFlags -> Bool -hasNoDebugOutput = dopt Opt_D_no_debug_output - -hasNoStateHack :: DynFlags -> Bool -hasNoStateHack = gopt Opt_G_NoStateHack - -hasNoOptCoercion :: DynFlags -> Bool -hasNoOptCoercion = gopt Opt_G_NoOptCoercion - - --- | Test whether a 'DumpFlag' is set -dopt :: DumpFlag -> DynFlags -> Bool -dopt = getDumpFlagFrom verbosity dumpFlags - --- | Set a 'DumpFlag' -dopt_set :: DynFlags -> DumpFlag -> DynFlags -dopt_set dfs f = dfs{ dumpFlags = EnumSet.insert f (dumpFlags dfs) } - --- | Unset a 'DumpFlag' -dopt_unset :: DynFlags -> DumpFlag -> DynFlags -dopt_unset dfs f = dfs{ dumpFlags = EnumSet.delete f (dumpFlags dfs) } - --- | Test whether a 'GeneralFlag' is set --- --- Note that `dynamicNow` (i.e., dynamic objects built with `-dynamic-too`) --- always implicitly enables Opt_PIC, Opt_ExternalDynamicRefs, and disables --- Opt_SplitSections. --- -gopt :: GeneralFlag -> DynFlags -> Bool -gopt Opt_PIC dflags - | dynamicNow dflags = True -gopt Opt_ExternalDynamicRefs dflags - | dynamicNow dflags = True -gopt Opt_SplitSections dflags - | dynamicNow dflags = False -gopt f dflags = f `EnumSet.member` generalFlags dflags - --- | Set a 'GeneralFlag' -gopt_set :: DynFlags -> GeneralFlag -> DynFlags -gopt_set dfs f = dfs{ generalFlags = EnumSet.insert f (generalFlags dfs) } - --- | Unset a 'GeneralFlag' -gopt_unset :: DynFlags -> GeneralFlag -> DynFlags -gopt_unset dfs f = dfs{ generalFlags = EnumSet.delete f (generalFlags dfs) } - --- | Test whether a 'WarningFlag' is set -wopt :: WarningFlag -> DynFlags -> Bool -wopt f dflags = f `EnumSet.member` warningFlags dflags - --- | Set a 'WarningFlag' -wopt_set :: DynFlags -> WarningFlag -> DynFlags -wopt_set dfs f = dfs{ warningFlags = EnumSet.insert f (warningFlags dfs) } - --- | Unset a 'WarningFlag' -wopt_unset :: DynFlags -> WarningFlag -> DynFlags -wopt_unset dfs f = dfs{ warningFlags = EnumSet.delete f (warningFlags dfs) } - --- | Test whether a 'WarningFlag' is set as fatal -wopt_fatal :: WarningFlag -> DynFlags -> Bool -wopt_fatal f dflags = f `EnumSet.member` fatalWarningFlags dflags - --- | Mark a 'WarningFlag' as fatal (do not set the flag) -wopt_set_fatal :: DynFlags -> WarningFlag -> DynFlags -wopt_set_fatal dfs f - = dfs { fatalWarningFlags = EnumSet.insert f (fatalWarningFlags dfs) } - --- | Mark a 'WarningFlag' as not fatal -wopt_unset_fatal :: DynFlags -> WarningFlag -> DynFlags -wopt_unset_fatal dfs f - = dfs { fatalWarningFlags = EnumSet.delete f (fatalWarningFlags dfs) } - --- | Test whether a 'LangExt.Extension' is set -xopt :: LangExt.Extension -> DynFlags -> Bool -xopt f dflags = f `EnumSet.member` extensionFlags dflags - --- | Set a 'LangExt.Extension' -xopt_set :: DynFlags -> LangExt.Extension -> DynFlags -xopt_set dfs f - = let onoffs = On f : extensions dfs - in dfs { extensions = onoffs, - extensionFlags = flattenExtensionFlags (language dfs) onoffs } - --- | Unset a 'LangExt.Extension' -xopt_unset :: DynFlags -> LangExt.Extension -> DynFlags -xopt_unset dfs f - = let onoffs = Off f : extensions dfs - in dfs { extensions = onoffs, - extensionFlags = flattenExtensionFlags (language dfs) onoffs } - --- | Set or unset a 'LangExt.Extension', unless it has been explicitly --- set or unset before. -xopt_set_unlessExplSpec - :: LangExt.Extension - -> (DynFlags -> LangExt.Extension -> DynFlags) - -> DynFlags -> DynFlags -xopt_set_unlessExplSpec ext setUnset dflags = - let referedExts = stripOnOff <$> extensions dflags - stripOnOff (On x) = x - stripOnOff (Off x) = x - in - if ext `elem` referedExts then dflags else setUnset dflags ext - -xopt_DuplicateRecordFields :: DynFlags -> FieldLabel.DuplicateRecordFields -xopt_DuplicateRecordFields dfs - | xopt LangExt.DuplicateRecordFields dfs = FieldLabel.DuplicateRecordFields - | otherwise = FieldLabel.NoDuplicateRecordFields - -xopt_FieldSelectors :: DynFlags -> FieldLabel.FieldSelectors -xopt_FieldSelectors dfs - | xopt LangExt.FieldSelectors dfs = FieldLabel.FieldSelectors - | otherwise = FieldLabel.NoFieldSelectors - -lang_set :: DynFlags -> Maybe Language -> DynFlags -lang_set dflags lang = - dflags { - language = lang, - extensionFlags = flattenExtensionFlags lang (extensions dflags) - } - --- | Set the Haskell language standard to use -setLanguage :: Language -> DynP () -setLanguage l = upd (`lang_set` Just l) - --- | Is the -fpackage-trust mode on -packageTrustOn :: DynFlags -> Bool -packageTrustOn = gopt Opt_PackageTrust - --- | Is Safe Haskell on in some way (including inference mode) -safeHaskellOn :: DynFlags -> Bool -safeHaskellOn dflags = safeHaskellModeEnabled dflags || safeInferOn dflags - -safeHaskellModeEnabled :: DynFlags -> Bool -safeHaskellModeEnabled dflags = safeHaskell dflags `elem` [Sf_Unsafe, Sf_Trustworthy - , Sf_Safe ] - - --- | Is the Safe Haskell safe language in use -safeLanguageOn :: DynFlags -> Bool -safeLanguageOn dflags = safeHaskell dflags == Sf_Safe - --- | Is the Safe Haskell safe inference mode active -safeInferOn :: DynFlags -> Bool -safeInferOn = safeInfer - --- | Test if Safe Imports are on in some form -safeImportsOn :: DynFlags -> Bool -safeImportsOn dflags = safeHaskell dflags == Sf_Unsafe || - safeHaskell dflags == Sf_Trustworthy || - safeHaskell dflags == Sf_Safe - --- | Set a 'Safe Haskell' flag -setSafeHaskell :: SafeHaskellMode -> DynP () -setSafeHaskell s = updM f - where f dfs = do - let sf = safeHaskell dfs - safeM <- combineSafeFlags sf s - case s of - Sf_Safe -> return $ dfs { safeHaskell = safeM, safeInfer = False } - -- leave safe inference on in Trustworthy mode so we can warn - -- if it could have been inferred safe. - Sf_Trustworthy -> do - l <- getCurLoc - return $ dfs { safeHaskell = safeM, trustworthyOnLoc = l } - -- leave safe inference on in Unsafe mode as well. - _ -> return $ dfs { safeHaskell = safeM } - --- | Are all direct imports required to be safe for this Safe Haskell mode? --- Direct imports are when the code explicitly imports a module -safeDirectImpsReq :: DynFlags -> Bool -safeDirectImpsReq d = safeLanguageOn d - --- | Are all implicit imports required to be safe for this Safe Haskell mode? --- Implicit imports are things in the prelude. e.g System.IO when print is used. -safeImplicitImpsReq :: DynFlags -> Bool -safeImplicitImpsReq d = safeLanguageOn d - --- | Combine two Safe Haskell modes correctly. Used for dealing with multiple flags. --- This makes Safe Haskell very much a monoid but for now I prefer this as I don't --- want to export this functionality from the module but do want to export the --- type constructors. -combineSafeFlags :: SafeHaskellMode -> SafeHaskellMode -> DynP SafeHaskellMode -combineSafeFlags a b | a == Sf_None = return b - | b == Sf_None = return a - | a == Sf_Ignore || b == Sf_Ignore = return Sf_Ignore - | a == b = return a - | otherwise = addErr errm >> pure a - where errm = "Incompatible Safe Haskell flags! (" - ++ show a ++ ", " ++ show b ++ ")" - --- | A list of unsafe flags under Safe Haskell. Tuple elements are: --- * name of the flag --- * function to get srcspan that enabled the flag --- * function to test if the flag is on --- * function to turn the flag off -unsafeFlags, unsafeFlagsForInfer - :: [(String, DynFlags -> SrcSpan, DynFlags -> Bool, DynFlags -> DynFlags)] -unsafeFlags = [ ("-XGeneralizedNewtypeDeriving", newDerivOnLoc, - xopt LangExt.GeneralizedNewtypeDeriving, - flip xopt_unset LangExt.GeneralizedNewtypeDeriving) - , ("-XDerivingVia", deriveViaOnLoc, - xopt LangExt.DerivingVia, - flip xopt_unset LangExt.DerivingVia) - , ("-XTemplateHaskell", thOnLoc, - xopt LangExt.TemplateHaskell, - flip xopt_unset LangExt.TemplateHaskell) - ] -unsafeFlagsForInfer = unsafeFlags - - --- | Retrieve the options corresponding to a particular @opt_*@ field in the correct order -getOpts :: DynFlags -- ^ 'DynFlags' to retrieve the options from - -> (DynFlags -> [a]) -- ^ Relevant record accessor: one of the @opt_*@ accessors - -> [a] -- ^ Correctly ordered extracted options -getOpts dflags opts = reverse (opts dflags) - -- We add to the options from the front, so we need to reverse the list - --- | Gets the verbosity flag for the current verbosity level. This is fed to --- other tools, so GHC-specific verbosity flags like @-ddump-most@ are not included -getVerbFlags :: DynFlags -> [String] -getVerbFlags dflags - | verbosity dflags >= 4 = ["-v"] - | otherwise = [] - -setObjectDir, setHiDir, setHieDir, setStubDir, setDumpDir, setOutputDir, - setDynObjectSuf, setDynHiSuf, - setDylibInstallName, - setObjectSuf, setHiSuf, setHieSuf, setHcSuf, parseDynLibLoaderMode, - setPgmP, addOptl, addOptc, addOptcxx, addOptP, - addCmdlineFramework, addHaddockOpts, addGhciScript, - setInteractivePrint - :: String -> DynFlags -> DynFlags -setOutputFile, setDynOutputFile, setOutputHi, setDynOutputHi, setDumpPrefixForce - :: Maybe String -> DynFlags -> DynFlags - -setObjectDir f d = d { objectDir = Just f} -setHiDir f d = d { hiDir = Just f} -setHieDir f d = d { hieDir = Just f} -setStubDir f d = d { stubDir = Just f - , includePaths = addGlobalInclude (includePaths d) [f] } - -- -stubdir D adds an implicit -I D, so that gcc can find the _stub.h file - -- \#included from the .hc file when compiling via C (i.e. unregisterised - -- builds). -setDumpDir f d = d { dumpDir = Just f} -setOutputDir f = setObjectDir f - . setHieDir f - . setHiDir f - . setStubDir f - . setDumpDir f -setDylibInstallName f d = d { dylibInstallName = Just f} - -setObjectSuf f d = d { objectSuf_ = f} -setDynObjectSuf f d = d { dynObjectSuf_ = f} -setHiSuf f d = d { hiSuf_ = f} -setHieSuf f d = d { hieSuf = f} -setDynHiSuf f d = d { dynHiSuf_ = f} -setHcSuf f d = d { hcSuf = f} - -setOutputFile f d = d { outputFile_ = f} -setDynOutputFile f d = d { dynOutputFile_ = f} -setOutputHi f d = d { outputHi = f} -setDynOutputHi f d = d { dynOutputHi = f} - -parseUnitInsts :: String -> Instantiations -parseUnitInsts str = case filter ((=="").snd) (readP_to_S parse str) of - [(r, "")] -> r - _ -> throwGhcException $ CmdLineError ("Can't parse -instantiated-with: " ++ str) - where parse = sepBy parseEntry (R.char ',') - parseEntry = do - n <- parseModuleName - _ <- R.char '=' - m <- parseHoleyModule - return (n, m) - -setUnitInstantiations :: String -> DynFlags -> DynFlags -setUnitInstantiations s d = - d { homeUnitInstantiations_ = parseUnitInsts s } - -setUnitInstanceOf :: String -> DynFlags -> DynFlags -setUnitInstanceOf s d = - d { homeUnitInstanceOf_ = Just (UnitId (fsLit s)) } - -addPluginModuleName :: String -> DynFlags -> DynFlags -addPluginModuleName name d = d { pluginModNames = (mkModuleName name) : (pluginModNames d) } - -clearPluginModuleNames :: DynFlags -> DynFlags -clearPluginModuleNames d = - d { pluginModNames = [] - , pluginModNameOpts = [] - } - -addPluginModuleNameOption :: String -> DynFlags -> DynFlags -addPluginModuleNameOption optflag d = d { pluginModNameOpts = (mkModuleName m, option) : (pluginModNameOpts d) } - where (m, rest) = break (== ':') optflag - option = case rest of - [] -> "" -- should probably signal an error - (_:plug_opt) -> plug_opt -- ignore the ':' from break - -addExternalPlugin :: String -> DynFlags -> DynFlags -addExternalPlugin optflag d = case parseExternalPluginSpec optflag of - Just r -> d { externalPluginSpecs = r : externalPluginSpecs d } - Nothing -> cmdLineError $ "Couldn't parse external plugin specification: " ++ optflag - -addFrontendPluginOption :: String -> DynFlags -> DynFlags -addFrontendPluginOption s d = d { frontendPluginOpts = s : frontendPluginOpts d } - -parseDynLibLoaderMode f d = - case splitAt 8 f of - ("deploy", "") -> d { dynLibLoader = Deployable } - ("sysdep", "") -> d { dynLibLoader = SystemDependent } - _ -> throwGhcException (CmdLineError ("Unknown dynlib loader: " ++ f)) - -setDumpPrefixForce f d = d { dumpPrefixForce = f} - --- 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 -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}) -addOptP f = alterToolSettings $ \s -> s - { toolSettings_opt_P = f : toolSettings_opt_P s - , toolSettings_opt_P_fingerprint = fingerprintStrings (f : toolSettings_opt_P s) - } - -- See Note [Repeated -optP hashing] - where - fingerprintStrings ss = fingerprintFingerprints $ map fingerprintString ss - - -setDepMakefile :: FilePath -> DynFlags -> DynFlags -setDepMakefile f d = d { depMakefile = f } - -setDepIncludeCppDeps :: Bool -> DynFlags -> DynFlags -setDepIncludeCppDeps b d = d { depIncludeCppDeps = b } - -setDepIncludePkgDeps :: Bool -> DynFlags -> DynFlags -setDepIncludePkgDeps b d = d { depIncludePkgDeps = b } - -addDepExcludeMod :: String -> DynFlags -> DynFlags -addDepExcludeMod m d - = d { depExcludeMods = mkModuleName m : depExcludeMods d } - -addDepSuffix :: FilePath -> DynFlags -> DynFlags -addDepSuffix s d = d { depSuffixes = s : depSuffixes d } - -addCmdlineFramework f d = d { cmdlineFrameworks = f : cmdlineFrameworks d} - -addGhcVersionFile :: FilePath -> DynFlags -> DynFlags -addGhcVersionFile f d = d { ghcVersionFile = Just f } - -addHaddockOpts f d = d { haddockOptions = Just f} - -addGhciScript f d = d { ghciScripts = f : ghciScripts d} - -setInteractivePrint f d = d { interactivePrint = Just f} - ------------------------------------------------------------------------------ --- Setting the optimisation level - -updOptLevelChanged :: Int -> DynFlags -> (DynFlags, Bool) --- ^ Sets the 'DynFlags' to be appropriate to the optimisation level and signals if any changes took place -updOptLevelChanged n dfs - = (dfs3, changed1 || changed2 || changed3) - where - final_n = max 0 (min 2 n) -- Clamp to 0 <= n <= 2 - (dfs1, changed1) = foldr unset (dfs , False) remove_gopts - (dfs2, changed2) = foldr set (dfs1, False) extra_gopts - (dfs3, changed3) = setLlvmOptLevel dfs2 - - extra_gopts = [ f | (ns,f) <- optLevelFlags, final_n `elem` ns ] - remove_gopts = [ f | (ns,f) <- optLevelFlags, final_n `notElem` ns ] - - set f (dfs, changed) - | gopt f dfs = (dfs, changed) - | otherwise = (gopt_set dfs f, True) - - unset f (dfs, changed) - | not (gopt f dfs) = (dfs, changed) - | otherwise = (gopt_unset dfs f, True) - - setLlvmOptLevel dfs - | llvmOptLevel dfs /= final_n = (dfs{ llvmOptLevel = final_n }, True) - | otherwise = (dfs, False) - -updOptLevel :: Int -> DynFlags -> DynFlags --- ^ Sets the 'DynFlags' to be appropriate to the optimisation level -updOptLevel n = fst . updOptLevelChanged n - -{- ********************************************************************** -%* * - DynFlags parser -%* * -%********************************************************************* -} - --- ----------------------------------------------------------------------------- --- Parsing the dynamic flags. - - --- | Parse dynamic flags from a list of command line arguments. Returns --- 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] - -> m (DynFlags, [Located String], [Warn]) - -- ^ Updated 'DynFlags', left-over arguments, and - -- list of warnings. -parseDynamicFlagsCmdLine = parseDynamicFlagsFull flagsAll True - - --- | 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] - -> m (DynFlags, [Located String], [Warn]) - -- ^ Updated 'DynFlags', left-over arguments, and - -- list of warnings. -parseDynamicFilePragma = parseDynamicFlagsFull flagsDynamic False - -newtype CmdLineP s a = CmdLineP (forall m. (Monad m) => StateT s m a) - deriving (Functor) - -instance Monad (CmdLineP s) where - CmdLineP k >>= f = CmdLineP (k >>= \x -> case f x of CmdLineP g -> g) - return = pure - -instance Applicative (CmdLineP s) where - pure x = CmdLineP (pure x) - (<*>) = ap - -getCmdLineState :: CmdLineP s s -getCmdLineState = CmdLineP State.get - -putCmdLineState :: s -> CmdLineP s () -putCmdLineState x = CmdLineP (State.put x) - -runCmdLineP :: CmdLineP s a -> s -> (a, s) -runCmdLineP (CmdLineP k) s0 = runIdentity $ runStateT k s0 - --- | A helper to parse a set of flags from a list of command-line arguments, handling --- response files. -processCmdLineP - :: forall s m. MonadIO m - => [Flag (CmdLineP s)] -- ^ valid flags to match against - -> s -- ^ current state - -> [Located String] -- ^ arguments to parse - -> m (([Located String], [Err], [Warn]), s) - -- ^ (leftovers, errors, warnings) -processCmdLineP activeFlags s0 args = - runStateT (processArgs (map (hoistFlag getCmdLineP) activeFlags) args parseResponseFile) s0 - where - getCmdLineP :: CmdLineP s a -> StateT s m a - getCmdLineP (CmdLineP k) = k - --- | Parses the dynamically set flags for GHC. This is the most general form of --- the dynamic flag parser that the other methods simply wrap. It allows --- saying which flags are valid flags and indicating if we are parsing --- arguments from the command line or from a file pragma. -parseDynamicFlagsFull - :: forall m. MonadIO m - => [Flag (CmdLineP DynFlags)] -- ^ valid flags to match against - -> Bool -- ^ are the arguments from the command line? - -> DynFlags -- ^ current dynamic flags - -> [Located String] -- ^ arguments to parse - -> m (DynFlags, [Located String], [Warn]) -parseDynamicFlagsFull activeFlags cmdline dflags0 args = do - ((leftover, errs, warns), dflags1) <- processCmdLineP activeFlags dflags0 args - - -- See Note [Handling errors when parsing command-line flags] - let rdr = renderWithContext (initSDocContext dflags0 defaultUserStyle) - unless (null errs) $ liftIO $ throwGhcExceptionIO $ errorsToGhcException $ - map ((rdr . ppr . getLoc &&& unLoc) . errMsg) $ errs - - -- check for disabled flags in safe haskell - let (dflags2, sh_warns) = safeFlagCheck cmdline dflags1 - theWays = ways dflags2 - - unless (allowed_combination theWays) $ liftIO $ - throwGhcExceptionIO (CmdLineError ("combination not supported: " ++ - intercalate "/" (map wayDesc (Set.toAscList theWays)))) - - let (dflags3, consistency_warnings) = makeDynFlagsConsistent dflags2 - - -- Set timer stats & heap size - when (enableTimeStats dflags3) $ liftIO enableTimingStats - case (ghcHeapSize dflags3) of - Just x -> liftIO (setHeapSize x) - _ -> return () - - liftIO $ setUnsafeGlobalDynFlags dflags3 - - let warns' = map (Warn WarningWithoutFlag) (consistency_warnings ++ sh_warns) - - return (dflags3, leftover, warns' ++ warns) - --- | Check (and potentially disable) any extensions that aren't allowed --- in safe mode. --- --- The bool is to indicate if we are parsing command line flags (false means --- file pragma). This allows us to generate better warnings. -safeFlagCheck :: Bool -> DynFlags -> (DynFlags, [Located String]) -safeFlagCheck _ dflags | safeLanguageOn dflags = (dflagsUnset, warns) - where - -- Handle illegal flags under safe language. - (dflagsUnset, warns) = foldl' check_method (dflags, []) unsafeFlags - - check_method (df, warns) (str,loc,test,fix) - | test df = (fix df, warns ++ safeFailure (loc df) str) - | otherwise = (df, warns) - - safeFailure loc str - = [L loc $ str ++ " is not allowed in Safe Haskell; ignoring " - ++ str] - -safeFlagCheck cmdl dflags = - case safeInferOn dflags of - True -> (dflags' { safeInferred = safeFlags }, warn) - False -> (dflags', warn) - - where - -- dynflags and warn for when -fpackage-trust by itself with no safe - -- haskell flag - (dflags', warn) - | not (safeHaskellModeEnabled dflags) && not cmdl && packageTrustOn dflags - = (gopt_unset dflags Opt_PackageTrust, pkgWarnMsg) - | otherwise = (dflags, []) - - pkgWarnMsg = [L (pkgTrustOnLoc dflags') $ - "-fpackage-trust ignored;" ++ - " must be specified with a Safe Haskell flag"] - - -- Have we inferred Unsafe? See Note [Safe Haskell Inference] in GHC.Driver.Main - -- Force this to avoid retaining reference to old DynFlags value - !safeFlags = all (\(_,_,t,_) -> not $ t dflags) unsafeFlagsForInfer - - -{- ********************************************************************** -%* * - DynFlags specifications -%* * -%********************************************************************* -} - --- | All dynamic flags option strings without the deprecated ones. --- These are the user facing strings for enabling and disabling options. -allNonDeprecatedFlags :: [String] -allNonDeprecatedFlags = allFlagsDeps False - --- | All flags with possibility to filter deprecated ones -allFlagsDeps :: Bool -> [String] -allFlagsDeps keepDeprecated = [ '-':flagName flag - | (deprecated, flag) <- flagsAllDeps - , keepDeprecated || not (isDeprecated deprecated)] - where isDeprecated Deprecated = True - isDeprecated _ = False - -{- - - Below we export user facing symbols for GHC dynamic flags for use with the - - GHC API. - -} - --- All dynamic flags present in GHC. -flagsAll :: [Flag (CmdLineP DynFlags)] -flagsAll = map snd flagsAllDeps - --- All dynamic flags present in GHC with deprecation information. -flagsAllDeps :: [(Deprecation, Flag (CmdLineP DynFlags))] -flagsAllDeps = package_flags_deps ++ dynamic_flags_deps - - --- All dynamic flags, minus package flags, present in GHC. -flagsDynamic :: [Flag (CmdLineP DynFlags)] -flagsDynamic = map snd dynamic_flags_deps - --- ALl package flags present in GHC. -flagsPackage :: [Flag (CmdLineP DynFlags)] -flagsPackage = map snd package_flags_deps - -----------------Helpers to make flags and keep deprecation information---------- - -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) - -> (Deprecation, Flag (CmdLineP DynFlags)) -make_ord_flag fm name kind = (NotDeprecated, fm name kind) - --- Make a deprecated flag -make_dep_flag :: DynFlagMaker -> String -> OptKind (CmdLineP DynFlags) -> String - -> (Deprecation, Flag (CmdLineP DynFlags)) -make_dep_flag fm name kind message = (Deprecated, - fm name $ add_dep_message kind message) - -add_dep_message :: OptKind (CmdLineP DynFlags) -> String - -> OptKind (CmdLineP DynFlags) -add_dep_message (NoArg f) message = NoArg $ f >> deprecate message -add_dep_message (HasArg f) message = HasArg $ \s -> f s >> deprecate message -add_dep_message (SepArg f) message = SepArg $ \s -> f s >> deprecate message -add_dep_message (Prefix f) message = Prefix $ \s -> f s >> deprecate message -add_dep_message (OptPrefix f) message = - OptPrefix $ \s -> f s >> deprecate message -add_dep_message (OptIntSuffix f) message = - OptIntSuffix $ \oi -> f oi >> deprecate message -add_dep_message (IntSuffix f) message = - IntSuffix $ \i -> f i >> deprecate message -add_dep_message (Word64Suffix f) message = - Word64Suffix $ \i -> f i >> deprecate message -add_dep_message (FloatSuffix f) message = - FloatSuffix $ \fl -> f fl >> deprecate message -add_dep_message (PassFlag f) message = - PassFlag $ \s -> f s >> deprecate message -add_dep_message (AnySuffix f) message = - AnySuffix $ \s -> f s >> deprecate message - ------------------------ The main flags themselves ------------------------------ --- See Note [Updating flag description in the User's Guide] --- See Note [Supporting CLI completion] -dynamic_flags_deps :: [(Deprecation, Flag (CmdLineP DynFlags))] -dynamic_flags_deps = [ - make_dep_flag defFlag "n" (NoArg $ return ()) - "The -n flag is deprecated and no longer has any effect" - , make_ord_flag defFlag "cpp" (NoArg (setExtensionFlag LangExt.Cpp)) - , make_ord_flag defFlag "F" (NoArg (setGeneralFlag Opt_Pp)) - , (Deprecated, defFlag "#include" - (HasArg (\_s -> - deprecate ("-#include and INCLUDE pragmas are " ++ - "deprecated: They no longer have any effect")))) - , make_ord_flag defFlag "v" (OptIntSuffix setVerbosity) - - , make_ord_flag defGhcFlag "j" (OptIntSuffix - (\n -> case n of - Just n - | n > 0 -> upd (\d -> d { parMakeCount = Just n }) - | otherwise -> addErr "Syntax: -j[n] where n > 0" - Nothing -> upd (\d -> d { parMakeCount = Nothing }))) - -- When the number of parallel builds - -- is omitted, it is the same - -- as specifying that the number of - -- parallel builds is equal to the - -- result of getNumProcessors - , make_ord_flag defFlag "instantiated-with" (sepArg setUnitInstantiations) - , make_ord_flag defFlag "this-component-id" (sepArg setUnitInstanceOf) - - -- RTS options ------------------------------------------------------------- - , make_ord_flag defFlag "H" (HasArg (\s -> upd (\d -> - d { ghcHeapSize = Just $ fromIntegral (decodeSize s)}))) - - , make_ord_flag defFlag "Rghc-timing" (NoArg (upd (\d -> - d { enableTimeStats = True }))) - - ------- ways --------------------------------------------------------------- - , make_ord_flag defGhcFlag "prof" (NoArg (addWayDynP WayProf)) - , (Deprecated, defFlag "eventlog" - $ noArgM $ \d -> do - deprecate "the eventlog is now enabled in all runtime system ways" - return d) - , make_ord_flag defGhcFlag "debug" (NoArg (addWayDynP WayDebug)) - , make_ord_flag defGhcFlag "threaded" (NoArg (addWayDynP WayThreaded)) - - , make_ord_flag defGhcFlag "ticky" - (NoArg (setGeneralFlag Opt_Ticky >> addWayDynP WayDebug)) - - -- -ticky enables ticky-ticky code generation, and also implies -debug which - -- is required to get the RTS ticky support. - - ----- Linker -------------------------------------------------------- - , make_ord_flag defGhcFlag "static" (NoArg removeWayDyn) - , make_ord_flag defGhcFlag "dynamic" (NoArg (addWayDynP WayDyn)) - , make_ord_flag defGhcFlag "rdynamic" $ noArg $ -#if defined(linux_HOST_OS) - addOptl "-rdynamic" -#elif defined(mingw32_HOST_OS) - addOptl "-Wl,--export-all-symbols" -#else - -- ignored for compat w/ gcc: - id -#endif - , make_ord_flag defGhcFlag "relative-dynlib-paths" - (NoArg (setGeneralFlag Opt_RelativeDynlibPaths)) - , make_ord_flag defGhcFlag "copy-libs-when-linking" - (NoArg (setGeneralFlag Opt_SingleLibFolder)) - , make_ord_flag defGhcFlag "pie" (NoArg (setGeneralFlag Opt_PICExecutable)) - , make_ord_flag defGhcFlag "no-pie" (NoArg (unSetGeneralFlag Opt_PICExecutable)) - - ------- Specific phases -------------------------------------------- - -- need to appear before -pgmL to be parsed as LLVM flags. - , make_ord_flag defFlag "pgmlo" - $ 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 "pgmlm" - $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_pgm_lm = - if null f then Nothing else Just (f,[]) } - , make_ord_flag defFlag "pgmi" - $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_pgm_i = f } - , make_ord_flag defFlag "pgmL" - $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_pgm_L = f } - , make_ord_flag defFlag "pgmP" - (hasArg setPgmP) - , make_ord_flag defFlag "pgmF" - $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_pgm_F = f } - , make_ord_flag defFlag "pgmc" - $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_pgm_c = f } - , make_ord_flag defFlag "pgmcxx" - $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_pgm_cxx = f } - , (Deprecated, defFlag "pgmc-supports-no-pie" - $ noArgM $ \d -> do - deprecate $ "use -pgml-supports-no-pie instead" - pure $ alterToolSettings (\s -> s { toolSettings_ccSupportsNoPie = True }) d) - , make_ord_flag defFlag "pgms" - (HasArg (\_ -> addWarn "Object splitting was removed in GHC 8.8")) - , make_ord_flag defFlag "pgma" - $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_pgm_a = (f,[]) } - , make_ord_flag defFlag "pgml" - $ hasArg $ \f -> alterToolSettings $ \s -> s - { toolSettings_pgm_l = (f,[]) - , -- Don't pass -no-pie with custom -pgml (see #15319). Note - -- that this could break when -no-pie is actually needed. - -- But the CC_SUPPORTS_NO_PIE check only happens at - -- buildtime, and -pgml is a runtime option. A better - -- solution would be running this check for each custom - -- -pgml. - toolSettings_ccSupportsNoPie = False - } - , 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" - $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_pgm_ar = f } - , make_ord_flag defFlag "pgmotool" - $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_pgm_otool = f} - , make_ord_flag defFlag "pgminstall_name_tool" - $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_pgm_install_name_tool = f} - , make_ord_flag defFlag "pgmranlib" - $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_pgm_ranlib = f } - - - -- need to appear before -optl/-opta to be parsed as LLVM flags. - , make_ord_flag defFlag "optlm" - $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_opt_lm = f : toolSettings_opt_lm s } - , make_ord_flag defFlag "optlo" - $ 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 "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 "optF" - $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_opt_F = f : toolSettings_opt_F s } - , make_ord_flag defFlag "optc" - (hasArg addOptc) - , make_ord_flag defFlag "optcxx" - (hasArg addOptcxx) - , make_ord_flag defFlag "opta" - $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_opt_a = f : toolSettings_opt_a s } - , make_ord_flag defFlag "optl" - (hasArg addOptl) - , make_ord_flag defFlag "optwindres" - $ 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" - (NoArg $ setGeneralFlag Opt_SplitSections) - - -------- ghc -M ----------------------------------------------------- - , make_ord_flag defGhcFlag "dep-suffix" (hasArg addDepSuffix) - , make_ord_flag defGhcFlag "dep-makefile" (hasArg setDepMakefile) - , make_ord_flag defGhcFlag "include-cpp-deps" - (noArg (setDepIncludeCppDeps True)) - , make_ord_flag defGhcFlag "include-pkg-deps" - (noArg (setDepIncludePkgDeps True)) - , make_ord_flag defGhcFlag "exclude-module" (hasArg addDepExcludeMod) - - -------- Linking ---------------------------------------------------- - , make_ord_flag defGhcFlag "no-link" - (noArg (\d -> d { ghcLink=NoLink })) - , make_ord_flag defGhcFlag "shared" - (noArg (\d -> d { ghcLink=LinkDynLib })) - , make_ord_flag defGhcFlag "staticlib" - (noArg (\d -> setGeneralFlag' Opt_LinkRts (d { ghcLink=LinkStaticLib }))) - , make_ord_flag defGhcFlag "-merge-objs" - (noArg (\d -> d { ghcLink=LinkMergedObj })) - , make_ord_flag defGhcFlag "dynload" (hasArg parseDynLibLoaderMode) - , make_ord_flag defGhcFlag "dylib-install-name" (hasArg setDylibInstallName) - - ------- Libraries --------------------------------------------------- - , make_ord_flag defFlag "L" (Prefix addLibraryPath) - , make_ord_flag defFlag "l" (hasArg (addLdInputs . Option . ("-l" ++))) - - ------- Frameworks -------------------------------------------------- - -- -framework-path should really be -F ... - , make_ord_flag defFlag "framework-path" (HasArg addFrameworkPath) - , make_ord_flag defFlag "framework" (hasArg addCmdlineFramework) - - ------- Output Redirection ------------------------------------------ - , make_ord_flag defGhcFlag "odir" (hasArg setObjectDir) - , make_ord_flag defGhcFlag "o" (sepArg (setOutputFile . Just)) - , make_ord_flag defGhcFlag "dyno" - (sepArg (setDynOutputFile . Just)) - , make_ord_flag defGhcFlag "ohi" - (hasArg (setOutputHi . Just )) - , make_ord_flag defGhcFlag "dynohi" - (hasArg (setDynOutputHi . Just )) - , make_ord_flag defGhcFlag "osuf" (hasArg setObjectSuf) - , make_ord_flag defGhcFlag "dynosuf" (hasArg setDynObjectSuf) - , make_ord_flag defGhcFlag "hcsuf" (hasArg setHcSuf) - , make_ord_flag defGhcFlag "hisuf" (hasArg setHiSuf) - , make_ord_flag defGhcFlag "hiesuf" (hasArg setHieSuf) - , make_ord_flag defGhcFlag "dynhisuf" (hasArg setDynHiSuf) - , make_ord_flag defGhcFlag "hidir" (hasArg setHiDir) - , make_ord_flag defGhcFlag "hiedir" (hasArg setHieDir) - , make_ord_flag defGhcFlag "tmpdir" (hasArg setTmpDir) - , make_ord_flag defGhcFlag "stubdir" (hasArg setStubDir) - , make_ord_flag defGhcFlag "dumpdir" (hasArg setDumpDir) - , make_ord_flag defGhcFlag "outputdir" (hasArg setOutputDir) - , make_ord_flag defGhcFlag "ddump-file-prefix" - (hasArg (setDumpPrefixForce . Just . flip (++) ".")) - - , make_ord_flag defGhcFlag "dynamic-too" - (NoArg (setGeneralFlag Opt_BuildDynamicToo)) - - ------- Keeping temporary files ------------------------------------- - -- These can be singular (think ghc -c) or plural (think ghc --make) - , make_ord_flag defGhcFlag "keep-hc-file" - (NoArg (setGeneralFlag Opt_KeepHcFiles)) - , make_ord_flag defGhcFlag "keep-hc-files" - (NoArg (setGeneralFlag Opt_KeepHcFiles)) - , make_ord_flag defGhcFlag "keep-hscpp-file" - (NoArg (setGeneralFlag Opt_KeepHscppFiles)) - , make_ord_flag defGhcFlag "keep-hscpp-files" - (NoArg (setGeneralFlag Opt_KeepHscppFiles)) - , make_ord_flag defGhcFlag "keep-s-file" - (NoArg (setGeneralFlag Opt_KeepSFiles)) - , make_ord_flag defGhcFlag "keep-s-files" - (NoArg (setGeneralFlag Opt_KeepSFiles)) - , make_ord_flag defGhcFlag "keep-llvm-file" - (NoArg $ setObjBackend llvmBackend >> setGeneralFlag Opt_KeepLlvmFiles) - , make_ord_flag defGhcFlag "keep-llvm-files" - (NoArg $ setObjBackend llvmBackend >> setGeneralFlag Opt_KeepLlvmFiles) - -- This only makes sense as plural - , make_ord_flag defGhcFlag "keep-tmp-files" - (NoArg (setGeneralFlag Opt_KeepTmpFiles)) - , make_ord_flag defGhcFlag "keep-hi-file" - (NoArg (setGeneralFlag Opt_KeepHiFiles)) - , make_ord_flag defGhcFlag "no-keep-hi-file" - (NoArg (unSetGeneralFlag Opt_KeepHiFiles)) - , make_ord_flag defGhcFlag "keep-hi-files" - (NoArg (setGeneralFlag Opt_KeepHiFiles)) - , make_ord_flag defGhcFlag "no-keep-hi-files" - (NoArg (unSetGeneralFlag Opt_KeepHiFiles)) - , make_ord_flag defGhcFlag "keep-o-file" - (NoArg (setGeneralFlag Opt_KeepOFiles)) - , make_ord_flag defGhcFlag "no-keep-o-file" - (NoArg (unSetGeneralFlag Opt_KeepOFiles)) - , make_ord_flag defGhcFlag "keep-o-files" - (NoArg (setGeneralFlag Opt_KeepOFiles)) - , make_ord_flag defGhcFlag "no-keep-o-files" - (NoArg (unSetGeneralFlag Opt_KeepOFiles)) - - ------- Miscellaneous ---------------------------------------------- - , make_ord_flag defGhcFlag "no-auto-link-packages" - (NoArg (unSetGeneralFlag Opt_AutoLinkPackages)) - , make_ord_flag defGhcFlag "no-hs-main" - (NoArg (setGeneralFlag Opt_NoHsMain)) - , make_ord_flag defGhcFlag "fno-state-hack" - (NoArg (setGeneralFlag Opt_G_NoStateHack)) - , make_ord_flag defGhcFlag "fno-opt-coercion" - (NoArg (setGeneralFlag Opt_G_NoOptCoercion)) - , make_ord_flag defGhcFlag "with-rtsopts" - (HasArg setRtsOpts) - , make_ord_flag defGhcFlag "rtsopts" - (NoArg (setRtsOptsEnabled RtsOptsAll)) - , make_ord_flag defGhcFlag "rtsopts=all" - (NoArg (setRtsOptsEnabled RtsOptsAll)) - , make_ord_flag defGhcFlag "rtsopts=some" - (NoArg (setRtsOptsEnabled RtsOptsSafeOnly)) - , make_ord_flag defGhcFlag "rtsopts=none" - (NoArg (setRtsOptsEnabled RtsOptsNone)) - , make_ord_flag defGhcFlag "rtsopts=ignore" - (NoArg (setRtsOptsEnabled RtsOptsIgnore)) - , make_ord_flag defGhcFlag "rtsopts=ignoreAll" - (NoArg (setRtsOptsEnabled RtsOptsIgnoreAll)) - , make_ord_flag defGhcFlag "no-rtsopts" - (NoArg (setRtsOptsEnabled RtsOptsNone)) - , make_ord_flag defGhcFlag "no-rtsopts-suggestions" - (noArg (\d -> d {rtsOptsSuggestions = False})) - , make_ord_flag defGhcFlag "dhex-word-literals" - (NoArg (setGeneralFlag Opt_HexWordLiterals)) - - , make_ord_flag defGhcFlag "ghcversion-file" (hasArg addGhcVersionFile) - , make_ord_flag defGhcFlag "main-is" (SepArg setMainIs) - , make_ord_flag defGhcFlag "haddock" (NoArg (setGeneralFlag Opt_Haddock)) - , make_ord_flag defGhcFlag "no-haddock" (NoArg (unSetGeneralFlag Opt_Haddock)) - , make_ord_flag defGhcFlag "haddock-opts" (hasArg addHaddockOpts) - , make_ord_flag defGhcFlag "hpcdir" (SepArg setOptHpcDir) - , make_ord_flag defGhciFlag "ghci-script" (hasArg addGhciScript) - , make_ord_flag defGhciFlag "interactive-print" (hasArg setInteractivePrint) - , make_ord_flag defGhcFlag "ticky-allocd" - (NoArg (setGeneralFlag Opt_Ticky_Allocd)) - , make_ord_flag defGhcFlag "ticky-LNE" - (NoArg (setGeneralFlag Opt_Ticky_LNE)) - , make_ord_flag defGhcFlag "ticky-ap-thunk" - (NoArg (setGeneralFlag Opt_Ticky_AP)) - , make_ord_flag defGhcFlag "ticky-dyn-thunk" - (NoArg (setGeneralFlag Opt_Ticky_Dyn_Thunk)) - , make_ord_flag defGhcFlag "ticky-tag-checks" - (NoArg (setGeneralFlag Opt_Ticky_Tag)) - ------- recompilation checker -------------------------------------- - , make_dep_flag defGhcFlag "recomp" - (NoArg $ unSetGeneralFlag Opt_ForceRecomp) - "Use -fno-force-recomp instead" - , make_dep_flag defGhcFlag "no-recomp" - (NoArg $ setGeneralFlag Opt_ForceRecomp) "Use -fforce-recomp instead" - , make_ord_flag defFlag "fmax-errors" - (intSuffix (\n d -> d { maxErrors = Just (max 1 n) })) - , make_ord_flag defFlag "fno-max-errors" - (noArg (\d -> d { maxErrors = Nothing })) - , make_ord_flag defFlag "freverse-errors" - (noArg (\d -> d {reverseErrors = True} )) - , make_ord_flag defFlag "fno-reverse-errors" - (noArg (\d -> d {reverseErrors = False} )) - - ------ HsCpp opts --------------------------------------------------- - , make_ord_flag defFlag "D" (AnySuffix (upd . addOptP)) - , make_ord_flag defFlag "U" (AnySuffix (upd . addOptP)) - - ------- Include/Import Paths ---------------------------------------- - , make_ord_flag defFlag "I" (Prefix addIncludePath) - , make_ord_flag defFlag "i" (OptPrefix addImportPath) - - ------ Output style options ----------------------------------------- - , make_ord_flag defFlag "dppr-user-length" (intSuffix (\n d -> - d { pprUserLength = n })) - , make_ord_flag defFlag "dppr-cols" (intSuffix (\n d -> - d { pprCols = n })) - , make_ord_flag defFlag "fdiagnostics-color=auto" - (NoArg (upd (\d -> d { useColor = Auto }))) - , make_ord_flag defFlag "fdiagnostics-color=always" - (NoArg (upd (\d -> d { useColor = Always }))) - , make_ord_flag defFlag "fdiagnostics-color=never" - (NoArg (upd (\d -> d { useColor = Never }))) - - -- Suppress all that is suppressible in core dumps. - -- Except for uniques, as some simplifier phases introduce new variables that - -- have otherwise identical names. - , make_ord_flag defGhcFlag "dsuppress-all" - (NoArg $ do setGeneralFlag Opt_SuppressCoercions - setGeneralFlag Opt_SuppressCoercionTypes - setGeneralFlag Opt_SuppressVarKinds - setGeneralFlag Opt_SuppressModulePrefixes - setGeneralFlag Opt_SuppressTypeApplications - setGeneralFlag Opt_SuppressIdInfo - setGeneralFlag Opt_SuppressTicks - setGeneralFlag Opt_SuppressStgExts - setGeneralFlag Opt_SuppressStgReps - setGeneralFlag Opt_SuppressTypeSignatures - setGeneralFlag Opt_SuppressCoreSizes - setGeneralFlag Opt_SuppressTimestamps) - - ------ Debugging ---------------------------------------------------- - , make_ord_flag defGhcFlag "dstg-stats" - (NoArg (setGeneralFlag Opt_StgStats)) - - , make_ord_flag defGhcFlag "ddump-cmm" - (setDumpFlag Opt_D_dump_cmm) - , make_ord_flag defGhcFlag "ddump-cmm-from-stg" - (setDumpFlag Opt_D_dump_cmm_from_stg) - , make_ord_flag defGhcFlag "ddump-cmm-raw" - (setDumpFlag Opt_D_dump_cmm_raw) - , make_ord_flag defGhcFlag "ddump-cmm-verbose" - (setDumpFlag Opt_D_dump_cmm_verbose) - , make_ord_flag defGhcFlag "ddump-cmm-verbose-by-proc" - (setDumpFlag Opt_D_dump_cmm_verbose_by_proc) - , make_ord_flag defGhcFlag "ddump-cmm-cfg" - (setDumpFlag Opt_D_dump_cmm_cfg) - , make_ord_flag defGhcFlag "ddump-cmm-cbe" - (setDumpFlag Opt_D_dump_cmm_cbe) - , make_ord_flag defGhcFlag "ddump-cmm-switch" - (setDumpFlag Opt_D_dump_cmm_switch) - , make_ord_flag defGhcFlag "ddump-cmm-proc" - (setDumpFlag Opt_D_dump_cmm_proc) - , make_ord_flag defGhcFlag "ddump-cmm-sp" - (setDumpFlag Opt_D_dump_cmm_sp) - , make_ord_flag defGhcFlag "ddump-cmm-sink" - (setDumpFlag Opt_D_dump_cmm_sink) - , make_ord_flag defGhcFlag "ddump-cmm-caf" - (setDumpFlag Opt_D_dump_cmm_caf) - , make_ord_flag defGhcFlag "ddump-cmm-procmap" - (setDumpFlag Opt_D_dump_cmm_procmap) - , make_ord_flag defGhcFlag "ddump-cmm-split" - (setDumpFlag Opt_D_dump_cmm_split) - , make_ord_flag defGhcFlag "ddump-cmm-info" - (setDumpFlag Opt_D_dump_cmm_info) - , make_ord_flag defGhcFlag "ddump-cmm-cps" - (setDumpFlag Opt_D_dump_cmm_cps) - , make_ord_flag defGhcFlag "ddump-cmm-opt" - (setDumpFlag Opt_D_dump_opt_cmm) - , make_ord_flag defGhcFlag "ddump-cmm-thread-sanitizer" - (setDumpFlag Opt_D_dump_cmm_thread_sanitizer) - , make_ord_flag defGhcFlag "ddump-cfg-weights" - (setDumpFlag Opt_D_dump_cfg_weights) - , make_ord_flag defGhcFlag "ddump-core-stats" - (setDumpFlag Opt_D_dump_core_stats) - , make_ord_flag defGhcFlag "ddump-asm" - (setDumpFlag Opt_D_dump_asm) - , make_ord_flag defGhcFlag "ddump-js" - (setDumpFlag Opt_D_dump_js) - , make_ord_flag defGhcFlag "ddump-asm-native" - (setDumpFlag Opt_D_dump_asm_native) - , make_ord_flag defGhcFlag "ddump-asm-liveness" - (setDumpFlag Opt_D_dump_asm_liveness) - , make_ord_flag defGhcFlag "ddump-asm-regalloc" - (setDumpFlag Opt_D_dump_asm_regalloc) - , make_ord_flag defGhcFlag "ddump-asm-conflicts" - (setDumpFlag Opt_D_dump_asm_conflicts) - , make_ord_flag defGhcFlag "ddump-asm-regalloc-stages" - (setDumpFlag Opt_D_dump_asm_regalloc_stages) - , make_ord_flag defGhcFlag "ddump-asm-stats" - (setDumpFlag Opt_D_dump_asm_stats) - , make_ord_flag defGhcFlag "ddump-llvm" - (NoArg $ setDumpFlag' Opt_D_dump_llvm) - , make_ord_flag defGhcFlag "ddump-c-backend" - (NoArg $ setDumpFlag' Opt_D_dump_c_backend) - , make_ord_flag defGhcFlag "ddump-deriv" - (setDumpFlag Opt_D_dump_deriv) - , make_ord_flag defGhcFlag "ddump-ds" - (setDumpFlag Opt_D_dump_ds) - , make_ord_flag defGhcFlag "ddump-ds-preopt" - (setDumpFlag Opt_D_dump_ds_preopt) - , make_ord_flag defGhcFlag "ddump-foreign" - (setDumpFlag Opt_D_dump_foreign) - , make_ord_flag defGhcFlag "ddump-inlinings" - (setDumpFlag Opt_D_dump_inlinings) - , make_ord_flag defGhcFlag "ddump-verbose-inlinings" - (setDumpFlag Opt_D_dump_verbose_inlinings) - , make_ord_flag defGhcFlag "ddump-rule-firings" - (setDumpFlag Opt_D_dump_rule_firings) - , make_ord_flag defGhcFlag "ddump-rule-rewrites" - (setDumpFlag Opt_D_dump_rule_rewrites) - , make_ord_flag defGhcFlag "ddump-simpl-trace" - (setDumpFlag Opt_D_dump_simpl_trace) - , make_ord_flag defGhcFlag "ddump-occur-anal" - (setDumpFlag Opt_D_dump_occur_anal) - , make_ord_flag defGhcFlag "ddump-parsed" - (setDumpFlag Opt_D_dump_parsed) - , make_ord_flag defGhcFlag "ddump-parsed-ast" - (setDumpFlag Opt_D_dump_parsed_ast) - , make_ord_flag defGhcFlag "dkeep-comments" - (NoArg (setGeneralFlag Opt_KeepRawTokenStream)) - , make_ord_flag defGhcFlag "ddump-rn" - (setDumpFlag Opt_D_dump_rn) - , make_ord_flag defGhcFlag "ddump-rn-ast" - (setDumpFlag Opt_D_dump_rn_ast) - , make_ord_flag defGhcFlag "ddump-simpl" - (setDumpFlag Opt_D_dump_simpl) - , make_ord_flag defGhcFlag "ddump-simpl-iterations" - (setDumpFlag Opt_D_dump_simpl_iterations) - , make_ord_flag defGhcFlag "ddump-spec" - (setDumpFlag Opt_D_dump_spec) - , make_ord_flag defGhcFlag "ddump-prep" - (setDumpFlag Opt_D_dump_prep) - , make_ord_flag defGhcFlag "ddump-late-cc" - (setDumpFlag Opt_D_dump_late_cc) - , make_ord_flag defGhcFlag "ddump-stg-from-core" - (setDumpFlag Opt_D_dump_stg_from_core) - , make_ord_flag defGhcFlag "ddump-stg-unarised" - (setDumpFlag Opt_D_dump_stg_unarised) - , make_ord_flag defGhcFlag "ddump-stg-final" - (setDumpFlag Opt_D_dump_stg_final) - , make_ord_flag defGhcFlag "ddump-stg-cg" - (setDumpFlag Opt_D_dump_stg_cg) - , make_dep_flag defGhcFlag "ddump-stg" - (setDumpFlag Opt_D_dump_stg_from_core) - "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-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_ord_flag defGhcFlag "ddump-cpranal" - (setDumpFlag Opt_D_dump_cpranal) - , make_ord_flag defGhcFlag "ddump-cpr-signatures" - (setDumpFlag Opt_D_dump_cpr_signatures) - , make_ord_flag defGhcFlag "ddump-tc" - (setDumpFlag Opt_D_dump_tc) - , make_ord_flag defGhcFlag "ddump-tc-ast" - (setDumpFlag Opt_D_dump_tc_ast) - , make_ord_flag defGhcFlag "ddump-hie" - (setDumpFlag Opt_D_dump_hie) - , make_ord_flag defGhcFlag "ddump-types" - (setDumpFlag Opt_D_dump_types) - , make_ord_flag defGhcFlag "ddump-rules" - (setDumpFlag Opt_D_dump_rules) - , make_ord_flag defGhcFlag "ddump-cse" - (setDumpFlag Opt_D_dump_cse) - , make_ord_flag defGhcFlag "ddump-worker-wrapper" - (setDumpFlag Opt_D_dump_worker_wrapper) - , make_ord_flag defGhcFlag "ddump-rn-trace" - (setDumpFlag Opt_D_dump_rn_trace) - , make_ord_flag defGhcFlag "ddump-if-trace" - (setDumpFlag Opt_D_dump_if_trace) - , make_ord_flag defGhcFlag "ddump-cs-trace" - (setDumpFlag Opt_D_dump_cs_trace) - , make_ord_flag defGhcFlag "ddump-tc-trace" - (NoArg (do setDumpFlag' Opt_D_dump_tc_trace - setDumpFlag' Opt_D_dump_cs_trace)) - , make_ord_flag defGhcFlag "ddump-ec-trace" - (setDumpFlag Opt_D_dump_ec_trace) - , make_ord_flag defGhcFlag "ddump-splices" - (setDumpFlag Opt_D_dump_splices) - , make_ord_flag defGhcFlag "dth-dec-file" - (setDumpFlag Opt_D_th_dec_file) - - , make_ord_flag defGhcFlag "ddump-rn-stats" - (setDumpFlag Opt_D_dump_rn_stats) - , make_ord_flag defGhcFlag "ddump-opt-cmm" --old alias for cmm-opt - (setDumpFlag Opt_D_dump_opt_cmm) - , make_ord_flag defGhcFlag "ddump-simpl-stats" - (setDumpFlag Opt_D_dump_simpl_stats) - , make_ord_flag defGhcFlag "ddump-bcos" - (setDumpFlag Opt_D_dump_BCOs) - , make_ord_flag defGhcFlag "dsource-stats" - (setDumpFlag Opt_D_source_stats) - , make_ord_flag defGhcFlag "dverbose-core2core" - (NoArg $ setVerbosity (Just 2) >> setDumpFlag' Opt_D_verbose_core2core) - , make_ord_flag defGhcFlag "dverbose-stg2stg" - (setDumpFlag Opt_D_verbose_stg2stg) - , make_ord_flag defGhcFlag "ddump-hi" - (setDumpFlag Opt_D_dump_hi) - , make_ord_flag defGhcFlag "ddump-minimal-imports" - (NoArg (setGeneralFlag Opt_D_dump_minimal_imports)) - , make_ord_flag defGhcFlag "ddump-hpc" - (setDumpFlag Opt_D_dump_ticked) -- back compat - , make_ord_flag defGhcFlag "ddump-ticked" - (setDumpFlag Opt_D_dump_ticked) - , make_ord_flag defGhcFlag "ddump-mod-cycles" - (setDumpFlag Opt_D_dump_mod_cycles) - , make_ord_flag defGhcFlag "ddump-mod-map" - (setDumpFlag Opt_D_dump_mod_map) - , make_ord_flag defGhcFlag "ddump-timings" - (setDumpFlag Opt_D_dump_timings) - , make_ord_flag defGhcFlag "ddump-view-pattern-commoning" - (setDumpFlag Opt_D_dump_view_pattern_commoning) - , make_ord_flag defGhcFlag "ddump-to-file" - (NoArg (setGeneralFlag Opt_DumpToFile)) - , make_ord_flag defGhcFlag "ddump-hi-diffs" - (setDumpFlag Opt_D_dump_hi_diffs) - , make_ord_flag defGhcFlag "ddump-rtti" - (setDumpFlag Opt_D_dump_rtti) - , make_ord_flag defGhcFlag "dlint" - (NoArg enableDLint) - , make_ord_flag defGhcFlag "dcore-lint" - (NoArg (setGeneralFlag Opt_DoCoreLinting)) - , make_ord_flag defGhcFlag "dlinear-core-lint" - (NoArg (setGeneralFlag Opt_DoLinearCoreLinting)) - , make_ord_flag defGhcFlag "dstg-lint" - (NoArg (setGeneralFlag Opt_DoStgLinting)) - , make_ord_flag defGhcFlag "dcmm-lint" - (NoArg (setGeneralFlag Opt_DoCmmLinting)) - , make_ord_flag defGhcFlag "dasm-lint" - (NoArg (setGeneralFlag Opt_DoAsmLinting)) - , make_ord_flag defGhcFlag "dannot-lint" - (NoArg (setGeneralFlag Opt_DoAnnotationLinting)) - , make_ord_flag defGhcFlag "dtag-inference-checks" - (NoArg (setGeneralFlag Opt_DoTagInferenceChecks)) - , make_ord_flag defGhcFlag "dshow-passes" - (NoArg $ forceRecompile >> (setVerbosity $ Just 2)) - , make_ord_flag defGhcFlag "dipe-stats" - (setDumpFlag Opt_D_ipe_stats) - , make_ord_flag defGhcFlag "dfaststring-stats" - (setDumpFlag Opt_D_faststring_stats) - , make_ord_flag defGhcFlag "dno-llvm-mangler" - (NoArg (setGeneralFlag Opt_NoLlvmMangler)) -- hidden flag - , make_ord_flag defGhcFlag "dno-typeable-binds" - (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_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) - - ------ Machine dependent (-m) stuff --------------------------- - - , make_ord_flag defGhcFlag "msse" (noArg (\d -> - d { sseVersion = Just SSE1 })) - , make_ord_flag defGhcFlag "msse2" (noArg (\d -> - d { sseVersion = Just SSE2 })) - , make_ord_flag defGhcFlag "msse3" (noArg (\d -> - d { sseVersion = Just SSE3 })) - , make_ord_flag defGhcFlag "msse4" (noArg (\d -> - d { sseVersion = Just SSE4 })) - , make_ord_flag defGhcFlag "msse4.2" (noArg (\d -> - d { sseVersion = Just SSE42 })) - , make_ord_flag defGhcFlag "mbmi" (noArg (\d -> - d { bmiVersion = Just BMI1 })) - , make_ord_flag defGhcFlag "mbmi2" (noArg (\d -> - d { bmiVersion = Just BMI2 })) - , make_ord_flag defGhcFlag "mavx" (noArg (\d -> d { avx = True })) - , make_ord_flag defGhcFlag "mavx2" (noArg (\d -> d { avx2 = True })) - , make_ord_flag defGhcFlag "mavx512cd" (noArg (\d -> - d { avx512cd = True })) - , make_ord_flag defGhcFlag "mavx512er" (noArg (\d -> - d { avx512er = True })) - , make_ord_flag defGhcFlag "mavx512f" (noArg (\d -> d { avx512f = True })) - , make_ord_flag defGhcFlag "mavx512pf" (noArg (\d -> - d { avx512pf = True })) - - ------ Warning opts ------------------------------------------------- - , make_ord_flag defFlag "W" (NoArg (mapM_ setWarningFlag minusWOpts)) - , make_ord_flag defFlag "Werror" - (NoArg (do { setGeneralFlag Opt_WarnIsError - ; mapM_ setFatalWarningFlag minusWeverythingOpts })) - , make_ord_flag defFlag "Wwarn" - (NoArg (do { unSetGeneralFlag Opt_WarnIsError - ; mapM_ unSetFatalWarningFlag minusWeverythingOpts })) - -- Opt_WarnIsError is still needed to pass -Werror - -- to CPP; see runCpp in SysTools - , make_dep_flag defFlag "Wnot" (NoArg (upd (\d -> - d {warningFlags = EnumSet.empty}))) - "Use -w or -Wno-everything instead" - , make_ord_flag defFlag "w" (NoArg (upd (\d -> - d {warningFlags = EnumSet.empty}))) - - -- New-style uniform warning sets - -- - -- Note that -Weverything > -Wall > -Wextra > -Wdefault > -Wno-everything - , make_ord_flag defFlag "Weverything" (NoArg (mapM_ - setWarningFlag minusWeverythingOpts)) - , make_ord_flag defFlag "Wno-everything" - (NoArg (upd (\d -> d {warningFlags = EnumSet.empty}))) - - , make_ord_flag defFlag "Wall" (NoArg (mapM_ - setWarningFlag minusWallOpts)) - , make_ord_flag defFlag "Wno-all" (NoArg (mapM_ - unSetWarningFlag minusWallOpts)) - - , make_ord_flag defFlag "Wextra" (NoArg (mapM_ - setWarningFlag minusWOpts)) - , make_ord_flag defFlag "Wno-extra" (NoArg (mapM_ - unSetWarningFlag minusWOpts)) - - , make_ord_flag defFlag "Wdefault" (NoArg (mapM_ - setWarningFlag standardWarnings)) - , make_ord_flag defFlag "Wno-default" (NoArg (mapM_ - unSetWarningFlag standardWarnings)) - - , make_ord_flag defFlag "Wcompat" (NoArg (mapM_ - setWarningFlag minusWcompatOpts)) - , make_ord_flag defFlag "Wno-compat" (NoArg (mapM_ - unSetWarningFlag minusWcompatOpts)) - - ------ Plugin flags ------------------------------------------------ - , make_ord_flag defGhcFlag "fplugin-opt" (hasArg addPluginModuleNameOption) - , make_ord_flag defGhcFlag "fplugin-trustworthy" - (NoArg (setGeneralFlag Opt_PluginTrustworthy)) - , make_ord_flag defGhcFlag "fplugin" (hasArg addPluginModuleName) - , make_ord_flag defGhcFlag "fclear-plugins" (noArg clearPluginModuleNames) - , make_ord_flag defGhcFlag "ffrontend-opt" (hasArg addFrontendPluginOption) - - , make_ord_flag defGhcFlag "fplugin-library" (hasArg addExternalPlugin) - - ------ Optimisation flags ------------------------------------------ - , make_dep_flag defGhcFlag "Onot" (noArgM $ setOptLevel 0 ) - "Use -O0 instead" - , make_ord_flag defGhcFlag "O" (optIntSuffixM (\mb_n -> - setOptLevel (mb_n `orElse` 1))) - -- If the number is missing, use 1 - - , make_ord_flag defFlag "fbinary-blob-threshold" - (intSuffix (\n d -> d { binBlobThreshold = case fromIntegral n of - 0 -> Nothing - x -> Just x})) - , make_ord_flag defFlag "fmax-relevant-binds" - (intSuffix (\n d -> d { maxRelevantBinds = Just n })) - , make_ord_flag defFlag "fno-max-relevant-binds" - (noArg (\d -> d { maxRelevantBinds = Nothing })) - - , make_ord_flag defFlag "fmax-valid-hole-fits" - (intSuffix (\n d -> d { maxValidHoleFits = Just n })) - , make_ord_flag defFlag "fno-max-valid-hole-fits" - (noArg (\d -> d { maxValidHoleFits = Nothing })) - , make_ord_flag defFlag "fmax-refinement-hole-fits" - (intSuffix (\n d -> d { maxRefHoleFits = Just n })) - , make_ord_flag defFlag "fno-max-refinement-hole-fits" - (noArg (\d -> d { maxRefHoleFits = Nothing })) - , make_ord_flag defFlag "frefinement-level-hole-fits" - (intSuffix (\n d -> d { refLevelHoleFits = Just n })) - , make_ord_flag defFlag "fno-refinement-level-hole-fits" - (noArg (\d -> d { refLevelHoleFits = Nothing })) - - , make_dep_flag defGhcFlag "fllvm-pass-vectors-in-regs" - (noArg id) - "vectors registers are now passed in registers by default." - , make_ord_flag defFlag "fmax-uncovered-patterns" - (intSuffix (\n d -> d { maxUncoveredPatterns = n })) - , make_ord_flag defFlag "fmax-pmcheck-models" - (intSuffix (\n d -> d { maxPmCheckModels = n })) - , make_ord_flag defFlag "fsimplifier-phases" - (intSuffix (\n d -> d { simplPhases = n })) - , make_ord_flag defFlag "fmax-simplifier-iterations" - (intSuffix (\n d -> d { maxSimplIterations = n })) - , (Deprecated, defFlag "fmax-pmcheck-iterations" - (intSuffixM (\_ d -> - do { deprecate $ "use -fmax-pmcheck-models instead" - ; return d }))) - , make_ord_flag defFlag "fsimpl-tick-factor" - (intSuffix (\n d -> d { simplTickFactor = n })) - , make_ord_flag defFlag "fdmd-unbox-width" - (intSuffix (\n d -> d { dmdUnboxWidth = n })) - , make_ord_flag defFlag "fspec-constr-threshold" - (intSuffix (\n d -> d { specConstrThreshold = Just n })) - , make_ord_flag defFlag "fno-spec-constr-threshold" - (noArg (\d -> d { specConstrThreshold = Nothing })) - , make_ord_flag defFlag "fspec-constr-count" - (intSuffix (\n d -> d { specConstrCount = Just n })) - , make_ord_flag defFlag "fno-spec-constr-count" - (noArg (\d -> d { specConstrCount = Nothing })) - , make_ord_flag defFlag "fspec-constr-recursive" - (intSuffix (\n d -> d { specConstrRecursive = n })) - , make_ord_flag defFlag "fliberate-case-threshold" - (intSuffix (\n d -> d { liberateCaseThreshold = Just n })) - , make_ord_flag defFlag "fno-liberate-case-threshold" - (noArg (\d -> d { liberateCaseThreshold = Nothing })) - , make_ord_flag defFlag "drule-check" - (sepArg (\s d -> d { ruleCheck = Just s })) - , make_ord_flag defFlag "dinline-check" - (sepArg (\s d -> d { unfoldingOpts = updateReportPrefix (Just s) (unfoldingOpts d)})) - , make_ord_flag defFlag "freduction-depth" - (intSuffix (\n d -> d { reductionDepth = treatZeroAsInf n })) - , make_ord_flag defFlag "fconstraint-solver-iterations" - (intSuffix (\n d -> d { solverIterations = treatZeroAsInf n })) - , (Deprecated, defFlag "fcontext-stack" - (intSuffixM (\n d -> - do { deprecate $ "use -freduction-depth=" ++ show n ++ " instead" - ; return $ d { reductionDepth = treatZeroAsInf n } }))) - , (Deprecated, defFlag "ftype-function-depth" - (intSuffixM (\n d -> - do { deprecate $ "use -freduction-depth=" ++ show n ++ " instead" - ; return $ d { reductionDepth = treatZeroAsInf n } }))) - , make_ord_flag defFlag "fstrictness-before" - (intSuffix (\n d -> d { strictnessBefore = n : strictnessBefore d })) - , make_ord_flag defFlag "ffloat-lam-args" - (intSuffix (\n d -> d { floatLamArgs = Just n })) - , make_ord_flag defFlag "ffloat-all-lams" - (noArg (\d -> d { floatLamArgs = Nothing })) - , make_ord_flag defFlag "fstg-lift-lams-rec-args" - (intSuffix (\n d -> d { liftLamsRecArgs = Just n })) - , make_ord_flag defFlag "fstg-lift-lams-rec-args-any" - (noArg (\d -> d { liftLamsRecArgs = Nothing })) - , make_ord_flag defFlag "fstg-lift-lams-non-rec-args" - (intSuffix (\n d -> d { liftLamsNonRecArgs = Just n })) - , make_ord_flag defFlag "fstg-lift-lams-non-rec-args-any" - (noArg (\d -> d { liftLamsNonRecArgs = Nothing })) - , make_ord_flag defFlag "fstg-lift-lams-known" - (noArg (\d -> d { liftLamsKnown = True })) - , make_ord_flag defFlag "fno-stg-lift-lams-known" - (noArg (\d -> d { liftLamsKnown = False })) - , make_ord_flag defFlag "fproc-alignment" - (intSuffix (\n d -> d { cmmProcAlignment = Just n })) - , make_ord_flag defFlag "fblock-layout-weights" - (HasArg (\s -> - upd (\d -> d { cfgWeights = - parseWeights s (cfgWeights d)}))) - , make_ord_flag defFlag "fhistory-size" - (intSuffix (\n d -> d { historySize = n })) - - , make_ord_flag defFlag "funfolding-creation-threshold" - (intSuffix (\n d -> d { unfoldingOpts = updateCreationThreshold n (unfoldingOpts d)})) - , make_ord_flag defFlag "funfolding-use-threshold" - (intSuffix (\n d -> d { unfoldingOpts = updateUseThreshold n (unfoldingOpts d)})) - , make_ord_flag defFlag "funfolding-fun-discount" - (intSuffix (\n d -> d { unfoldingOpts = updateFunAppDiscount n (unfoldingOpts d)})) - , make_ord_flag defFlag "funfolding-dict-discount" - (intSuffix (\n d -> d { unfoldingOpts = updateDictDiscount n (unfoldingOpts d)})) - - , make_ord_flag defFlag "funfolding-case-threshold" - (intSuffix (\n d -> d { unfoldingOpts = updateCaseThreshold n (unfoldingOpts d)})) - , make_ord_flag defFlag "funfolding-case-scaling" - (intSuffix (\n d -> d { unfoldingOpts = updateCaseScaling n (unfoldingOpts d)})) - - , make_dep_flag defFlag "funfolding-keeness-factor" - (floatSuffix (\_ d -> d)) - "-funfolding-keeness-factor is no longer respected as of GHC 9.0" - - , make_ord_flag defFlag "fmax-worker-args" - (intSuffix (\n d -> d {maxWorkerArgs = n})) - , make_ord_flag defGhciFlag "fghci-hist-size" - (intSuffix (\n d -> d {ghciHistSize = n})) - , make_ord_flag defGhcFlag "fmax-inline-alloc-size" - (intSuffix (\n d -> d { maxInlineAllocSize = n })) - , make_ord_flag defGhcFlag "fmax-inline-memcpy-insns" - (intSuffix (\n d -> d { maxInlineMemcpyInsns = n })) - , make_ord_flag defGhcFlag "fmax-inline-memset-insns" - (intSuffix (\n d -> d { maxInlineMemsetInsns = n })) - , make_ord_flag defGhcFlag "dinitial-unique" - (word64Suffix (\n d -> d { initialUnique = n })) - , make_ord_flag defGhcFlag "dunique-increment" - (intSuffix (\n d -> d { uniqueIncrement = n })) - - ------ Profiling ---------------------------------------------------- - - -- OLD profiling flags - , make_dep_flag defGhcFlag "auto-all" - (noArg (\d -> d { profAuto = ProfAutoAll } )) - "Use -fprof-auto instead" - , make_dep_flag defGhcFlag "no-auto-all" - (noArg (\d -> d { profAuto = NoProfAuto } )) - "Use -fno-prof-auto instead" - , make_dep_flag defGhcFlag "auto" - (noArg (\d -> d { profAuto = ProfAutoExports } )) - "Use -fprof-auto-exported instead" - , make_dep_flag defGhcFlag "no-auto" - (noArg (\d -> d { profAuto = NoProfAuto } )) - "Use -fno-prof-auto instead" - , make_dep_flag defGhcFlag "caf-all" - (NoArg (setGeneralFlag Opt_AutoSccsOnIndividualCafs)) - "Use -fprof-cafs instead" - , make_dep_flag defGhcFlag "no-caf-all" - (NoArg (unSetGeneralFlag Opt_AutoSccsOnIndividualCafs)) - "Use -fno-prof-cafs instead" - - -- NEW profiling flags - , make_ord_flag defGhcFlag "fprof-auto" - (noArg (\d -> d { profAuto = ProfAutoAll } )) - , make_ord_flag defGhcFlag "fprof-auto-top" - (noArg (\d -> d { profAuto = ProfAutoTop } )) - , make_ord_flag defGhcFlag "fprof-auto-exported" - (noArg (\d -> d { profAuto = ProfAutoExports } )) - , make_ord_flag defGhcFlag "fprof-auto-calls" - (noArg (\d -> d { profAuto = ProfAutoCalls } )) - , make_ord_flag defGhcFlag "fno-prof-auto" - (noArg (\d -> d { profAuto = NoProfAuto } )) - - -- Caller-CC - , make_ord_flag defGhcFlag "fprof-callers" - (HasArg setCallerCcFilters) - ------ Compiler flags ----------------------------------------------- - - , make_ord_flag defGhcFlag "fasm" (NoArg (setObjBackend ncgBackend)) - , make_ord_flag defGhcFlag "fvia-c" (NoArg - (deprecate $ "The -fvia-c flag does nothing; " ++ - "it will be removed in a future GHC release")) - , make_ord_flag defGhcFlag "fvia-C" (NoArg - (deprecate $ "The -fvia-C flag does nothing; " ++ - "it will be removed in a future GHC release")) - , make_ord_flag defGhcFlag "fllvm" (NoArg (setObjBackend llvmBackend)) - - , make_ord_flag defFlag "fno-code" (NoArg ((upd $ \d -> - d { ghcLink=NoLink }) >> setBackend noBackend)) - , make_ord_flag defFlag "fbyte-code" - (noArgM $ \dflags -> do - setBackend interpreterBackend - pure $ flip gopt_unset Opt_ByteCodeAndObjectCode (gopt_set dflags Opt_ByteCode)) - , make_ord_flag defFlag "fobject-code" $ noArgM $ \dflags -> do - setBackend $ platformDefaultBackend (targetPlatform dflags) - dflags' <- liftEwM getCmdLineState - pure $ gopt_unset dflags' Opt_ByteCodeAndObjectCode - - , make_dep_flag defFlag "fglasgow-exts" - (NoArg enableGlasgowExts) "Use individual extensions instead" - , make_dep_flag defFlag "fno-glasgow-exts" - (NoArg disableGlasgowExts) "Use individual extensions instead" - , make_ord_flag defFlag "Wunused-binds" (NoArg enableUnusedBinds) - , make_ord_flag defFlag "Wno-unused-binds" (NoArg disableUnusedBinds) - , make_ord_flag defHiddenFlag "fwarn-unused-binds" (NoArg enableUnusedBinds) - , make_ord_flag defHiddenFlag "fno-warn-unused-binds" (NoArg - disableUnusedBinds) - - ------ Safe Haskell flags ------------------------------------------- - , make_ord_flag defFlag "fpackage-trust" (NoArg setPackageTrust) - , make_ord_flag defFlag "fno-safe-infer" (noArg (\d -> - d { safeInfer = False })) - , make_ord_flag defFlag "fno-safe-haskell" (NoArg (setSafeHaskell Sf_Ignore)) - - ------ position independent flags ---------------------------------- - , make_ord_flag defGhcFlag "fPIC" (NoArg (setGeneralFlag Opt_PIC)) - , make_ord_flag defGhcFlag "fno-PIC" (NoArg (unSetGeneralFlag Opt_PIC)) - , make_ord_flag defGhcFlag "fPIE" (NoArg (setGeneralFlag Opt_PIE)) - , make_ord_flag defGhcFlag "fno-PIE" (NoArg (unSetGeneralFlag Opt_PIE)) - - ------ Debugging flags ---------------------------------------------- - , make_ord_flag defGhcFlag "g" (OptIntSuffix setDebugLevel) - ] - ++ map (mkFlag turnOn "" setGeneralFlag ) negatableFlagsDeps - ++ map (mkFlag turnOff "no-" unSetGeneralFlag ) negatableFlagsDeps - ++ map (mkFlag turnOn "d" setGeneralFlag ) dFlagsDeps - ++ map (mkFlag turnOff "dno-" unSetGeneralFlag ) dFlagsDeps - ++ map (mkFlag turnOn "f" setGeneralFlag ) fFlagsDeps - ++ map (mkFlag turnOff "fno-" unSetGeneralFlag ) fFlagsDeps - ++ map (mkFlag turnOn "W" setWarningFlag ) wWarningFlagsDeps - ++ map (mkFlag turnOff "Wno-" unSetWarningFlag ) wWarningFlagsDeps - ++ map (mkFlag turnOn "Werror=" setWErrorFlag ) wWarningFlagsDeps - ++ map (mkFlag turnOn "Wwarn=" unSetFatalWarningFlag ) - wWarningFlagsDeps - ++ map (mkFlag turnOn "Wno-error=" unSetFatalWarningFlag ) - wWarningFlagsDeps - ++ map (mkFlag turnOn "fwarn-" setWarningFlag . hideFlag) - wWarningFlagsDeps - ++ map (mkFlag turnOff "fno-warn-" unSetWarningFlag . hideFlag) - wWarningFlagsDeps - ++ [ (NotDeprecated, unrecognisedWarning "W"), - (Deprecated, unrecognisedWarning "fwarn-"), - (Deprecated, unrecognisedWarning "fno-warn-") ] - ++ [ make_ord_flag defFlag "Werror=compat" - (NoArg (mapM_ setWErrorFlag minusWcompatOpts)) - , make_ord_flag defFlag "Wno-error=compat" - (NoArg (mapM_ unSetFatalWarningFlag minusWcompatOpts)) - , make_ord_flag defFlag "Wwarn=compat" - (NoArg (mapM_ unSetFatalWarningFlag minusWcompatOpts)) ] - ++ map (mkFlag turnOn "f" setExtensionFlag ) fLangFlagsDeps - ++ map (mkFlag turnOff "fno-" unSetExtensionFlag) fLangFlagsDeps - ++ map (mkFlag turnOn "X" setExtensionFlag ) xFlagsDeps - ++ map (mkFlag turnOff "XNo" unSetExtensionFlag) xFlagsDeps - ++ map (mkFlag turnOn "X" setLanguage ) languageFlagsDeps - ++ map (mkFlag turnOn "X" setSafeHaskell ) safeHaskellFlagsDeps - --- | This is where we handle unrecognised warning flags. We only issue a warning --- if -Wunrecognised-warning-flags is set. See #11429 for context. -unrecognisedWarning :: String -> Flag (CmdLineP DynFlags) -unrecognisedWarning prefix = defHiddenFlag prefix (Prefix action) - where - action :: String -> EwM (CmdLineP DynFlags) () - action flag = do - f <- wopt Opt_WarnUnrecognisedWarningFlags <$> liftEwM getCmdLineState - when f $ addFlagWarn (WarningWithFlag Opt_WarnUnrecognisedWarningFlags) $ - "unrecognised warning flag: -" ++ prefix ++ flag - --- See Note [Supporting CLI completion] -package_flags_deps :: [(Deprecation, Flag (CmdLineP DynFlags))] -package_flags_deps = [ - ------- Packages ---------------------------------------------------- - make_ord_flag defFlag "package-db" - (HasArg (addPkgDbRef . PkgDbPath)) - , make_ord_flag defFlag "clear-package-db" (NoArg clearPkgDb) - , make_ord_flag defFlag "no-global-package-db" (NoArg removeGlobalPkgDb) - , make_ord_flag defFlag "no-user-package-db" (NoArg removeUserPkgDb) - , make_ord_flag defFlag "global-package-db" - (NoArg (addPkgDbRef GlobalPkgDb)) - , make_ord_flag defFlag "user-package-db" - (NoArg (addPkgDbRef UserPkgDb)) - -- backwards compat with GHC<=7.4 : - , make_dep_flag defFlag "package-conf" - (HasArg $ addPkgDbRef . PkgDbPath) "Use -package-db instead" - , make_dep_flag defFlag "no-user-package-conf" - (NoArg removeUserPkgDb) "Use -no-user-package-db instead" - , make_ord_flag defGhcFlag "package-name" (HasArg $ \name -> - upd (setUnitId name)) - , make_ord_flag defGhcFlag "this-unit-id" (hasArg setUnitId) - - , make_ord_flag defGhcFlag "working-dir" (hasArg setWorkingDirectory) - , make_ord_flag defGhcFlag "this-package-name" (hasArg setPackageName) - , make_ord_flag defGhcFlag "hidden-module" (HasArg addHiddenModule) - , make_ord_flag defGhcFlag "reexported-module" (HasArg addReexportedModule) - - , make_ord_flag defFlag "package" (HasArg exposePackage) - , make_ord_flag defFlag "plugin-package-id" (HasArg exposePluginPackageId) - , make_ord_flag defFlag "plugin-package" (HasArg exposePluginPackage) - , make_ord_flag defFlag "package-id" (HasArg exposePackageId) - , make_ord_flag defFlag "hide-package" (HasArg hidePackage) - , make_ord_flag defFlag "hide-all-packages" - (NoArg (setGeneralFlag Opt_HideAllPackages)) - , make_ord_flag defFlag "hide-all-plugin-packages" - (NoArg (setGeneralFlag Opt_HideAllPluginPackages)) - , make_ord_flag defFlag "package-env" (HasArg setPackageEnv) - , make_ord_flag defFlag "ignore-package" (HasArg ignorePackage) - , make_dep_flag defFlag "syslib" (HasArg exposePackage) "Use -package instead" - , make_ord_flag defFlag "distrust-all-packages" - (NoArg (setGeneralFlag Opt_DistrustAllPackages)) - , make_ord_flag defFlag "trust" (HasArg trustPackage) - , make_ord_flag defFlag "distrust" (HasArg distrustPackage) - ] - where - setPackageEnv env = upd $ \s -> s { packageEnv = Just env } - --- | Make a list of flags for shell completion. --- Filter all available flags into two groups, for interactive GHC vs all other. -flagsForCompletion :: Bool -> [String] -flagsForCompletion isInteractive - = [ '-':flagName flag - | flag <- flagsAll - , modeFilter (flagGhcMode flag) - ] - where - modeFilter AllModes = True - modeFilter OnlyGhci = isInteractive - modeFilter OnlyGhc = not isInteractive - modeFilter HiddenFlag = False - -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 FlagSpec flag - = FlagSpec - { flagSpecName :: String -- ^ Flag in string form - , flagSpecFlag :: flag -- ^ Flag in internal form - , flagSpecAction :: (TurnOnFlag -> DynP ()) - -- ^ Extra action to run when the flag is found - -- Typically, emit a warning or error - , flagSpecGhcMode :: GhcFlagMode - -- ^ In which ghc mode the flag has effect - } - --- | Define a new flag. -flagSpec :: String -> flag -> (Deprecation, FlagSpec flag) -flagSpec name flag = flagSpec' name flag nop - --- | Define a new flag with an effect. -flagSpec' :: String -> flag -> (TurnOnFlag -> DynP ()) - -> (Deprecation, FlagSpec flag) -flagSpec' name flag act = (NotDeprecated, FlagSpec name flag act AllModes) - --- | Define a warning flag. -warnSpec :: WarningFlag -> [(Deprecation, FlagSpec WarningFlag)] -warnSpec flag = warnSpec' flag nop - --- | Define a warning flag with an effect. -warnSpec' :: WarningFlag -> (TurnOnFlag -> DynP ()) - -> [(Deprecation, FlagSpec WarningFlag)] -warnSpec' flag act = [ (NotDeprecated, FlagSpec name flag act AllModes) - | name <- NE.toList (warnFlagNames flag) - ] - --- | Define a new deprecated flag with an effect. -depFlagSpecOp :: String -> flag -> (TurnOnFlag -> DynP ()) -> String - -> (Deprecation, FlagSpec flag) -depFlagSpecOp name flag act dep = - (Deprecated, snd (flagSpec' name flag (\f -> act f >> deprecate dep))) - --- | Define a new deprecated flag. -depFlagSpec :: String -> flag -> String - -> (Deprecation, FlagSpec flag) -depFlagSpec name flag dep = depFlagSpecOp name flag nop dep - --- | Define a deprecated warning flag. -depWarnSpec :: WarningFlag -> String - -> [(Deprecation, FlagSpec WarningFlag)] -depWarnSpec flag dep = [ depFlagSpecOp name flag nop dep - | name <- NE.toList (warnFlagNames flag) - ] - --- | Define a deprecated warning name substituted by another. -subWarnSpec :: String -> WarningFlag -> String - -> [(Deprecation, FlagSpec WarningFlag)] -subWarnSpec oldname flag dep = [ depFlagSpecOp oldname flag nop dep ] - - --- | Define a new deprecated flag with an effect where the deprecation message --- depends on the flag value -depFlagSpecOp' :: String - -> flag - -> (TurnOnFlag -> DynP ()) - -> (TurnOnFlag -> String) - -> (Deprecation, FlagSpec flag) -depFlagSpecOp' name flag act dep = - (Deprecated, FlagSpec name flag (\f -> act f >> (deprecate $ dep f)) - AllModes) - --- | Define a new deprecated flag where the deprecation message --- depends on the flag value -depFlagSpec' :: String - -> flag - -> (TurnOnFlag -> String) - -> (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 - --- | Define a new flag for GHCi with an effect. -flagGhciSpec' :: String -> flag -> (TurnOnFlag -> DynP ()) - -> (Deprecation, FlagSpec flag) -flagGhciSpec' name flag act = (NotDeprecated, FlagSpec name flag act OnlyGhci) - --- | Define a new flag invisible to CLI completion. -flagHiddenSpec :: String -> flag -> (Deprecation, FlagSpec flag) -flagHiddenSpec name flag = flagHiddenSpec' name flag nop - --- | Define a new flag invisible to CLI completion with an effect. -flagHiddenSpec' :: String -> flag -> (TurnOnFlag -> DynP ()) - -> (Deprecation, FlagSpec flag) -flagHiddenSpec' name flag act = (NotDeprecated, FlagSpec name flag act - HiddenFlag) - --- | Hide a 'FlagSpec' from being displayed in @--show-options@. --- --- This is for example useful for flags that are obsolete, but should not --- (yet) be deprecated for compatibility reasons. -hideFlag :: (Deprecation, FlagSpec a) -> (Deprecation, FlagSpec a) -hideFlag (dep, fs) = (dep, fs { flagSpecGhcMode = HiddenFlag }) - -mkFlag :: TurnOnFlag -- ^ True <=> it should be turned on - -> String -- ^ The flag prefix - -> (flag -> DynP ()) -- ^ What to do when the flag is found - -> (Deprecation, FlagSpec flag) -- ^ Specification of - -- this particular flag - -> (Deprecation, Flag (CmdLineP DynFlags)) -mkFlag turn_on flagPrefix f (dep, (FlagSpec name flag extra_action mode)) - = (dep, - Flag (flagPrefix ++ name) (NoArg (f flag >> extra_action turn_on)) mode) - --- here to avoid module cycle with GHC.Driver.CmdLine -deprecate :: Monad m => String -> EwM m () -deprecate s = do - arg <- getArg - addFlagWarn (WarningWithFlag Opt_WarnDeprecatedFlags) (arg ++ " is deprecated: " ++ s) - -deprecatedForExtension :: String -> TurnOnFlag -> String -deprecatedForExtension lang turn_on - = "use -X" ++ flag ++ - " or pragma {-# LANGUAGE " ++ flag ++ " #-} instead" - where - flag | turn_on = lang - | otherwise = "No" ++ lang - -deprecatedForExtensions :: [String] -> TurnOnFlag -> String -deprecatedForExtensions [] _ = panic "new extension has not been specified" -deprecatedForExtensions [lang] turn_on = deprecatedForExtension lang turn_on -deprecatedForExtensions langExts turn_on - = "use " ++ xExt flags ++ " instead" - where - flags | turn_on = langExts - | otherwise = ("No" ++) <$> langExts - - xExt fls = intercalate " and " $ (\flag -> "-X" ++ flag) <$> fls - -useInstead :: String -> String -> TurnOnFlag -> String -useInstead prefix flag turn_on - = "Use " ++ prefix ++ no ++ flag ++ " instead" - where - no = if turn_on then "" else "no-" - -nop :: TurnOnFlag -> DynP () -nop _ = return () - --- | Find the 'FlagSpec' for a 'WarningFlag'. -flagSpecOf :: WarningFlag -> Maybe (FlagSpec WarningFlag) -flagSpecOf = flip Map.lookup wWarningFlagMap - -wWarningFlagMap :: Map.Map WarningFlag (FlagSpec WarningFlag) -wWarningFlagMap = Map.fromListWith (\_ x -> x) $ map (flagSpecFlag &&& id) wWarningFlags - --- | These @-W\@ flags can all be reversed with @-Wno-\@ -wWarningFlags :: [FlagSpec WarningFlag] -wWarningFlags = map snd (sortBy (comparing fst) wWarningFlagsDeps) - -wWarningFlagsDeps :: [(Deprecation, FlagSpec WarningFlag)] -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_WarnCPPUndef -> warnSpec x - Opt_WarnUnbangedStrictPatterns -> warnSpec x - Opt_WarnDeferredTypeErrors -> warnSpec x - Opt_WarnDeferredOutOfScopeVariables -> warnSpec x - Opt_WarnWarningsDeprecations -> warnSpec x - Opt_WarnDeprecatedFlags -> warnSpec x - Opt_WarnDerivingDefaults -> warnSpec x - Opt_WarnDerivingTypeable -> warnSpec x - Opt_WarnDodgyExports -> warnSpec x - Opt_WarnDodgyForeignImports -> warnSpec x - Opt_WarnDodgyImports -> warnSpec x - Opt_WarnEmptyEnumerations -> warnSpec x - Opt_WarnDuplicateConstraints - -> subWarnSpec "duplicate-constraints" x "it is subsumed by -Wredundant-constraints" - Opt_WarnRedundantConstraints -> warnSpec x - Opt_WarnDuplicateExports -> warnSpec x - Opt_WarnHiShadows - -> 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_WarnIncompletePatterns -> warnSpec x - Opt_WarnIncompletePatternsRecUpd -> warnSpec x - Opt_WarnIncompleteUniPatterns -> warnSpec x - Opt_WarnInlineRuleShadowing -> warnSpec x - Opt_WarnIdentities -> warnSpec x - Opt_WarnLoopySuperclassSolve -> warnSpec x - 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" - ++ warnSpec x - Opt_WarnMissingMethods -> warnSpec x - Opt_WarnMissingMonadFailInstances - -> depWarnSpec x "fail is no longer a method of Monad" - Opt_WarnSemigroup -> warnSpec x - Opt_WarnMissingSignatures -> warnSpec x - Opt_WarnMissingKindSignatures -> warnSpec x - Opt_WarnMissingExportedSignatures - -> subWarnSpec "missing-exported-sigs" x "it is replaced by -Wmissing-exported-signatures" - ++ warnSpec x - 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_WarnNonCanonicalMonoidInstances -> warnSpec x - Opt_WarnOrphans -> warnSpec x - Opt_WarnOverflowedLiterals -> warnSpec x - Opt_WarnOverlappingPatterns -> warnSpec x - Opt_WarnMissedSpecs -> warnSpec x - Opt_WarnAllMissedSpecs -> warnSpec x - Opt_WarnSafe -> warnSpec' x setWarnSafe - Opt_WarnTrustworthySafe -> warnSpec x - Opt_WarnInferredSafeImports -> warnSpec x - Opt_WarnMissingSafeHaskellMode -> warnSpec x - Opt_WarnTabs -> warnSpec x - Opt_WarnTypeDefaults -> warnSpec x - Opt_WarnTypedHoles -> warnSpec x - Opt_WarnPartialTypeSignatures -> warnSpec x - Opt_WarnUnrecognisedPragmas -> warnSpec x - Opt_WarnMisplacedPragmas -> warnSpec x - Opt_WarnUnsafe -> warnSpec' x setWarnUnsafe - Opt_WarnUnsupportedCallingConventions -> warnSpec x - Opt_WarnUnsupportedLlvmVersion -> warnSpec x - Opt_WarnMissedExtraSharedLib -> warnSpec x - Opt_WarnUntickedPromotedConstructors -> warnSpec x - Opt_WarnUnusedDoBind -> warnSpec x - Opt_WarnUnusedForalls -> warnSpec x - Opt_WarnUnusedImports -> warnSpec x - Opt_WarnUnusedLocalBinds -> warnSpec x - Opt_WarnUnusedMatches -> warnSpec x - Opt_WarnUnusedPatternBinds -> warnSpec x - Opt_WarnUnusedTopBinds -> warnSpec x - Opt_WarnUnusedTypePatterns -> warnSpec x - Opt_WarnUnusedRecordWildcards -> warnSpec x - Opt_WarnRedundantBangPatterns -> warnSpec x - Opt_WarnRedundantRecordWildcards -> warnSpec x - Opt_WarnRedundantStrictnessFlags -> warnSpec x - Opt_WarnWrongDoBind -> warnSpec x - Opt_WarnMissingPatternSynonymSignatures -> warnSpec x - Opt_WarnMissingDerivingStrategies -> warnSpec x - Opt_WarnSimplifiableClassConstraints -> warnSpec x - Opt_WarnMissingHomeModules -> warnSpec x - Opt_WarnUnrecognisedWarningFlags -> warnSpec x - Opt_WarnStarBinder -> warnSpec x - Opt_WarnStarIsType -> warnSpec x - Opt_WarnSpaceAfterBang - -> depWarnSpec x "bang patterns can no longer be written with a space" - Opt_WarnPartialFields -> warnSpec x - Opt_WarnPrepositiveQualifiedModule -> warnSpec x - Opt_WarnUnusedPackages -> warnSpec x - Opt_WarnCompatUnqualifiedImports -> warnSpec x - 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_WarnUnicodeBidirectionalFormatCharacters -> warnSpec x - Opt_WarnGADTMonoLocalBinds -> warnSpec x - Opt_WarnTypeEqualityOutOfScope -> warnSpec x - Opt_WarnTypeEqualityRequiresOperators -> warnSpec x - --- | These @-\@ flags can all be reversed with @-no-\@ -negatableFlagsDeps :: [(Deprecation, FlagSpec GeneralFlag)] -negatableFlagsDeps = [ - flagGhciSpec "ignore-dot-ghci" Opt_IgnoreDotGhci ] - --- | These @-d\@ flags can all be reversed with @-dno-\@ -dFlagsDeps :: [(Deprecation, FlagSpec GeneralFlag)] -dFlagsDeps = [ --- See Note [Updating flag description in the User's Guide] --- See Note [Supporting CLI completion] --- Please keep the list of flags below sorted alphabetically - flagSpec "ppr-case-as-let" Opt_PprCaseAsLet, - depFlagSpec' "ppr-ticks" Opt_PprShowTicks - (\turn_on -> useInstead "-d" "suppress-ticks" (not turn_on)), - flagSpec "suppress-ticks" Opt_SuppressTicks, - depFlagSpec' "suppress-stg-free-vars" Opt_SuppressStgExts - (useInstead "-d" "suppress-stg-exts"), - flagSpec "suppress-stg-exts" Opt_SuppressStgExts, - flagSpec "suppress-stg-reps" Opt_SuppressStgReps, - flagSpec "suppress-coercions" Opt_SuppressCoercions, - flagSpec "suppress-coercion-types" Opt_SuppressCoercionTypes, - flagSpec "suppress-idinfo" Opt_SuppressIdInfo, - flagSpec "suppress-unfoldings" Opt_SuppressUnfoldings, - flagSpec "suppress-module-prefixes" Opt_SuppressModulePrefixes, - flagSpec "suppress-timestamps" Opt_SuppressTimestamps, - flagSpec "suppress-type-applications" Opt_SuppressTypeApplications, - flagSpec "suppress-type-signatures" Opt_SuppressTypeSignatures, - flagSpec "suppress-uniques" Opt_SuppressUniques, - flagSpec "suppress-var-kinds" Opt_SuppressVarKinds, - flagSpec "suppress-core-sizes" Opt_SuppressCoreSizes - ] - --- | These @-f\@ flags can all be reversed with @-fno-\@ -fFlags :: [FlagSpec GeneralFlag] -fFlags = map snd fFlagsDeps - -fFlagsDeps :: [(Deprecation, FlagSpec GeneralFlag)] -fFlagsDeps = [ --- See Note [Updating flag description in the User's Guide] --- See Note [Supporting CLI completion] --- Please keep the list of flags below sorted alphabetically - depFlagSpec "asm-shortcutting" Opt_AsmShortcutting - "this flag is disabled on this ghc version due to unsoundness concerns (https://gitlab.haskell.org/ghc/ghc/-/issues/24507)", - flagGhciSpec "break-on-error" Opt_BreakOnError, - flagGhciSpec "break-on-exception" Opt_BreakOnException, - flagSpec "building-cabal-package" Opt_BuildingCabalPackage, - flagSpec "call-arity" Opt_CallArity, - flagSpec "exitification" Opt_Exitification, - flagSpec "case-merge" Opt_CaseMerge, - flagSpec "case-folding" Opt_CaseFolding, - flagSpec "cmm-elim-common-blocks" Opt_CmmElimCommonBlocks, - flagSpec "cmm-sink" Opt_CmmSink, - flagSpec "cmm-static-pred" Opt_CmmStaticPred, - flagSpec "cse" Opt_CSE, - flagSpec "stg-cse" Opt_StgCSE, - flagSpec "stg-lift-lams" Opt_StgLiftLams, - flagSpec "cpr-anal" Opt_CprAnal, - flagSpec "defer-diagnostics" Opt_DeferDiagnostics, - flagSpec "defer-type-errors" Opt_DeferTypeErrors, - flagSpec "defer-typed-holes" Opt_DeferTypedHoles, - flagSpec "defer-out-of-scope-variables" Opt_DeferOutOfScopeVariables, - flagSpec "diagnostics-show-caret" Opt_DiagnosticsShowCaret, - -- With-ways needs to be reversible hence why its made via flagSpec unlike - -- other debugging flags. - flagSpec "dump-with-ways" Opt_DumpWithWays, - flagSpec "dicts-cheap" Opt_DictsCheap, - flagSpec "dicts-strict" Opt_DictsStrict, - depFlagSpec "dmd-tx-dict-sel" - Opt_DmdTxDictSel "effect is now unconditionally enabled", - flagSpec "do-eta-reduction" Opt_DoEtaReduction, - flagSpec "do-lambda-eta-expansion" Opt_DoLambdaEtaExpansion, - flagSpec "eager-blackholing" Opt_EagerBlackHoling, - 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-internal-symbols" Opt_ExposeInternalSymbols, - flagSpec "external-dynamic-refs" Opt_ExternalDynamicRefs, - flagSpec "external-interpreter" Opt_ExternalInterpreter, - flagSpec "family-application-cache" Opt_FamAppCache, - flagSpec "float-in" Opt_FloatIn, - flagSpec "force-recomp" Opt_ForceRecomp, - flagSpec "ignore-optim-changes" Opt_IgnoreOptimChanges, - flagSpec "ignore-hpc-changes" Opt_IgnoreHpcChanges, - flagSpec "full-laziness" Opt_FullLaziness, - depFlagSpec' "fun-to-thunk" Opt_FunToThunk - (useInstead "-f" "full-laziness"), - flagSpec "local-float-out" Opt_LocalFloatOut, - flagSpec "local-float-out-top-level" Opt_LocalFloatOutTopLevel, - flagSpec "gen-manifest" Opt_GenManifest, - flagSpec "ghci-history" Opt_GhciHistory, - flagSpec "ghci-leak-check" Opt_GhciLeakCheck, - flagSpec "validate-ide-info" Opt_ValidateHie, - flagGhciSpec "local-ghci-history" Opt_LocalGhciHistory, - flagGhciSpec "no-it" Opt_NoIt, - flagSpec "ghci-sandbox" Opt_GhciSandbox, - flagSpec "helpful-errors" Opt_HelpfulErrors, - flagSpec "hpc" Opt_Hpc, - flagSpec "ignore-asserts" Opt_IgnoreAsserts, - flagSpec "ignore-interface-pragmas" Opt_IgnoreInterfacePragmas, - flagGhciSpec "implicit-import-qualified" Opt_ImplicitImportQualified, - flagSpec "irrefutable-tuples" Opt_IrrefutableTuples, - flagSpec "keep-going" Opt_KeepGoing, - 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, - flagSpec "block-layout-weightless" Opt_WeightlessBlocklayout, - flagSpec "omit-interface-pragmas" Opt_OmitInterfacePragmas, - flagSpec "omit-yields" Opt_OmitYields, - flagSpec "optimal-applicative-do" Opt_OptimalApplicativeDo, - flagSpec "pedantic-bottoms" Opt_PedanticBottoms, - flagSpec "pre-inlining" Opt_SimplPreInlining, - flagGhciSpec "print-bind-contents" Opt_PrintBindContents, - flagGhciSpec "print-bind-result" Opt_PrintBindResult, - flagGhciSpec "print-evld-with-show" Opt_PrintEvldWithShow, - flagSpec "print-explicit-foralls" Opt_PrintExplicitForalls, - flagSpec "print-explicit-kinds" Opt_PrintExplicitKinds, - flagSpec "print-explicit-coercions" Opt_PrintExplicitCoercions, - flagSpec "print-explicit-runtime-reps" Opt_PrintExplicitRuntimeReps, - flagSpec "print-equality-relations" Opt_PrintEqualityRelations, - flagSpec "print-axiom-incomps" Opt_PrintAxiomIncomps, - flagSpec "print-unicode-syntax" Opt_PrintUnicodeSyntax, - flagSpec "print-expanded-synonyms" Opt_PrintExpandedSynonyms, - flagSpec "print-potential-instances" Opt_PrintPotentialInstances, - flagSpec "print-redundant-promotion-ticks" Opt_PrintRedundantPromotionTicks, - flagSpec "print-typechecker-elaboration" Opt_PrintTypecheckerElaboration, - flagSpec "prof-cafs" Opt_AutoSccsOnIndividualCafs, - flagSpec "prof-count-entries" Opt_ProfCountEntries, - flagSpec "prof-late" Opt_ProfLateCcs, - flagSpec "prof-manual" Opt_ProfManualCcs, - flagSpec "prof-late-inline" Opt_ProfLateInlineCcs, - flagSpec "regs-graph" Opt_RegsGraph, - flagSpec "regs-iterative" Opt_RegsIterative, - depFlagSpec' "rewrite-rules" Opt_EnableRewriteRules - (useInstead "-f" "enable-rewrite-rules"), - flagSpec "shared-implib" Opt_SharedImplib, - flagSpec "spec-constr" Opt_SpecConstr, - flagSpec "spec-constr-keen" Opt_SpecConstrKeen, - flagSpec "specialise" Opt_Specialise, - flagSpec "specialize" Opt_Specialise, - flagSpec "specialise-aggressively" Opt_SpecialiseAggressively, - flagSpec "specialize-aggressively" Opt_SpecialiseAggressively, - flagSpec "cross-module-specialise" Opt_CrossModuleSpecialise, - flagSpec "cross-module-specialize" Opt_CrossModuleSpecialise, - flagSpec "polymorphic-specialisation" Opt_PolymorphicSpecialisation, - flagSpec "inline-generics" Opt_InlineGenerics, - flagSpec "inline-generics-aggressively" Opt_InlineGenericsAggressively, - flagSpec "static-argument-transformation" Opt_StaticArgumentTransformation, - flagSpec "strictness" Opt_Strictness, - flagSpec "use-rpaths" Opt_RPath, - flagSpec "write-interface" Opt_WriteInterface, - flagSpec "write-if-simplified-core" Opt_WriteIfSimplifiedCore, - flagSpec "write-ide-info" Opt_WriteHie, - flagSpec "unbox-small-strict-fields" Opt_UnboxSmallStrictFields, - flagSpec "unbox-strict-fields" Opt_UnboxStrictFields, - flagSpec "version-macros" Opt_VersionMacros, - flagSpec "worker-wrapper" Opt_WorkerWrapper, - flagSpec "worker-wrapper-cbv" Opt_WorkerWrapperUnlift, -- See Note [Worker/wrapper for strict arguments] - flagSpec "solve-constant-dicts" Opt_SolveConstantDicts, - flagSpec "catch-nonexhaustive-cases" Opt_CatchNonexhaustiveCases, - flagSpec "alignment-sanitisation" Opt_AlignmentSanitisation, - flagSpec "check-prim-bounds" Opt_DoBoundsChecking, - 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, - flagSpec "show-loaded-modules" Opt_ShowLoadedModules, - flagSpec "whole-archive-hs-libs" Opt_WholeArchiveHsLibs, - flagSpec "keep-cafs" Opt_KeepCAFs, - flagSpec "link-rts" Opt_LinkRts, - flagSpec "byte-code-and-object-code" Opt_ByteCodeAndObjectCode, - flagSpec "prefer-byte-code" Opt_UseBytecodeRatherThanObjects, - flagSpec' "compact-unwind" Opt_CompactUnwind - (\turn_on -> updM (\dflags -> do - unless (platformOS (targetPlatform dflags) == OSDarwin && turn_on) - (addWarn "-compact-unwind is only implemented by the darwin platform. Ignoring.") - return dflags)), - flagSpec "show-error-context" Opt_ShowErrorContext, - flagSpec "cmm-thread-sanitizer" Opt_CmmThreadSanitizer, - flagSpec "split-sections" Opt_SplitSections, - flagSpec "distinct-constructor-tables" Opt_DistinctConstructorTables, - flagSpec "info-table-map" Opt_InfoTableMap, - flagSpec "info-table-map-with-stack" Opt_InfoTableMapWithStack, - flagSpec "info-table-map-with-fallback" Opt_InfoTableMapWithFallback - ] - ++ fHoleFlags - --- | These @-f\@ flags have to do with the typed-hole error message or --- the valid hole fits in that message. See Note [Valid hole fits include ...] --- in the "GHC.Tc.Errors.Hole" module. These flags can all be reversed with --- @-fno-\@ -fHoleFlags :: [(Deprecation, FlagSpec GeneralFlag)] -fHoleFlags = [ - flagSpec "show-hole-constraints" Opt_ShowHoleConstraints, - depFlagSpec' "show-valid-substitutions" Opt_ShowValidHoleFits - (useInstead "-f" "show-valid-hole-fits"), - flagSpec "show-valid-hole-fits" Opt_ShowValidHoleFits, - -- Sorting settings - flagSpec "sort-valid-hole-fits" Opt_SortValidHoleFits, - flagSpec "sort-by-size-hole-fits" Opt_SortBySizeHoleFits, - flagSpec "sort-by-subsumption-hole-fits" Opt_SortBySubsumHoleFits, - flagSpec "abstract-refinement-hole-fits" Opt_AbstractRefHoleFits, - -- Output format settings - flagSpec "show-hole-matches-of-hole-fits" Opt_ShowMatchesOfHoleFits, - flagSpec "show-provenance-of-hole-fits" Opt_ShowProvOfHoleFits, - flagSpec "show-type-of-hole-fits" Opt_ShowTypeOfHoleFits, - flagSpec "show-type-app-of-hole-fits" Opt_ShowTypeAppOfHoleFits, - flagSpec "show-type-app-vars-of-hole-fits" Opt_ShowTypeAppVarsOfHoleFits, - flagSpec "show-docs-of-hole-fits" Opt_ShowDocsOfHoleFits, - flagSpec "unclutter-valid-hole-fits" Opt_UnclutterValidHoleFits - ] - --- | These @-f\@ flags can all be reversed with @-fno-\@ -fLangFlags :: [FlagSpec LangExt.Extension] -fLangFlags = map snd fLangFlagsDeps - -fLangFlagsDeps :: [(Deprecation, FlagSpec LangExt.Extension)] -fLangFlagsDeps = [ --- See Note [Updating flag description in the User's Guide] --- See Note [Supporting CLI completion] - depFlagSpecOp' "th" LangExt.TemplateHaskell - checkTemplateHaskellOk - (deprecatedForExtension "TemplateHaskell"), - depFlagSpec' "fi" LangExt.ForeignFunctionInterface - (deprecatedForExtension "ForeignFunctionInterface"), - depFlagSpec' "ffi" LangExt.ForeignFunctionInterface - (deprecatedForExtension "ForeignFunctionInterface"), - depFlagSpec' "arrows" LangExt.Arrows - (deprecatedForExtension "Arrows"), - depFlagSpec' "implicit-prelude" LangExt.ImplicitPrelude - (deprecatedForExtension "ImplicitPrelude"), - depFlagSpec' "bang-patterns" LangExt.BangPatterns - (deprecatedForExtension "BangPatterns"), - depFlagSpec' "monomorphism-restriction" LangExt.MonomorphismRestriction - (deprecatedForExtension "MonomorphismRestriction"), - depFlagSpec' "extended-default-rules" LangExt.ExtendedDefaultRules - (deprecatedForExtension "ExtendedDefaultRules"), - depFlagSpec' "implicit-params" LangExt.ImplicitParams - (deprecatedForExtension "ImplicitParams"), - depFlagSpec' "scoped-type-variables" LangExt.ScopedTypeVariables - (deprecatedForExtension "ScopedTypeVariables"), - depFlagSpec' "allow-overlapping-instances" LangExt.OverlappingInstances - (deprecatedForExtension "OverlappingInstances"), - depFlagSpec' "allow-undecidable-instances" LangExt.UndecidableInstances - (deprecatedForExtension "UndecidableInstances"), - depFlagSpec' "allow-incoherent-instances" LangExt.IncoherentInstances - (deprecatedForExtension "IncoherentInstances") - ] - -supportedLanguages :: [String] -supportedLanguages = map (flagSpecName . snd) languageFlagsDeps - -supportedLanguageOverlays :: [String] -supportedLanguageOverlays = map (flagSpecName . snd) safeHaskellFlagsDeps - -supportedExtensions :: ArchOS -> [String] -supportedExtensions (ArchOS _ os) = concatMap toFlagSpecNamePair xFlags - where - toFlagSpecNamePair flg - -- IMPORTANT! Make sure that `ghc --supported-extensions` omits - -- "TemplateHaskell"/"QuasiQuotes" when it's known not to work out of the - -- box. See also GHC #11102 and #16331 for more details about - -- the rationale - | isAIX, flagSpecFlag flg == LangExt.TemplateHaskell = [noName] - | isAIX, flagSpecFlag flg == LangExt.QuasiQuotes = [noName] - | otherwise = [name, noName] - where - isAIX = os == OSAIX - noName = "No" ++ name - name = flagSpecName flg - -supportedLanguagesAndExtensions :: ArchOS -> [String] -supportedLanguagesAndExtensions arch_os = - supportedLanguages ++ supportedLanguageOverlays ++ supportedExtensions arch_os - --- | These -X flags cannot be reversed with -XNo -languageFlagsDeps :: [(Deprecation, FlagSpec Language)] -languageFlagsDeps = [ - flagSpec "Haskell98" Haskell98, - flagSpec "Haskell2010" Haskell2010, - flagSpec "GHC2021" GHC2021 - ] - --- | These -X flags cannot be reversed with -XNo --- They are used to place hard requirements on what GHC Haskell language --- features can be used. -safeHaskellFlagsDeps :: [(Deprecation, FlagSpec SafeHaskellMode)] -safeHaskellFlagsDeps = [mkF Sf_Unsafe, mkF Sf_Trustworthy, mkF Sf_Safe] - where mkF flag = flagSpec (show flag) flag - --- | These -X flags can all be reversed with -XNo -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 "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 "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 - ] - -defaultFlags :: Settings -> [GeneralFlag] -defaultFlags settings --- See Note [Updating flag description in the User's Guide] - = [ Opt_AutoLinkPackages, - Opt_DiagnosticsShowCaret, - Opt_EmbedManifest, - Opt_FamAppCache, - Opt_GenManifest, - Opt_GhciHistory, - Opt_GhciSandbox, - Opt_HelpfulErrors, - Opt_KeepHiFiles, - Opt_KeepOFiles, - Opt_OmitYields, - Opt_PrintBindContents, - Opt_ProfCountEntries, - Opt_SharedImplib, - Opt_SimplPreInlining, - Opt_VersionMacros, - Opt_RPath, - Opt_DumpWithWays, - Opt_CompactUnwind, - Opt_ShowErrorContext, - Opt_SuppressStgReps - ] - - ++ [f | (ns,f) <- optLevelFlags, 0 `elem` ns] - -- The default -O0 options - - -- 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 --- fits in typed-hole error messages. See Note [Valid hole fits include ...] - -- in the "GHC.Tc.Errors.Hole" module. -validHoleFitDefaults :: [GeneralFlag] -validHoleFitDefaults - = [ Opt_ShowTypeAppOfHoleFits - , Opt_ShowTypeOfHoleFits - , Opt_ShowProvOfHoleFits - , Opt_ShowMatchesOfHoleFits - , Opt_ShowValidHoleFits - , Opt_SortValidHoleFits - , Opt_SortBySizeHoleFits - , Opt_ShowHoleConstraints ] - - -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) ] - -default_PIC :: Platform -> [GeneralFlag] -default_PIC platform = - case (platformOS platform, platformArch platform) of - -- Darwin always requires PIC. Especially on more recent macOS releases - -- there will be a 4GB __ZEROPAGE that prevents us from using 32bit addresses - -- while we could work around this on x86_64 (like WINE does), we won't be - -- able on aarch64, where this is enforced. - (OSDarwin, ArchX86_64) -> [Opt_PIC] - -- For AArch64, we need to always have PIC enabled. The relocation model - -- on AArch64 does not permit arbitrary relocations. Under ASLR, we can't - -- control much how far apart symbols are in memory for our in-memory static - -- linker; and thus need to ensure we get sufficiently capable relocations. - -- This requires PIC on AArch64, and ExternalDynamicRefs on Linux as on top - -- of that. Subsequently we expect all code on aarch64/linux (and macOS) to - -- be built with -fPIC. - (OSDarwin, ArchAArch64) -> [Opt_PIC] - (OSLinux, ArchAArch64) -> [Opt_PIC, Opt_ExternalDynamicRefs] - (OSLinux, ArchARM {}) -> [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. - _ -> [] - --- 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) - - -- The extensions needed to declare an H98 unlifted data type - , (LangExt.UnliftedDatatypes, turnOn, LangExt.DataKinds) - , (LangExt.UnliftedDatatypes, turnOn, LangExt.StandaloneKindSignatures) - ] - --- Note [When is StarIsType enabled] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- The StarIsType extension determines whether to treat '*' as a regular type --- operator or as a synonym for 'Data.Kind.Type'. Many existing pre-TypeInType --- programs expect '*' to be synonymous with 'Type', so by default StarIsType is --- enabled. --- --- Programs that use TypeOperators might expect to repurpose '*' for --- multiplication or another binary operation, but making TypeOperators imply --- NoStarIsType caused too much breakage on Hackage. --- - --- Note [Documenting optimisation flags] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- --- If you change the list of flags enabled for particular optimisation levels --- please remember to update the User's Guide. The relevant file is: --- --- docs/users_guide/using-optimisation.rst --- --- Make sure to note whether a flag is implied by -O0, -O or -O2. - -optLevelFlags :: [([Int], GeneralFlag)] --- 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) - , ([0,1,2], Opt_ProfManualCcs ) - , ([2], Opt_DictsStrict) - - , ([0], Opt_IgnoreInterfacePragmas) - , ([0], Opt_OmitInterfacePragmas) - - , ([1,2], Opt_CoreConstantFolding) - - , ([1,2], Opt_CallArity) - , ([1,2], Opt_Exitification) - , ([1,2], Opt_CaseMerge) - , ([1,2], Opt_CaseFolding) - , ([1,2], Opt_CmmElimCommonBlocks) - -- Disabled due to #24507 - -- , ([2], Opt_AsmShortcutting) - , ([1,2], Opt_CmmSink) - , ([1,2], Opt_CmmStaticPred) - , ([1,2], Opt_CSE) - , ([1,2], Opt_StgCSE) - , ([2], Opt_StgLiftLams) - , ([1,2], Opt_CmmControlFlow) - - , ([1,2], Opt_EnableRewriteRules) - -- Off for -O0. Otherwise we desugar list literals - -- to 'build' but don't run the simplifier passes that - -- would rewrite them back to cons cells! This seems - -- silly, and matters for the GHCi debugger. - - , ([1,2], Opt_FloatIn) - , ([1,2], Opt_FullLaziness) - , ([1,2], Opt_IgnoreAsserts) - , ([1,2], Opt_Loopification) - , ([1,2], Opt_CfgBlocklayout) -- Experimental - - , ([1,2], Opt_Specialise) - , ([1,2], Opt_CrossModuleSpecialise) - , ([1,2], Opt_InlineGenerics) - , ([1,2], Opt_Strictness) - , ([1,2], Opt_UnboxSmallStrictFields) - , ([1,2], Opt_CprAnal) - , ([1,2], Opt_WorkerWrapper) - , ([1,2], Opt_SolveConstantDicts) - , ([1,2], Opt_NumConstantFolding) - - , ([2], Opt_LiberateCase) - , ([2], Opt_SpecConstr) - , ([2], Opt_FastPAPCalls) --- , ([2], Opt_RegsGraph) --- RegsGraph suffers performance regression. See #7679 --- , ([2], Opt_StaticArgumentTransformation) --- Static Argument Transformation needs investigation. See #9374 - , ([0,1,2], Opt_SpecEval) - , ([0,1,2], Opt_SpecEvalDictFun) - ] - - -enableUnusedBinds :: DynP () -enableUnusedBinds = mapM_ setWarningFlag unusedBindsFlags - -disableUnusedBinds :: DynP () -disableUnusedBinds = mapM_ unSetWarningFlag unusedBindsFlags - --- | Things you get with `-dlint`. -enableDLint :: DynP () -enableDLint = do - mapM_ setGeneralFlag dLintFlags - addWayDynP WayDebug - where - dLintFlags :: [GeneralFlag] - dLintFlags = - [ Opt_DoCoreLinting - , Opt_DoStgLinting - , Opt_DoCmmLinting - , Opt_DoAsmLinting - , Opt_CatchNonexhaustiveCases - , Opt_LlvmFillUndefWithGarbage - ] - -enableGlasgowExts :: DynP () -enableGlasgowExts = do setGeneralFlag Opt_PrintExplicitForalls - mapM_ setExtensionFlag glasgowExtsFlags - -disableGlasgowExts :: DynP () -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 }) -setWarnSafe False = return () - -setWarnUnsafe :: Bool -> DynP () -setWarnUnsafe True = getCurLoc >>= \l -> upd (\d -> d { warnUnsafeOnLoc = l }) -setWarnUnsafe False = return () - -setPackageTrust :: DynP () -setPackageTrust = do - setGeneralFlag Opt_PackageTrust - l <- getCurLoc - upd $ \d -> d { pkgTrustOnLoc = l } - -setGenDeriving :: TurnOnFlag -> DynP () -setGenDeriving True = getCurLoc >>= \l -> upd (\d -> d { newDerivOnLoc = l }) -setGenDeriving False = return () - -setDeriveVia :: TurnOnFlag -> DynP () -setDeriveVia True = getCurLoc >>= \l -> upd (\d -> d { deriveViaOnLoc = l }) -setDeriveVia False = return () - -setOverlappingInsts :: TurnOnFlag -> DynP () -setOverlappingInsts False = return () -setOverlappingInsts True = do - l <- getCurLoc - upd (\d -> d { overlapInstLoc = l }) - -setIncoherentInsts :: TurnOnFlag -> DynP () -setIncoherentInsts False = return () -setIncoherentInsts True = do - l <- getCurLoc - upd (\d -> d { incoherentOnLoc = l }) - -checkTemplateHaskellOk :: TurnOnFlag -> DynP () -checkTemplateHaskellOk _turn_on - = getCurLoc >>= \l -> upd (\d -> d { thOnLoc = l }) - -{- ********************************************************************** -%* * - DynFlags constructors -%* * -%********************************************************************* -} - -type DynP = EwM (CmdLineP DynFlags) - -upd :: (DynFlags -> DynFlags) -> DynP () -upd f = liftEwM (do dflags <- getCmdLineState - putCmdLineState $! f dflags) - -updM :: (DynFlags -> DynP DynFlags) -> DynP () -updM f = do dflags <- liftEwM getCmdLineState - dflags' <- f dflags - liftEwM $ putCmdLineState $! dflags' - ---------------- Constructor functions for OptKind ----------------- -noArg :: (DynFlags -> DynFlags) -> OptKind (CmdLineP DynFlags) -noArg fn = NoArg (upd fn) - -noArgM :: (DynFlags -> DynP DynFlags) -> OptKind (CmdLineP DynFlags) -noArgM fn = NoArg (updM fn) - -hasArg :: (String -> DynFlags -> DynFlags) -> OptKind (CmdLineP DynFlags) -hasArg fn = HasArg (upd . fn) - -sepArg :: (String -> DynFlags -> DynFlags) -> OptKind (CmdLineP DynFlags) -sepArg fn = SepArg (upd . fn) - -intSuffix :: (Int -> DynFlags -> DynFlags) -> OptKind (CmdLineP DynFlags) -intSuffix fn = IntSuffix (\n -> upd (fn n)) - -intSuffixM :: (Int -> DynFlags -> DynP DynFlags) -> OptKind (CmdLineP DynFlags) -intSuffixM fn = IntSuffix (\n -> updM (fn n)) - -word64Suffix :: (Word64 -> DynFlags -> DynFlags) -> OptKind (CmdLineP DynFlags) -word64Suffix fn = Word64Suffix (\n -> upd (fn n)) - -floatSuffix :: (Float -> DynFlags -> DynFlags) -> OptKind (CmdLineP DynFlags) -floatSuffix fn = FloatSuffix (\n -> upd (fn n)) - -optIntSuffixM :: (Maybe Int -> DynFlags -> DynP DynFlags) - -> OptKind (CmdLineP DynFlags) -optIntSuffixM fn = OptIntSuffix (\mi -> updM (fn mi)) - -setDumpFlag :: DumpFlag -> OptKind (CmdLineP DynFlags) -setDumpFlag dump_flag = NoArg (setDumpFlag' dump_flag) - --------------------------- -addWayDynP :: Way -> DynP () -addWayDynP = upd . addWay' - -addWay' :: Way -> DynFlags -> DynFlags -addWay' w dflags0 = - let platform = targetPlatform dflags0 - dflags1 = dflags0 { targetWays_ = addWay w (targetWays_ dflags0) } - dflags2 = foldr setGeneralFlag' dflags1 - (wayGeneralFlags platform w) - dflags3 = foldr unSetGeneralFlag' dflags2 - (wayUnsetGeneralFlags platform w) - in dflags3 - -removeWayDyn :: DynP () -removeWayDyn = upd (\dfs -> dfs { targetWays_ = removeWay WayDyn (targetWays_ dfs) }) - --------------------------- -setGeneralFlag, unSetGeneralFlag :: GeneralFlag -> DynP () -setGeneralFlag f = upd (setGeneralFlag' f) -unSetGeneralFlag f = upd (unSetGeneralFlag' f) - -setGeneralFlag' :: GeneralFlag -> DynFlags -> DynFlags -setGeneralFlag' f dflags = foldr ($) (gopt_set dflags f) deps - where - deps = [ if turn_on then setGeneralFlag' d - else unSetGeneralFlag' d - | (f', turn_on, d) <- impliedGFlags, f' == f ] - -- When you set f, set the ones it implies - -- NB: use setGeneralFlag recursively, in case the implied flags - -- implies further flags - -unSetGeneralFlag' :: GeneralFlag -> DynFlags -> DynFlags -unSetGeneralFlag' f dflags = foldr ($) (gopt_unset dflags f) deps - where - deps = [ if turn_on then setGeneralFlag' d - else unSetGeneralFlag' d - | (f', turn_on, d) <- impliedOffGFlags, f' == f ] - -- In general, when you un-set f, we don't un-set the things it implies. - -- There are however some exceptions, e.g., -fno-strictness implies - -- -fno-worker-wrapper. - -- - -- NB: use unSetGeneralFlag' recursively, in case the implied off flags - -- imply further flags. - --------------------------- -setWarningFlag, unSetWarningFlag :: WarningFlag -> DynP () -setWarningFlag f = upd (\dfs -> wopt_set dfs f) -unSetWarningFlag f = upd (\dfs -> wopt_unset dfs f) - -setFatalWarningFlag, unSetFatalWarningFlag :: WarningFlag -> DynP () -setFatalWarningFlag f = upd (\dfs -> wopt_set_fatal dfs f) -unSetFatalWarningFlag f = upd (\dfs -> wopt_unset_fatal dfs f) - -setWErrorFlag :: WarningFlag -> DynP () -setWErrorFlag flag = - do { setWarningFlag flag - ; setFatalWarningFlag flag } - --------------------------- -setExtensionFlag, unSetExtensionFlag :: LangExt.Extension -> DynP () -setExtensionFlag f = upd (setExtensionFlag' f) -unSetExtensionFlag f = upd (unSetExtensionFlag' f) - -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 ] - -- When you set f, set the ones it implies - -- NB: use setExtensionFlag recursively, in case the implied flags - -- implies further flags - -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) - --------------------------- - -alterToolSettings :: (ToolSettings -> ToolSettings) -> DynFlags -> DynFlags -alterToolSettings f dynFlags = dynFlags { toolSettings = f (toolSettings dynFlags) } - --------------------------- -setDumpFlag' :: DumpFlag -> DynP () -setDumpFlag' dump_flag - = do upd (\dfs -> dopt_set dfs dump_flag) - when want_recomp forceRecompile - where -- Certain dumpy-things are really interested in what's going - -- on during recompilation checking, so in those cases we - -- don't want to turn it off. - want_recomp = dump_flag `notElem` [Opt_D_dump_if_trace, - Opt_D_dump_hi_diffs, - Opt_D_no_debug_output] - -forceRecompile :: DynP () --- Whenever we -ddump, force recompilation (by switching off the --- recompilation checker), else you don't see the dump! However, --- don't switch it off in --make mode, else *everything* gets --- recompiled which probably isn't what you want -forceRecompile = do dfs <- liftEwM getCmdLineState - when (force_recomp dfs) (setGeneralFlag Opt_ForceRecomp) - where - force_recomp dfs = isOneShot (ghcMode dfs) - - -setVerbosity :: Maybe Int -> DynP () -setVerbosity mb_n = upd (\dfs -> dfs{ verbosity = mb_n `orElse` 3 }) - -setDebugLevel :: Maybe Int -> DynP () -setDebugLevel mb_n = - upd (\dfs -> exposeSyms $ dfs{ debugLevel = n }) - where - n = mb_n `orElse` 2 - exposeSyms - | n > 2 = setGeneralFlag' Opt_ExposeInternalSymbols - | otherwise = id - -data PkgDbRef - = GlobalPkgDb - | UserPkgDb - | PkgDbPath FilePath - deriving Eq - -addPkgDbRef :: PkgDbRef -> DynP () -addPkgDbRef p = upd $ \s -> - s { packageDBFlags = PackageDB p : packageDBFlags s } - -removeUserPkgDb :: DynP () -removeUserPkgDb = upd $ \s -> - s { packageDBFlags = NoUserPackageDB : packageDBFlags s } - -removeGlobalPkgDb :: DynP () -removeGlobalPkgDb = upd $ \s -> - s { packageDBFlags = NoGlobalPackageDB : packageDBFlags s } - -clearPkgDb :: DynP () -clearPkgDb = upd $ \s -> - s { packageDBFlags = ClearPackageDBs : packageDBFlags s } - -parsePackageFlag :: String -- the flag - -> ReadP PackageArg -- type of argument - -> String -- string to parse - -> PackageFlag -parsePackageFlag flag arg_parse str - = case filter ((=="").snd) (readP_to_S parse str) of - [(r, "")] -> r - _ -> throwGhcException $ CmdLineError ("Can't parse package flag: " ++ str) - where doc = flag ++ " " ++ str - parse = do - pkg_arg <- tok arg_parse - let mk_expose = ExposePackage doc pkg_arg - ( do _ <- tok $ string "with" - fmap (mk_expose . ModRenaming True) parseRns - <++ fmap (mk_expose . ModRenaming False) parseRns - <++ return (mk_expose (ModRenaming True []))) - parseRns = do _ <- tok $ R.char '(' - rns <- tok $ sepBy parseItem (tok $ R.char ',') - _ <- tok $ R.char ')' - return rns - parseItem = do - orig <- tok $ parseModuleName - (do _ <- tok $ string "as" - new <- tok $ parseModuleName - return (orig, new) - +++ - return (orig, orig)) - tok m = m >>= \x -> skipSpaces >> return x - -exposePackage, exposePackageId, hidePackage, - exposePluginPackage, exposePluginPackageId, - ignorePackage, - trustPackage, distrustPackage :: String -> DynP () -exposePackage p = upd (exposePackage' p) -exposePackageId p = - upd (\s -> s{ packageFlags = - parsePackageFlag "-package-id" parseUnitArg p : packageFlags s }) -exposePluginPackage p = - upd (\s -> s{ pluginPackageFlags = - parsePackageFlag "-plugin-package" parsePackageArg p : pluginPackageFlags s }) -exposePluginPackageId p = - upd (\s -> s{ pluginPackageFlags = - parsePackageFlag "-plugin-package-id" parseUnitArg p : pluginPackageFlags s }) -hidePackage p = - upd (\s -> s{ packageFlags = HidePackage p : packageFlags s }) -ignorePackage p = - upd (\s -> s{ ignorePackageFlags = IgnorePackage p : ignorePackageFlags s }) - -trustPackage p = exposePackage p >> -- both trust and distrust also expose a package - upd (\s -> s{ trustFlags = TrustPackage p : trustFlags s }) -distrustPackage p = exposePackage p >> - upd (\s -> s{ trustFlags = DistrustPackage p : trustFlags s }) - -exposePackage' :: String -> DynFlags -> DynFlags -exposePackage' p dflags - = dflags { packageFlags = - parsePackageFlag "-package" parsePackageArg p : packageFlags dflags } - -parsePackageArg :: ReadP PackageArg -parsePackageArg = - fmap PackageArg (munch1 (\c -> isAlphaNum c || c `elem` ":-_.")) - -parseUnitArg :: ReadP PackageArg -parseUnitArg = - fmap UnitIdArg parseUnit - -setUnitId :: String -> DynFlags -> DynFlags -setUnitId p d = d { homeUnitId_ = stringToUnitId p } - -setWorkingDirectory :: String -> DynFlags -> DynFlags -setWorkingDirectory p d = d { workingDirectory = Just p } - -{- -Note [Filepaths and Multiple Home Units] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -It is common to assume that a package is compiled in the directory where its -cabal file resides. Thus, all paths used in the compiler are assumed to be relative -to this directory. When there are multiple home units the compiler is often -not operating in the standard directory and instead where the cabal.project -file is located. In this case the `-working-dir` option can be passed which specifies -the path from the current directory to the directory the unit assumes to be it's root, -normally the directory which contains the cabal file. - -When the flag is passed, any relative paths used by the compiler are offset -by the working directory. Notably this includes `-i`, `-I⟨dir⟩`, `-hidir`, `-odir` etc and -the location of input files. - --} - -augmentByWorkingDirectory :: DynFlags -> FilePath -> FilePath -augmentByWorkingDirectory dflags fp | isRelative fp, Just offset <- workingDirectory dflags = offset fp -augmentByWorkingDirectory _ fp = fp - -setPackageName :: String -> DynFlags -> DynFlags -setPackageName p d = d { thisPackageName = Just p } - -addHiddenModule :: String -> DynP () -addHiddenModule p = - upd (\s -> s{ hiddenModules = Set.insert (mkModuleName p) (hiddenModules s) }) - -addReexportedModule :: String -> DynP () -addReexportedModule p = - upd (\s -> s{ reexportedModules = Set.insert (mkModuleName p) (reexportedModules s) }) - - --- 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 () -setBackend l = upd $ \ dfs -> - if ghcLink dfs /= LinkBinary || backendWritesFiles l - then dfs{ backend = l } - else dfs - --- Changes the target only if we're compiling object code. This is --- used by -fasm and -fllvm, which switch from one to the other, but --- not from bytecode to object-code. The idea is that -fasm/-fllvm --- can be safely used in an OPTIONS_GHC pragma. -setObjBackend :: Backend -> DynP () -setObjBackend l = updM set - where - set dflags - | backendWritesFiles (backend dflags) - = return $ dflags { backend = l } - | otherwise = return dflags - -setOptLevel :: Int -> DynFlags -> DynP DynFlags -setOptLevel n dflags = return (updOptLevel n dflags) - -setCallerCcFilters :: String -> DynP () -setCallerCcFilters arg = - case parseCallerCcFilter arg of - Right filt -> upd $ \d -> d { callerCcFilters = filt : callerCcFilters d } - 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 } - - | x:_ <- arg, isUpper x -- The arg looked like "Foo" or "Foo.Bar" - = upd $ \d -> d { mainModuleNameIs = mkModuleName arg } - - | otherwise -- The arg looked like "baz" - = upd $ \d -> d { mainFunIs = Just arg } - where - (main_mod, main_fn) = splitLongestPrefix arg (== '.') - -addLdInputs :: Option -> DynFlags -> DynFlags -addLdInputs p dflags = dflags{ldInputs = ldInputs dflags ++ [p]} - --- ----------------------------------------------------------------------------- --- Load dynflags from environment files. - -setFlagsFromEnvFile :: FilePath -> String -> DynP () -setFlagsFromEnvFile envfile content = do - setGeneralFlag Opt_HideAllPackages - parseEnvFile envfile content - -parseEnvFile :: FilePath -> String -> DynP () -parseEnvFile envfile = mapM_ parseEntry . lines - where - parseEntry str = case words str of - ("package-db": _) -> addPkgDbRef (PkgDbPath (envdir db)) - -- relative package dbs are interpreted relative to the env file - where envdir = takeDirectory envfile - db = drop 11 str - ["clear-package-db"] -> clearPkgDb - ["hide-package", pkg] -> hidePackage pkg - ["global-package-db"] -> addPkgDbRef GlobalPkgDb - ["user-package-db"] -> addPkgDbRef UserPkgDb - ["package-id", pkgid] -> exposePackageId pkgid - (('-':'-':_):_) -> return () -- comments - -- and the original syntax introduced in 7.10: - [pkgid] -> exposePackageId pkgid - [] -> return () - _ -> throwGhcException $ CmdLineError $ - "Can't parse environment file entry: " - ++ envfile ++ ": " ++ str - - ------------------------------------------------------------------------------ --- Paths & Libraries - -addImportPath, addLibraryPath, addIncludePath, addFrameworkPath :: FilePath -> DynP () - --- -i on its own deletes the import paths -addImportPath "" = upd (\s -> s{importPaths = []}) -addImportPath p = upd (\s -> s{importPaths = importPaths s ++ splitPathList p}) - -addLibraryPath p = - upd (\s -> s{libraryPaths = libraryPaths s ++ splitPathList p}) - -addIncludePath p = - upd (\s -> s{includePaths = - addGlobalInclude (includePaths s) (splitPathList p)}) - -addFrameworkPath p = - upd (\s -> s{frameworkPaths = frameworkPaths s ++ splitPathList p}) - -#if !defined(mingw32_HOST_OS) -split_marker :: Char -split_marker = ':' -- not configurable (ToDo) -#endif - -splitPathList :: String -> [String] -splitPathList s = filter notNull (splitUp s) - -- empty paths are ignored: there might be a trailing - -- ':' in the initial list, for example. Empty paths can - -- cause confusion when they are translated into -I options - -- for passing to gcc. - where -#if !defined(mingw32_HOST_OS) - splitUp xs = split split_marker xs -#else - -- Windows: 'hybrid' support for DOS-style paths in directory lists. - -- - -- That is, if "foo:bar:baz" is used, this interpreted as - -- consisting of three entries, 'foo', 'bar', 'baz'. - -- However, with "c:/foo:c:\\foo;x:/bar", this is interpreted - -- as 3 elts, "c:/foo", "c:\\foo", "x:/bar" - -- - -- Notice that no attempt is made to fully replace the 'standard' - -- split marker ':' with the Windows / DOS one, ';'. The reason being - -- that this will cause too much breakage for users & ':' will - -- work fine even with DOS paths, if you're not insisting on being silly. - -- So, use either. - splitUp [] = [] - splitUp (x:':':div:xs) | div `elem` dir_markers - = ((x:':':div:p): splitUp rs) - where - (p,rs) = findNextPath xs - -- we used to check for existence of the path here, but that - -- required the IO monad to be threaded through the command-line - -- parser which is quite inconvenient. The - splitUp xs = cons p (splitUp rs) - where - (p,rs) = findNextPath xs - - cons "" xs = xs - cons x xs = x:xs - - -- will be called either when we've consumed nought or the - -- ":/" part of a DOS path, so splitting is just a Q of - -- finding the next split marker. - findNextPath xs = - case break (`elem` split_markers) xs of - (p, _:ds) -> (p, ds) - (p, xs) -> (p, xs) - - split_markers :: [Char] - split_markers = [':', ';'] - - dir_markers :: [Char] - dir_markers = ['/', '\\'] -#endif - --- ----------------------------------------------------------------------------- --- tmpDir, where we store temporary files. - -setTmpDir :: FilePath -> DynFlags -> DynFlags -setTmpDir dir d = d { tmpDir = TempDir (normalise dir) } - -- we used to fix /cygdrive/c/.. on Windows, but this doesn't - -- seem necessary now --SDM 7/2/2008 - ------------------------------------------------------------------------------ --- RTS opts - -setRtsOpts :: String -> DynP () -setRtsOpts arg = upd $ \ d -> d {rtsOpts = Just arg} - -setRtsOptsEnabled :: RtsOptsEnabled -> DynP () -setRtsOptsEnabled arg = upd $ \ d -> d {rtsOptsEnabled = arg} - ------------------------------------------------------------------------------ --- Hpc stuff - -setOptHpcDir :: String -> DynP () -setOptHpcDir arg = upd $ \ d -> d {hpcDir = arg} - ------------------------------------------------------------------------------ --- Via-C compilation stuff - --- There are some options that we need to pass to gcc when compiling --- Haskell code via C, but are only supported by recent versions of --- gcc. The configure script decides which of these options we need, --- and puts them in the "settings" file in $topdir. The advantage of --- having these in a separate file is that the file can be created at --- install-time depending on the available gcc version, and even --- re-generated later if gcc is upgraded. --- --- The options below are not dependent on the version of gcc, only the --- platform. - -picCCOpts :: DynFlags -> [String] -picCCOpts dflags = - case platformOS (targetPlatform dflags) of - OSDarwin - -- Apple prefers to do things the other way round. - -- PIC is on by default. - -- -mdynamic-no-pic: - -- Turn off PIC code generation. - -- -fno-common: - -- Don't generate "common" symbols - these are unwanted - -- in dynamic libraries. - - | gopt Opt_PIC dflags -> ["-fno-common", "-U__PIC__", "-D__PIC__"] - | otherwise -> ["-mdynamic-no-pic"] - OSMinGW32 -- no -fPIC for Windows - | gopt Opt_PIC dflags -> ["-U__PIC__", "-D__PIC__"] - | otherwise -> [] - _ - -- we need -fPIC for C files when we are compiling with -dynamic, - -- otherwise things like stub.c files don't get compiled - -- correctly. They need to reference data in the Haskell - -- 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__"] - -- gcc may be configured to have PIC on by default, let's be - -- explicit here, see #15847 - | otherwise -> ["-fno-PIC"] - -pieCCLDOpts :: DynFlags -> [String] -pieCCLDOpts dflags - | gopt Opt_PICExecutable dflags = ["-pie"] - -- See Note [No PIE when linking] - | toolSettings_ccSupportsNoPie (toolSettings dflags) = ["-no-pie"] - | otherwise = [] - - -{- -Note [No PIE when linking] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -As of 2016 some Linux distributions (e.g. Debian) have started enabling -pie by -default in their gcc builds. This is incompatible with -r as it implies that we -are producing an executable. Consequently, we must manually pass -no-pie to gcc -when joining object files or linking dynamic libraries. Unless, of course, the -user has explicitly requested a PIE executable with -pie. See #12759. --} - -picPOpts :: DynFlags -> [String] -picPOpts dflags - | gopt Opt_PIC dflags = ["-U__PIC__", "-D__PIC__"] - | otherwise = [] - --- ----------------------------------------------------------------------------- --- Compiler Info - -compilerInfo :: DynFlags -> [(String, String)] -compilerInfo dflags - = -- We always make "Project name" be first to keep parsing in - -- other languages simple, i.e. when looking for other fields, - -- you don't have to worry whether there is a leading '[' or not - ("Project name", cProjectName) - -- Next come the settings, so anything else can be overridden - -- in the settings file (as "lookup" uses the first match for the - -- key) - : map (fmap $ expandDirectories (topDir dflags) (toolDir dflags)) - (rawSettings dflags) - ++ [("Project version", projectVersion dflags), - ("Project Git commit id", cProjectGitCommitId), - ("Project Version Int", cProjectVersionInt), - ("Project Patch Level", cProjectPatchLevel), - ("Project Patch Level1", cProjectPatchLevel1), - ("Project Patch Level2", cProjectPatchLevel2), - ("Booter version", cBooterVersion), - ("Stage", cStage), - ("Build platform", cBuildPlatformString), - ("Host platform", cHostPlatformString), - ("Target platform", platformMisc_targetPlatformString $ platformMisc dflags), - ("Have interpreter", showBool $ platformMisc_ghcWithInterpreter $ platformMisc dflags), - ("Object splitting supported", showBool False), - ("Have native code generator", showBool $ platformNcgSupported (targetPlatform dflags)), - ("Target default backend", show $ platformDefaultBackend (targetPlatform dflags)), - -- Whether or not we support @-dynamic-too@ - ("Support dynamic-too", showBool $ not isWindows), - -- Whether or not we support the @-j@ flag with @--make@. - ("Support parallel --make", "YES"), - -- Whether or not we support "Foo from foo-0.1-XXX:Foo" syntax in - -- installed package info. - ("Support reexported-modules", "YES"), - -- Whether or not we support extended @-package foo (Foo)@ syntax. - ("Support thinning and renaming package flags", "YES"), - -- Whether or not we support Backpack. - ("Support Backpack", "YES"), - -- If true, we require that the 'id' field in installed package info - -- match what is passed to the @-this-unit-id@ flag for modules - -- built in it - ("Requires unified installed package IDs", "YES"), - -- Whether or not we support the @-this-package-key@ flag. Prefer - -- "Uses unit IDs" over it. We still say yes even if @-this-package-key@ - -- flag has been removed, otherwise it breaks Cabal... - ("Uses package keys", "YES"), - -- Whether or not we support the @-this-unit-id@ flag - ("Uses unit IDs", "YES"), - -- Whether or not GHC was compiled using -dynamic - ("GHC Dynamic", showBool hostIsDynamic), - -- Whether or not GHC was compiled using -prof - ("GHC Profiled", showBool hostIsProfiled), - ("Debug on", showBool debugIsOn), - ("LibDir", topDir dflags), - -- The path of the global package database used by GHC - ("Global Package DB", globalPackageDatabasePath dflags) - ] - where - showBool True = "YES" - showBool False = "NO" - platform = targetPlatform dflags - isWindows = platformOS platform == OSMinGW32 - useInplaceMinGW = toolSettings_useInplaceMinGW $ toolSettings dflags - expandDirectories :: FilePath -> Maybe FilePath -> String -> String - expandDirectories topd mtoold = expandToolDir useInplaceMinGW mtoold . expandTopDir topd - - --- | Get target profile -targetProfile :: DynFlags -> Profile -targetProfile dflags = Profile (targetPlatform dflags) (ways dflags) - -{- ----------------------------------------------------------------------------- -Note [DynFlags consistency] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -There are a number of number of DynFlags configurations which either -do not make sense or lead to unimplemented or buggy codepaths in the -compiler. makeDynFlagsConsistent is responsible for verifying the validity -of a set of DynFlags, fixing any issues, and reporting them back to the -caller. - -GHCi and -O ---------------- - -When using optimization, the compiler can introduce several things -(such as unboxed tuples) into the intermediate code, which GHCi later -chokes on since the bytecode interpreter can't handle this (and while -this is arguably a bug these aren't handled, there are no plans to fix -it.) - -While the driver pipeline always checks for this particular erroneous -combination when parsing flags, we also need to check when we update -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). --} - --- | 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, [Located String]) --- 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! -makeDynFlagsConsistent dflags - -- Disable -dynamic-too on Windows (#8228, #7134, #5987) - | os == OSMinGW32 && gopt Opt_BuildDynamicToo dflags - = let dflags' = gopt_unset dflags Opt_BuildDynamicToo - warn = "-dynamic-too is not supported on Windows" - in loop dflags' warn - -- Disable -dynamic-too if we are are compiling with -dynamic already, otherwise - -- you get two dynamic object files (.o and .dyn_o). (#20436) - | ways dflags `hasWay` WayDyn && gopt Opt_BuildDynamicToo dflags - = let dflags' = gopt_unset dflags Opt_BuildDynamicToo - warn = "-dynamic-too is ignored when using -dynamic" - in loop dflags' warn - - | gopt Opt_SplitSections dflags - , platformHasSubsectionsViaSymbols (targetPlatform dflags) - = let dflags' = gopt_unset dflags Opt_SplitSections - warn = "-fsplit-sections is not useful on this platform " ++ - "since it uses subsections-via-symbols. Ignoring." - in loop dflags' warn - - -- Via-C backend only supports unregisterised ABI. Switch to a backend - -- supporting it if possible. - | backendUnregisterisedAbiOnly (backend dflags) && - not (platformUnregisterised (targetPlatform dflags)) - = let b = platformDefaultBackend (targetPlatform dflags) - in if backendSwappableWithViaC b then - let dflags' = dflags { backend = b } - warn = "Target platform doesn't use unregisterised ABI, so using " ++ - backendDescription b ++ " rather than " ++ - backendDescription (backend dflags) - in loop dflags' warn - else - pgmError (backendDescription (backend dflags) ++ - " supports only unregisterised ABI but target platform doesn't use it.") - - | gopt Opt_Hpc dflags && not (backendSupportsHpc (backend dflags)) - = let dflags' = gopt_unset dflags Opt_Hpc - warn = "Hpc can't be used with " ++ backendDescription (backend dflags) ++ - ". Ignoring -fhpc." - in loop dflags' warn - - | backendSwappableWithViaC (backend dflags) && - platformUnregisterised (targetPlatform dflags) - = loop (dflags { backend = viaCBackend }) - "Target platform uses unregisterised ABI, so compiling via C" - - | backendNeedsPlatformNcgSupport (backend dflags) && - not (platformNcgSupported $ targetPlatform dflags) - = let dflags' = dflags { backend = llvmBackend } - warn = "Native code generator doesn't support target platform, so using LLVM" - in loop dflags' warn - - | not (osElfTarget os) && gopt Opt_PIE dflags - = loop (gopt_unset dflags Opt_PIE) - "Position-independent only supported on ELF platforms" - | os == OSDarwin && - arch == ArchX86_64 && - not (gopt Opt_PIC dflags) - = loop (gopt_set dflags Opt_PIC) - "Enabling -fPIC as it is always on for this platform" - - | backendForcesOptimization0 (backend dflags) - , let (dflags', changed) = updOptLevelChanged 0 dflags - , changed - = loop dflags' ("Optimization flags are incompatible with the " ++ - backendDescription (backend dflags) ++ - "; optimization flags ignored.") - - | LinkInMemory <- ghcLink dflags - , not (gopt Opt_ExternalInterpreter dflags) - , hostIsProfiled - , backendWritesFiles (backend dflags) - , ways dflags `hasNotWay` WayProf - = loop dflags{targetWays_ = addWay WayProf (targetWays_ dflags)} - "Enabling -prof, because -fobject-code is enabled and GHCi is profiled" - - | LinkMergedObj <- ghcLink dflags - , Nothing <- outputFile dflags - = pgmError "--output must be specified when using --merge-objs" - - | otherwise = (dflags, []) - where loc = mkGeneralSrcSpan (fsLit "when making flags consistent") - loop updated_dflags warning - = case makeDynFlagsConsistent updated_dflags of - (dflags', ws) -> (dflags', L loc warning : ws) - platform = targetPlatform dflags - arch = platformArch platform - os = platformOS platform - - -setUnsafeGlobalDynFlags :: DynFlags -> IO () -setUnsafeGlobalDynFlags dflags = do - writeIORef v_unsafeHasPprDebug (hasPprDebug dflags) - writeIORef v_unsafeHasNoDebugOutput (hasNoDebugOutput dflags) - writeIORef v_unsafeHasNoStateHack (hasNoStateHack dflags) - - --- ----------------------------------------------------------------------------- --- SSE and AVX - -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 - --- ----------------------------------------------------------------------------- --- 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) - --- | Indicate whether we need to generate source notes -needSourceNotes :: DynFlags -> Bool -needSourceNotes dflags = debugLevel dflags > 0 - || gopt Opt_InfoTableMap dflags - --- ----------------------------------------------------------------------------- --- Linker/compiler information - --- LinkerInfo contains any extra options needed by the system linker. -data LinkerInfo - = GnuLD [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 - - --- | Should we use `-XLinker -rpath` when linking or not? --- See Note [-fno-use-rpaths] -useXLinkerRPath :: DynFlags -> OS -> Bool -useXLinkerRPath _ OSDarwin = False -- See Note [Dynamic linking on macOS] -useXLinkerRPath dflags _ = gopt Opt_RPath dflags - -{- -Note [-fno-use-rpaths] -~~~~~~~~~~~~~~~~~~~~~~ - -First read, Note [Dynamic linking on macOS] to understand why on darwin we never -use `-XLinker -rpath`. - -The specification of `Opt_RPath` is as follows: - -The default case `-fuse-rpaths`: -* On darwin, never use `-Xlinker -rpath -Xlinker`, always inject the rpath - afterwards, see `runInjectRPaths`. There is no way to use `-Xlinker` on darwin - as things stand but it wasn't documented in the user guide before this patch how - `-fuse-rpaths` should behave and the fact it was always disabled on darwin. -* Otherwise, use `-Xlinker -rpath -Xlinker` to set the rpath of the executable, - this is the normal way you should set the rpath. - -The case of `-fno-use-rpaths` -* Never inject anything into the rpath. - -When this was first implemented, `Opt_RPath` was disabled on darwin, but -the rpath was still always augmented by `runInjectRPaths`, and there was no way to -stop this. This was problematic because you couldn't build an executable in CI -with a clean rpath. - --} - --- ----------------------------------------------------------------------------- --- RTS hooks - --- Convert sizes like "3.5M" into integers -decodeSize :: String -> Integer -decodeSize str - | c == "" = truncate n - | c == "K" || c == "k" = truncate (n * 1000) - | c == "M" || c == "m" = truncate (n * 1000 * 1000) - | c == "G" || c == "g" = truncate (n * 1000 * 1000 * 1000) - | otherwise = throwGhcException (CmdLineError ("can't decode size: " ++ str)) - where (m, c) = span pred str - n = readRational m - pred c = isDigit c || c == '.' - -foreign import ccall unsafe "setHeapSize" setHeapSize :: Int -> IO () -foreign import ccall unsafe "enableTimingStats" enableTimingStats :: IO () - - --- | Initialize the pretty-printing options -initSDocContext :: DynFlags -> PprStyle -> SDocContext -initSDocContext dflags style = SDC - { sdocStyle = style - , sdocColScheme = colScheme dflags - , sdocLastColour = Col.colReset - , sdocShouldUseColor = overrideWith (canUseColor dflags) (useColor dflags) - , sdocDefaultDepth = pprUserLength dflags - , sdocLineLength = pprCols dflags - , sdocCanUseUnicode = useUnicode dflags - , sdocHexWordLiterals = gopt Opt_HexWordLiterals dflags - , sdocPprDebug = dopt Opt_D_ppr_debug dflags - , sdocPrintUnicodeSyntax = gopt Opt_PrintUnicodeSyntax dflags - , sdocPrintCaseAsLet = gopt Opt_PprCaseAsLet dflags - , sdocPrintTypecheckerElaboration = gopt Opt_PrintTypecheckerElaboration dflags - , sdocPrintAxiomIncomps = gopt Opt_PrintAxiomIncomps dflags - , sdocPrintExplicitKinds = gopt Opt_PrintExplicitKinds dflags - , sdocPrintExplicitCoercions = gopt Opt_PrintExplicitCoercions dflags - , sdocPrintExplicitRuntimeReps = gopt Opt_PrintExplicitRuntimeReps dflags - , sdocPrintExplicitForalls = gopt Opt_PrintExplicitForalls dflags - , sdocPrintPotentialInstances = gopt Opt_PrintPotentialInstances dflags - , sdocPrintEqualityRelations = gopt Opt_PrintEqualityRelations dflags - , sdocSuppressTicks = gopt Opt_SuppressTicks dflags - , sdocSuppressTypeSignatures = gopt Opt_SuppressTypeSignatures dflags - , sdocSuppressTypeApplications = gopt Opt_SuppressTypeApplications dflags - , sdocSuppressIdInfo = gopt Opt_SuppressIdInfo dflags - , sdocSuppressCoercions = gopt Opt_SuppressCoercions dflags - , sdocSuppressCoercionTypes = gopt Opt_SuppressCoercionTypes dflags - , sdocSuppressUnfoldings = gopt Opt_SuppressUnfoldings dflags - , sdocSuppressVarKinds = gopt Opt_SuppressVarKinds dflags - , sdocSuppressUniques = gopt Opt_SuppressUniques dflags - , sdocSuppressModulePrefixes = gopt Opt_SuppressModulePrefixes dflags - , sdocSuppressStgExts = gopt Opt_SuppressStgExts dflags - , sdocSuppressStgReps = gopt Opt_SuppressStgReps dflags - , sdocErrorSpans = gopt Opt_ErrorSpans dflags - , sdocStarIsType = xopt LangExt.StarIsType dflags - , sdocLinearTypes = xopt LangExt.LinearTypes dflags - , sdocListTuplePuns = True - , sdocPrintTypeAbbreviations = True - , sdocUnitIdForUser = ftext - } - --- | Initialize the pretty-printing options using the default user style -initDefaultSDocContext :: DynFlags -> SDocContext -initDefaultSDocContext dflags = initSDocContext dflags defaultUserStyle - -initPromotionTickContext :: DynFlags -> PromotionTickContext -initPromotionTickContext dflags = - PromTickCtx { - ptcListTuplePuns = True, - ptcPrintRedundantPromTicks = gopt Opt_PrintRedundantPromotionTicks dflags - } - -outputFile :: DynFlags -> Maybe String -outputFile dflags - | dynamicNow dflags = dynOutputFile_ dflags - | otherwise = outputFile_ dflags - -objectSuf :: DynFlags -> String -objectSuf dflags - | dynamicNow dflags = dynObjectSuf_ dflags - | otherwise = objectSuf_ dflags - -ways :: DynFlags -> Ways -ways dflags - | dynamicNow dflags = addWay WayDyn (targetWays_ dflags) - | otherwise = targetWays_ dflags +module GHC.Driver.Session ( + -- * Dynamic flags and associated configuration types + DumpFlag(..), + GeneralFlag(..), + WarningFlag(..), DiagnosticReason(..), + Language(..), + FatalMessager, FlushOut(..), + ProfAuto(..), + glasgowExtsFlags, + hasPprDebug, hasNoDebugOutput, hasNoStateHack, hasNoOptCoercion, + dopt, dopt_set, dopt_unset, + gopt, gopt_set, gopt_unset, setGeneralFlag', unSetGeneralFlag', + wopt, wopt_set, wopt_unset, + wopt_fatal, wopt_set_fatal, wopt_unset_fatal, + wopt_set_all_custom, wopt_unset_all_custom, + wopt_set_all_fatal_custom, wopt_unset_all_fatal_custom, + wopt_set_custom, wopt_unset_custom, + wopt_set_fatal_custom, wopt_unset_fatal_custom, + wopt_any_custom, + xopt, xopt_set, xopt_unset, + xopt_set_unlessExplSpec, + xopt_DuplicateRecordFields, + xopt_FieldSelectors, + lang_set, + DynamicTooState(..), dynamicTooState, setDynamicNow, + sccProfilingEnabled, + needSourceNotes, + OnOff(..), + DynFlags(..), + ParMakeCount(..), + outputFile, objectSuf, ways, + FlagSpec(..), + HasDynFlags(..), ContainsDynFlags(..), + RtsOptsEnabled(..), + GhcMode(..), isOneShot, + GhcLink(..), isNoLink, + PackageFlag(..), PackageArg(..), ModRenaming(..), + packageFlagsChanged, + IgnorePackageFlag(..), TrustFlag(..), + PackageDBFlag(..), PkgDbRef(..), + Option(..), showOpt, + DynLibLoader(..), + fFlags, fLangFlags, xFlags, + wWarningFlags, + makeDynFlagsConsistent, + positionIndependent, + optimisationFlags, + codeGenFlags, + setFlagsFromEnvFile, + pprDynFlagsDiff, + flagSpecOf, + + targetProfile, + + -- ** Safe Haskell + safeHaskellOn, safeHaskellModeEnabled, + safeImportsOn, safeLanguageOn, safeInferOn, + packageTrustOn, + safeDirectImpsReq, safeImplicitImpsReq, + unsafeFlags, unsafeFlagsForInfer, + + -- ** base + baseUnitId, + + -- ** System tool settings and locations + Settings(..), + sProgramName, + sProjectVersion, + sGhcUsagePath, + sGhciUsagePath, + sToolDir, + sTopDir, + sGlobalPackageDatabasePath, + sLdSupportsCompactUnwind, + sLdSupportsFilelist, + sLdIsGnuLd, + sGccSupportsNoPie, + sPgm_L, + sPgm_P, + sPgm_F, + sPgm_c, + sPgm_cxx, + sPgm_cpp, + sPgm_a, + sPgm_l, + sPgm_lm, + sPgm_windres, + sPgm_ar, + sPgm_ranlib, + sPgm_lo, + sPgm_lc, + 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, + sOpt_a, + sOpt_l, + sOpt_lm, + sOpt_windres, + sOpt_lo, + sOpt_lc, + sOpt_i, + sExtraGccViaCFlags, + sTargetPlatformString, + sGhcWithInterpreter, + sLibFFI, + sTargetRTSLinkerOnlySupportsSharedLibs, + GhcNameVersion(..), + FileSettings(..), + PlatformMisc(..), + settings, + programName, projectVersion, + ghcUsagePath, ghciUsagePath, topDir, + versionedAppDir, versionedFilePath, + extraGccViaCFlags, globalPackageDatabasePath, + 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 + addPluginModuleName, + defaultDynFlags, -- Settings -> DynFlags + initDynFlags, -- DynFlags -> IO DynFlags + defaultFatalMessager, + defaultFlushOut, + setOutputFile, setDynOutputFile, setOutputHi, setDynOutputHi, + augmentByWorkingDirectory, + + getOpts, -- DynFlags -> (DynFlags -> [a]) -> [a] + getVerbFlags, + updOptLevel, + setTmpDir, + setUnitId, + setHomeUnitId, + + TurnOnFlag, + turnOn, + turnOff, + impliedGFlags, + impliedOffGFlags, + impliedXFlags, + + -- ** State + CmdLineP(..), runCmdLineP, + getCmdLineState, putCmdLineState, + processCmdLineP, + + -- ** Parsing DynFlags + parseDynamicFlagsCmdLine, + parseDynamicFilePragma, + parseDynamicFlagsFull, + flagSuggestions, + + -- ** Available DynFlags + allNonDeprecatedFlags, + flagsAll, + flagsDynamic, + flagsPackage, + flagsForCompletion, + + supportedLanguagesAndExtensions, + languageExtensions, + + -- ** DynFlags C compiler options + picCCOpts, picPOpts, + + -- ** DynFlags C linker options + pieCCLDOpts, + + -- * Compiler configuration suitable for display to the user + compilerInfo, + + wordAlignment, + + setUnsafeGlobalDynFlags, + + -- * SSE and AVX + isSse3Enabled, + isSsse3Enabled, + isSse4_1Enabled, + isSse4_2Enabled, + isBmiEnabled, + isBmi2Enabled, + isAvxEnabled, + isAvx2Enabled, + isAvx512cdEnabled, + isAvx512erEnabled, + isAvx512fEnabled, + isAvx512pfEnabled, + isFmaEnabled, + + -- * Linker/compiler information + useXLinkerRPath, + + -- * Include specifications + IncludeSpecs(..), addGlobalInclude, addQuoteInclude, flattenIncludes, + addImplicitQuoteInclude, + + -- * SDoc + initSDocContext, initDefaultSDocContext, + initPromotionTickContext, + ) where + +import GHC.Prelude + +import GHC.Platform +import GHC.Platform.Ways +import GHC.Platform.Profile +import GHC.Platform.ArchOS + +import GHC.Unit.Types +import GHC.Unit.Parser +import GHC.Unit.Module +import GHC.Unit.Module.Warnings +import GHC.Driver.DynFlags +import GHC.Driver.Config.Diagnostic +import GHC.Driver.Flags +import GHC.Driver.Backend +import GHC.Driver.Errors.Types +import GHC.Driver.Plugins.External +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 +import GHC.Types.Basic ( treatZeroAsInf ) +import GHC.Data.FastString +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 ) + +import Data.IORef +import Control.Arrow ((&&&)) +import Control.Monad +import Control.Monad.Trans.State as State +import Data.Functor.Identity + +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 +import Data.Word +import System.FilePath +import Text.ParserCombinators.ReadP hiding (char) +import Text.ParserCombinators.ReadP as R + +import qualified GHC.Data.EnumSet as EnumSet + +import qualified GHC.LanguageExtensions as LangExt + + +-- Note [Updating flag description in the User's Guide] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- +-- If you modify anything in this file please make sure that your changes are +-- described in the User's Guide. Please update the flag description in the +-- users guide (docs/users_guide) whenever you add or change a flag. +-- Please make sure you add ":since:" information to new flags. + +-- Note [Supporting CLI completion] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- +-- The command line interface completion (in for example bash) is an easy way +-- for the developer to learn what flags are available from GHC. +-- GHC helps by separating which flags are available when compiling with GHC, +-- and which flags are available when using GHCi. +-- A flag is assumed to either work in both these modes, or only in one of them. +-- When adding or changing a flag, please consider for which mode the flag will +-- have effect, and annotate it accordingly. For Flags use defFlag, defGhcFlag, +-- defGhciFlag, and for FlagSpec use flagSpec or flagGhciSpec. + +-- Note [Adding a language extension] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- +-- There are a few steps to adding (or removing) a language extension, +-- +-- * Adding the extension to GHC.LanguageExtensions +-- +-- The Extension type in libraries/ghc-boot-th/GHC/LanguageExtensions/Type.hs +-- is the canonical list of language extensions known by GHC. +-- +-- * Adding a flag to DynFlags.xFlags +-- +-- This is fairly self-explanatory. The name should be concise, memorable, +-- and consistent with any previous implementations of the similar idea in +-- other Haskell compilers. +-- +-- * Adding the flag to the documentation +-- +-- This is the same as any other flag. See +-- Note [Updating flag description in the User's Guide] +-- +-- * Adding the flag to Cabal +-- +-- The Cabal library has its own list of all language extensions supported +-- by all major compilers. This is the list that user code being uploaded +-- to Hackage is checked against to ensure language extension validity. +-- Consequently, it is very important that this list remains up-to-date. +-- +-- To this end, there is a testsuite test (testsuite/tests/driver/T4437.hs) +-- whose job it is to ensure these GHC's extensions are consistent with +-- Cabal. +-- +-- The recommended workflow is, +-- +-- 1. Temporarily add your new language extension to the +-- expectedGhcOnlyExtensions list in T4437 to ensure the test doesn't +-- break while Cabal is updated. +-- +-- 2. After your GHC change is accepted, submit a Cabal pull request adding +-- your new extension to Cabal's list (found in +-- Cabal/Language/Haskell/Extension.hs). +-- +-- 3. After your Cabal change is accepted, let the GHC developers know so +-- they can update the Cabal submodule and remove the extensions from +-- expectedGhcOnlyExtensions. +-- +-- * Adding the flag to the GHC Wiki +-- +-- There is a change log tracking language extension additions and removals +-- on the GHC wiki: https://gitlab.haskell.org/ghc/ghc/wikis/language-pragma-history +-- +-- See #4437 and #8176. + +-- ----------------------------------------------------------------------------- +-- DynFlags + +{- Note [RHS Floating] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + We provide both 'Opt_LocalFloatOut' and 'Opt_LocalFloatOutTopLevel' to correspond to + 'doFloatFromRhs'; with this we can control floating out with GHC flags. + + This addresses https://gitlab.haskell.org/ghc/ghc/-/issues/13663 and + allows for experimentation. +-} + +----------------------------------------------------------------------------- +-- Accessors from 'DynFlags' + +-- | "unbuild" a 'Settings' from a 'DynFlags'. This shouldn't be needed in the +-- vast majority of code. But GHCi questionably uses this to produce a default +-- 'DynFlags' from which to compute a flags diff for printing. +settings :: DynFlags -> Settings +settings dflags = Settings + { sGhcNameVersion = ghcNameVersion dflags + , sFileSettings = fileSettings dflags + , sUnitSettings = unitSettings dflags + , sTargetPlatform = targetPlatform dflags + , sToolSettings = toolSettings dflags + , sPlatformMisc = platformMisc dflags + , sRawSettings = rawSettings dflags + } + +pgm_L :: DynFlags -> String +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_windres :: DynFlags -> String +pgm_windres dflags = toolSettings_pgm_windres $ toolSettings dflags +pgm_ar :: DynFlags -> String +pgm_ar dflags = toolSettings_pgm_ar $ toolSettings dflags +pgm_ranlib :: DynFlags -> String +pgm_ranlib dflags = toolSettings_pgm_ranlib $ toolSettings dflags +pgm_lo :: DynFlags -> (String,[Option]) +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] +opt_L dflags = toolSettings_opt_L $ toolSettings dflags +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]. +opt_P_signature :: DynFlags -> ([String], Fingerprint) +opt_P_signature dflags = + ( 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 +opt_c :: DynFlags -> [String] +opt_c dflags = concatMap (wayOptc (targetPlatform dflags)) (ways dflags) + ++ toolSettings_opt_c (toolSettings dflags) +opt_cxx :: DynFlags -> [String] +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] +opt_l dflags = concatMap (wayOptl (targetPlatform dflags)) (ways dflags) + ++ toolSettings_opt_l (toolSettings dflags) +opt_lm :: DynFlags -> [String] +opt_lm dflags= toolSettings_opt_lm $ toolSettings dflags +opt_windres :: DynFlags -> [String] +opt_windres dflags= toolSettings_opt_windres $ 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) } + +----------------------------------------------------------------------------- + +{- +Note [Verbosity levels] +~~~~~~~~~~~~~~~~~~~~~~~ + 0 | print errors & warnings only + 1 | minimal verbosity: print "compiling M ... done." for each module. + 2 | equivalent to -dshow-passes + 3 | equivalent to existing "ghc -v" + 4 | "ghc -v -ddump-most" + 5 | "ghc -v -ddump-all" +-} + +-- | Set the Haskell language standard to use +setLanguage :: Language -> DynP () +setLanguage l = upd (`lang_set` Just l) + +-- | Is the -fpackage-trust mode on +packageTrustOn :: DynFlags -> Bool +packageTrustOn = gopt Opt_PackageTrust + +-- | Is Safe Haskell on in some way (including inference mode) +safeHaskellOn :: DynFlags -> Bool +safeHaskellOn dflags = safeHaskellModeEnabled dflags || safeInferOn dflags + +safeHaskellModeEnabled :: DynFlags -> Bool +safeHaskellModeEnabled dflags = safeHaskell dflags `elem` [Sf_Unsafe, Sf_Trustworthy + , Sf_Safe ] + + +-- | Is the Safe Haskell safe language in use +safeLanguageOn :: DynFlags -> Bool +safeLanguageOn dflags = safeHaskell dflags == Sf_Safe + +-- | Is the Safe Haskell safe inference mode active +safeInferOn :: DynFlags -> Bool +safeInferOn = safeInfer + +-- | Test if Safe Imports are on in some form +safeImportsOn :: DynFlags -> Bool +safeImportsOn dflags = safeHaskell dflags == Sf_Unsafe || + safeHaskell dflags == Sf_Trustworthy || + safeHaskell dflags == Sf_Safe + +-- | Set a 'Safe Haskell' flag +setSafeHaskell :: SafeHaskellMode -> DynP () +setSafeHaskell s = updM f + where f dfs = do + let sf = safeHaskell dfs + safeM <- combineSafeFlags sf s + case s of + Sf_Safe -> return $ dfs { safeHaskell = safeM, safeInfer = False } + -- leave safe inference on in Trustworthy mode so we can warn + -- if it could have been inferred safe. + Sf_Trustworthy -> do + l <- getCurLoc + return $ dfs { safeHaskell = safeM, trustworthyOnLoc = l } + -- leave safe inference on in Unsafe mode as well. + _ -> return $ dfs { safeHaskell = safeM } + +-- | Are all direct imports required to be safe for this Safe Haskell mode? +-- Direct imports are when the code explicitly imports a module +safeDirectImpsReq :: DynFlags -> Bool +safeDirectImpsReq d = safeLanguageOn d + +-- | Are all implicit imports required to be safe for this Safe Haskell mode? +-- Implicit imports are things in the prelude. e.g System.IO when print is used. +safeImplicitImpsReq :: DynFlags -> Bool +safeImplicitImpsReq d = safeLanguageOn d + +-- | Combine two Safe Haskell modes correctly. Used for dealing with multiple flags. +-- This makes Safe Haskell very much a monoid but for now I prefer this as I don't +-- want to export this functionality from the module but do want to export the +-- type constructors. +combineSafeFlags :: SafeHaskellMode -> SafeHaskellMode -> DynP SafeHaskellMode +combineSafeFlags a b | a == Sf_None = return b + | b == Sf_None = return a + | a == Sf_Ignore || b == Sf_Ignore = return Sf_Ignore + | a == b = return a + | otherwise = addErr errm >> pure a + where errm = "Incompatible Safe Haskell flags! (" + ++ show a ++ ", " ++ show b ++ ")" + +-- | A list of unsafe flags under Safe Haskell. Tuple elements are: +-- * name of the flag +-- * function to get srcspan that enabled the flag +-- * function to test if the flag is on +-- * function to turn the flag off +unsafeFlags, unsafeFlagsForInfer + :: [(LangExt.Extension, DynFlags -> SrcSpan, DynFlags -> Bool, DynFlags -> DynFlags)] +unsafeFlags = [ (LangExt.GeneralizedNewtypeDeriving, newDerivOnLoc, + xopt LangExt.GeneralizedNewtypeDeriving, + flip xopt_unset LangExt.GeneralizedNewtypeDeriving) + , (LangExt.DerivingVia, deriveViaOnLoc, + xopt LangExt.DerivingVia, + flip xopt_unset LangExt.DerivingVia) + , (LangExt.TemplateHaskell, thOnLoc, + xopt LangExt.TemplateHaskell, + flip xopt_unset LangExt.TemplateHaskell) + ] +unsafeFlagsForInfer = unsafeFlags + + +-- | Retrieve the options corresponding to a particular @opt_*@ field in the correct order +getOpts :: DynFlags -- ^ 'DynFlags' to retrieve the options from + -> (DynFlags -> [a]) -- ^ Relevant record accessor: one of the @opt_*@ accessors + -> [a] -- ^ Correctly ordered extracted options +getOpts dflags opts = reverse (opts dflags) + -- We add to the options from the front, so we need to reverse the list + +-- | Gets the verbosity flag for the current verbosity level. This is fed to +-- other tools, so GHC-specific verbosity flags like @-ddump-most@ are not included +getVerbFlags :: DynFlags -> [String] +getVerbFlags dflags + | verbosity dflags >= 4 = ["-v"] + | otherwise = [] + +setObjectDir, setHiDir, setHieDir, setStubDir, setDumpDir, setOutputDir, + setDynObjectSuf, setDynHiSuf, + setDylibInstallName, + setObjectSuf, setHiSuf, setHieSuf, setHcSuf, parseDynLibLoaderMode, + setPgmP, setPgmJSP, setPgmCmmP, addOptl, addOptc, addOptcxx, addOptP, + addOptJSP, addOptCmmP, + addCmdlineFramework, addHaddockOpts, addGhciScript, + setInteractivePrint + :: String -> DynFlags -> DynFlags +setOutputFile, setDynOutputFile, setOutputHi, setDynOutputHi, setDumpPrefixForce + :: Maybe String -> DynFlags -> DynFlags + +setObjectDir f d = d { objectDir = Just f} +setHiDir f d = d { hiDir = Just f} +setHieDir f d = d { hieDir = Just f} +setStubDir f d = d { stubDir = Just f + , includePaths = addGlobalInclude (includePaths d) [f] } + -- -stubdir D adds an implicit -I D, so that gcc can find the _stub.h file + -- \#included from the .hc file when compiling via C (i.e. unregisterised + -- builds). +setDumpDir f d = d { dumpDir = Just f} +setOutputDir f = setObjectDir f + . setHieDir f + . setHiDir f + . setStubDir f + . setDumpDir f +setDylibInstallName f d = d { dylibInstallName = Just f} + +setObjectSuf f d = d { objectSuf_ = f} +setDynObjectSuf f d = d { dynObjectSuf_ = f} +setHiSuf f d = d { hiSuf_ = f} +setHieSuf f d = d { hieSuf = f} +setDynHiSuf f d = d { dynHiSuf_ = f} +setHcSuf f d = d { hcSuf = f} + +setOutputFile f d = d { outputFile_ = f} +setDynOutputFile f d = d { dynOutputFile_ = f} +setOutputHi f d = d { outputHi = f} +setDynOutputHi f d = d { dynOutputHi = f} + +parseUnitInsts :: String -> Instantiations +parseUnitInsts str = case filter ((=="").snd) (readP_to_S parse str) of + [(r, "")] -> r + _ -> throwGhcException $ CmdLineError ("Can't parse -instantiated-with: " ++ str) + where parse = sepBy parseEntry (R.char ',') + parseEntry = do + n <- parseModuleName + _ <- R.char '=' + m <- parseHoleyModule + return (n, m) + +setUnitInstantiations :: String -> DynFlags -> DynFlags +setUnitInstantiations s d = + d { homeUnitInstantiations_ = parseUnitInsts s } + +setUnitInstanceOf :: String -> DynFlags -> DynFlags +setUnitInstanceOf s d = + d { homeUnitInstanceOf_ = Just (UnitId (fsLit s)) } + +addPluginModuleName :: String -> DynFlags -> DynFlags +addPluginModuleName name d = d { pluginModNames = (mkModuleName name) : (pluginModNames d) } + +clearPluginModuleNames :: DynFlags -> DynFlags +clearPluginModuleNames d = + d { pluginModNames = [] + , pluginModNameOpts = [] + } + +addPluginModuleNameOption :: String -> DynFlags -> DynFlags +addPluginModuleNameOption optflag d = d { pluginModNameOpts = (mkModuleName m, option) : (pluginModNameOpts d) } + where (m, rest) = break (== ':') optflag + option = case rest of + [] -> "" -- should probably signal an error + (_:plug_opt) -> plug_opt -- ignore the ':' from break + +addExternalPlugin :: String -> DynFlags -> DynFlags +addExternalPlugin optflag d = case parseExternalPluginSpec optflag of + Just r -> d { externalPluginSpecs = r : externalPluginSpecs d } + Nothing -> cmdLineError $ "Couldn't parse external plugin specification: " ++ optflag + +addFrontendPluginOption :: String -> DynFlags -> DynFlags +addFrontendPluginOption s d = d { frontendPluginOpts = s : frontendPluginOpts d } + +parseDynLibLoaderMode f d = + case splitAt 8 f of + ("deploy", "") -> d { dynLibLoader = Deployable } + ("sysdep", "") -> d { dynLibLoader = SystemDependent } + _ -> throwGhcException (CmdLineError ("Unknown dynlib loader: " ++ f)) + +setDumpPrefixForce f d = d { dumpPrefixForce = f} + +-- 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 = 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}) +addOptP f = alterToolSettings $ \s -> s + { toolSettings_opt_P = f : toolSettings_opt_P s + , toolSettings_opt_P_fingerprint = fingerprintStrings (f : toolSettings_opt_P s) + } + -- See Note [Repeated -optP hashing] +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 } + +setDepIncludeCppDeps :: Bool -> DynFlags -> DynFlags +setDepIncludeCppDeps b d = d { depIncludeCppDeps = b } + +setDepIncludePkgDeps :: Bool -> DynFlags -> DynFlags +setDepIncludePkgDeps b d = d { depIncludePkgDeps = b } + +addDepExcludeMod :: String -> DynFlags -> DynFlags +addDepExcludeMod m d + = d { depExcludeMods = mkModuleName m : depExcludeMods d } + +addDepSuffix :: FilePath -> DynFlags -> DynFlags +addDepSuffix s d = d { depSuffixes = s : depSuffixes d } + +addCmdlineFramework f d = d { cmdlineFrameworks = f : cmdlineFrameworks d} + +addGhcVersionFile :: FilePath -> DynFlags -> DynFlags +addGhcVersionFile f d = d { ghcVersionFile = Just f } + +addHaddockOpts f d = d { haddockOptions = Just f} + +addGhciScript f d = d { ghciScripts = f : ghciScripts d} + +setInteractivePrint f d = d { interactivePrint = Just f} + +----------------------------------------------------------------------------- +-- Setting the optimisation level + +updOptLevelChanged :: Int -> DynFlags -> (DynFlags, Bool) +-- ^ Sets the 'DynFlags' to be appropriate to the optimisation level and signals if any changes took place +updOptLevelChanged n dfs + = (dfs3, changed1 || changed2 || changed3) + where + final_n = max 0 (min 2 n) -- Clamp to 0 <= n <= 2 + (dfs1, changed1) = foldr unset (dfs , False) remove_gopts + (dfs2, changed2) = foldr set (dfs1, False) extra_gopts + (dfs3, changed3) = setLlvmOptLevel dfs2 + + extra_gopts = [ f | (ns,f) <- optLevelFlags, final_n `elem` ns ] + remove_gopts = [ f | (ns,f) <- optLevelFlags, final_n `notElem` ns ] + + set f (dfs, changed) + | gopt f dfs = (dfs, changed) + | otherwise = (gopt_set dfs f, True) + + unset f (dfs, changed) + | not (gopt f dfs) = (dfs, changed) + | otherwise = (gopt_unset dfs f, True) + + setLlvmOptLevel dfs + | llvmOptLevel dfs /= final_n = (dfs{ llvmOptLevel = final_n }, True) + | otherwise = (dfs, False) + +updOptLevel :: Int -> DynFlags -> DynFlags +-- ^ Sets the 'DynFlags' to be appropriate to the optimisation level +updOptLevel n = fst . updOptLevelChanged n + +{- ********************************************************************** +%* * + DynFlags parser +%* * +%********************************************************************* -} + +-- ----------------------------------------------------------------------------- +-- Parsing the dynamic flags. + + +-- | Parse dynamic flags from a list of command line arguments. Returns +-- 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 => Logger -> DynFlags -> [Located String] + -> m (DynFlags, [Located String], Messages DriverMessage) + -- ^ Updated 'DynFlags', left-over arguments, and + -- list of warnings. +parseDynamicFlagsCmdLine = parseDynamicFlagsFull flagsAll True + + +-- | 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 => Logger -> DynFlags -> [Located String] + -> m (DynFlags, [Located String], Messages DriverMessage) + -- ^ Updated 'DynFlags', left-over arguments, and + -- list of warnings. +parseDynamicFilePragma = parseDynamicFlagsFull flagsDynamic False + +newtype CmdLineP s a = CmdLineP (forall m. (Monad m) => StateT s m a) + deriving (Functor) + +instance Monad (CmdLineP s) where + CmdLineP k >>= f = CmdLineP (k >>= \x -> case f x of CmdLineP g -> g) + return = pure + +instance Applicative (CmdLineP s) where + pure x = CmdLineP (pure x) + (<*>) = ap + +getCmdLineState :: CmdLineP s s +getCmdLineState = CmdLineP State.get + +putCmdLineState :: s -> CmdLineP s () +putCmdLineState x = CmdLineP (State.put x) + +runCmdLineP :: CmdLineP s a -> s -> (a, s) +runCmdLineP (CmdLineP k) s0 = runIdentity $ runStateT k s0 + +-- | A helper to parse a set of flags from a list of command-line arguments, handling +-- response files. +processCmdLineP + :: forall s m. MonadIO m + => [Flag (CmdLineP s)] -- ^ valid flags to match against + -> s -- ^ current state + -> [Located String] -- ^ arguments to parse + -> m (([Located String], [Err], [Warn]), s) + -- ^ (leftovers, errors, warnings) +processCmdLineP activeFlags s0 args = + runStateT (processArgs (map (hoistFlag getCmdLineP) activeFlags) args parseResponseFile) s0 + where + getCmdLineP :: CmdLineP s a -> StateT s m a + getCmdLineP (CmdLineP k) = k + +-- | Parses the dynamically set flags for GHC. This is the most general form of +-- the dynamic flag parser that the other methods simply wrap. It allows +-- saying which flags are valid flags and indicating if we are parsing +-- arguments from the command line or from a file pragma. +parseDynamicFlagsFull + :: 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 logger dflags0 args = do + ((leftover, errs, cli_warns), dflags1) <- processCmdLineP activeFlags dflags0 args + + -- See Note [Handling errors when parsing command-line flags] + let rdr = renderWithContext (initSDocContext dflags0 defaultUserStyle) + unless (null errs) $ liftIO $ throwGhcExceptionIO $ errorsToGhcException $ + map ((rdr . ppr . getLoc &&& unLoc) . errMsg) $ errs + + -- check for disabled flags in safe haskell + let (dflags2, sh_warns) = safeFlagCheck cmdline dflags1 + theWays = ways dflags2 + + unless (allowed_combination theWays) $ liftIO $ + throwGhcExceptionIO (CmdLineError ("combination not supported: " ++ + intercalate "/" (map wayDesc (Set.toAscList theWays)))) + + let (dflags3, consistency_warnings, infoverb) = makeDynFlagsConsistent dflags2 + + -- Set timer stats & heap size + when (enableTimeStats dflags3) $ liftIO enableTimingStats + case (ghcHeapSize dflags3) of + Just x -> liftIO (setHeapSize x) + _ -> return () + + liftIO $ setUnsafeGlobalDynFlags dflags3 + + -- create message envelopes using final DynFlags: #23402 + 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 +-- in safe mode. +-- +-- The bool is to indicate if we are parsing command line flags (false means +-- file pragma). This allows us to generate better warnings. +safeFlagCheck :: Bool -> DynFlags -> (DynFlags, [Warn]) +safeFlagCheck _ dflags | safeLanguageOn dflags = (dflagsUnset, warns) + where + -- Handle illegal flags under safe language. + (dflagsUnset, warns) = foldl' check_method (dflags, mempty) unsafeFlags + + check_method (df, warns) (ext,loc,test,fix) + | test df = (fix df, safeFailure (loc df) ext : warns) + | otherwise = (df, warns) + + safeFailure loc ext + = L loc $ DriverSafeHaskellIgnoredExtension ext + +safeFlagCheck cmdl dflags = + case safeInferOn dflags of + True -> (dflags' { safeInferred = safeFlags }, warn) + False -> (dflags', warn) + + where + -- dynflags and warn for when -fpackage-trust by itself with no safe + -- haskell flag + (dflags', warn) + | not (safeHaskellModeEnabled dflags) && not cmdl && packageTrustOn dflags + = (gopt_unset dflags Opt_PackageTrust, pkgWarnMsg) + | otherwise = (dflags, mempty) + + pkgWarnMsg :: [Warn] + pkgWarnMsg = [ L (pkgTrustOnLoc dflags') DriverPackageTrustIgnored ] + + -- Have we inferred Unsafe? See Note [Safe Haskell Inference] in GHC.Driver.Main + -- Force this to avoid retaining reference to old DynFlags value + !safeFlags = all (\(_,_,t,_) -> not $ t dflags) unsafeFlagsForInfer + +-- | Produce a list of suggestions for a user provided flag that is invalid. +flagSuggestions + :: [String] -- valid flags to match against + -> String + -> [String] +flagSuggestions flags userInput + -- fixes #11789 + -- If the flag contains '=', + -- this uses both the whole and the left side of '=' for comparing. + | elem '=' userInput = + let (flagsWithEq, flagsWithoutEq) = partition (elem '=') flags + fName = takeWhile (/= '=') userInput + in (fuzzyMatch userInput flagsWithEq) ++ (fuzzyMatch fName flagsWithoutEq) + | otherwise = fuzzyMatch userInput flags + +{- ********************************************************************** +%* * + DynFlags specifications +%* * +%********************************************************************* -} + +-- | All dynamic flags option strings without the deprecated ones. +-- These are the user facing strings for enabling and disabling options. +allNonDeprecatedFlags :: [String] +allNonDeprecatedFlags = allFlagsDeps False + +-- | All flags with possibility to filter deprecated ones +allFlagsDeps :: Bool -> [String] +allFlagsDeps keepDeprecated = [ '-':flagName flag + | (deprecated, flag) <- flagsAllDeps + , keepDeprecated || not (isDeprecated deprecated)] + where isDeprecated Deprecated = True + isDeprecated _ = False + +{- + - Below we export user facing symbols for GHC dynamic flags for use with the + - GHC API. + -} + +-- All dynamic flags present in GHC. +flagsAll :: [Flag (CmdLineP DynFlags)] +flagsAll = map snd flagsAllDeps + +-- All dynamic flags present in GHC with deprecation information. +flagsAllDeps :: [(Deprecation, Flag (CmdLineP DynFlags))] +flagsAllDeps = package_flags_deps ++ dynamic_flags_deps + + +-- All dynamic flags, minus package flags, present in GHC. +flagsDynamic :: [Flag (CmdLineP DynFlags)] +flagsDynamic = map snd dynamic_flags_deps + +-- ALl package flags present in GHC. +flagsPackage :: [Flag (CmdLineP DynFlags)] +flagsPackage = map snd package_flags_deps + +----------------Helpers to make flags and keep deprecation information---------- + +type FlagMaker m = String -> OptKind m -> Flag m +type DynFlagMaker = FlagMaker (CmdLineP DynFlags) + +-- Make a non-deprecated flag +make_ord_flag :: DynFlagMaker -> String -> OptKind (CmdLineP DynFlags) + -> (Deprecation, Flag (CmdLineP DynFlags)) +make_ord_flag fm name kind = (NotDeprecated, fm name kind) + +-- Make a deprecated flag +make_dep_flag :: DynFlagMaker -> String -> OptKind (CmdLineP DynFlags) -> String + -> (Deprecation, Flag (CmdLineP DynFlags)) +make_dep_flag fm name kind message = (Deprecated, + fm name $ add_dep_message kind message) + +add_dep_message :: OptKind (CmdLineP DynFlags) -> String + -> OptKind (CmdLineP DynFlags) +add_dep_message (NoArg f) message = NoArg $ f >> deprecate message +add_dep_message (HasArg f) message = HasArg $ \s -> f s >> deprecate message +add_dep_message (SepArg f) message = SepArg $ \s -> f s >> deprecate message +add_dep_message (Prefix f) message = Prefix $ \s -> f s >> deprecate message +add_dep_message (OptPrefix f) message = + OptPrefix $ \s -> f s >> deprecate message +add_dep_message (OptIntSuffix f) message = + OptIntSuffix $ \oi -> f oi >> deprecate message +add_dep_message (IntSuffix f) message = + IntSuffix $ \i -> f i >> deprecate message +add_dep_message (Word64Suffix f) message = + Word64Suffix $ \i -> f i >> deprecate message +add_dep_message (FloatSuffix f) message = + FloatSuffix $ \fl -> f fl >> deprecate message +add_dep_message (PassFlag f) message = + PassFlag $ \s -> f s >> deprecate message +add_dep_message (AnySuffix f) message = + AnySuffix $ \s -> f s >> deprecate message + +----------------------- The main flags themselves ------------------------------ +-- See Note [Updating flag description in the User's Guide] +-- See Note [Supporting CLI completion] +dynamic_flags_deps :: [(Deprecation, Flag (CmdLineP DynFlags))] +dynamic_flags_deps = [ + make_dep_flag defFlag "n" (NoArg $ return ()) + "The -n flag is deprecated and no longer has any effect" + , make_ord_flag defFlag "cpp" (NoArg (setExtensionFlag LangExt.Cpp)) + , make_ord_flag defFlag "F" (NoArg (setGeneralFlag Opt_Pp)) + , (Deprecated, defFlag "#include" + (HasArg (\_s -> + deprecate ("-#include and INCLUDE pragmas are " ++ + "deprecated: They no longer have any effect")))) + , make_ord_flag defFlag "v" (OptIntSuffix setVerbosity) + + , make_ord_flag defGhcFlag "j" (OptIntSuffix + (\n -> case n of + Just n + | n > 0 -> upd (\d -> d { parMakeCount = Just (ParMakeThisMany n) }) + | otherwise -> addErr "Syntax: -j[n] where n > 0" + Nothing -> upd (\d -> d { parMakeCount = Just ParMakeNumProcessors }))) + -- When the number of parallel builds + -- is omitted, it is the same + -- as specifying that the number of + -- parallel builds is equal to the + -- result of getNumProcessors + , make_ord_flag defGhcFlag "jsem" $ hasArg $ \f d -> d { parMakeCount = Just (ParMakeSemaphore f) } + + , make_ord_flag defFlag "instantiated-with" (sepArg setUnitInstantiations) + , make_ord_flag defFlag "this-component-id" (sepArg setUnitInstanceOf) + + -- RTS options ------------------------------------------------------------- + , make_ord_flag defFlag "H" (HasArg (\s -> upd (\d -> + d { ghcHeapSize = Just $ fromIntegral (decodeSize s)}))) + + , make_ord_flag defFlag "Rghc-timing" (NoArg (upd (\d -> + d { enableTimeStats = True }))) + + ------- ways --------------------------------------------------------------- + , make_ord_flag defGhcFlag "prof" (NoArg (addWayDynP WayProf)) + , (Deprecated, defFlag "eventlog" + $ noArgM $ \d -> do + deprecate "the eventlog is now enabled in all runtime system ways" + return d) + , make_ord_flag defGhcFlag "debug" (NoArg (addWayDynP WayDebug)) + , make_ord_flag defGhcFlag "threaded" (NoArg (addWayDynP WayThreaded)) + , make_ord_flag defGhcFlag "single-threaded" (NoArg (removeWayDynP WayThreaded)) + + , make_ord_flag defGhcFlag "ticky" + (NoArg (setGeneralFlag Opt_Ticky >> addWayDynP WayDebug)) + + -- -ticky enables ticky-ticky code generation, and also implies -debug which + -- is required to get the RTS ticky support. + + ----- Linker -------------------------------------------------------- + , make_ord_flag defGhcFlag "static" (NoArg (removeWayDynP WayDyn)) + , make_ord_flag defGhcFlag "dynamic" (NoArg (addWayDynP WayDyn)) + , make_ord_flag defGhcFlag "rdynamic" $ noArg $ +#if defined(linux_HOST_OS) + addOptl "-rdynamic" +#elif defined(mingw32_HOST_OS) + addOptl "-Wl,--export-all-symbols" +#else + -- ignored for compat w/ gcc: + id +#endif + , make_ord_flag defGhcFlag "relative-dynlib-paths" + (NoArg (setGeneralFlag Opt_RelativeDynlibPaths)) + , make_ord_flag defGhcFlag "copy-libs-when-linking" + (NoArg (setGeneralFlag Opt_SingleLibFolder)) + , make_ord_flag defGhcFlag "pie" (NoArg (setGeneralFlag Opt_PICExecutable)) + , make_ord_flag defGhcFlag "no-pie" (NoArg (unSetGeneralFlag Opt_PICExecutable)) + + ------- Specific phases -------------------------------------------- + -- need to appear before -pgmL to be parsed as LLVM flags. + , make_ord_flag defFlag "pgmlo" + $ 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,[]) } + , make_ord_flag defFlag "pgmi" + $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_pgm_i = f } + , make_ord_flag defFlag "pgmL" + $ 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" + $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_pgm_c = f } + , make_ord_flag defFlag "pgmcxx" + $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_pgm_cxx = f } + , (Deprecated, defFlag "pgmc-supports-no-pie" + $ noArgM $ \d -> do + deprecate $ "use -pgml-supports-no-pie instead" + pure $ alterToolSettings (\s -> s { toolSettings_ccSupportsNoPie = True }) d) + , make_ord_flag defFlag "pgms" + (HasArg (\_ -> addWarn "Object splitting was removed in GHC 8.8")) + , make_ord_flag defFlag "pgma" + $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_pgm_a = (f,[]) } + , make_ord_flag defFlag "pgml" + $ hasArg $ \f -> alterToolSettings $ \s -> s + { toolSettings_pgm_l = (f,[]) + , -- Don't pass -no-pie with custom -pgml (see #15319). Note + -- that this could break when -no-pie is actually needed. + -- But the CC_SUPPORTS_NO_PIE check only happens at + -- buildtime, and -pgml is a runtime option. A better + -- solution would be running this check for each custom + -- -pgml. + toolSettings_ccSupportsNoPie = False + } + , make_ord_flag defFlag "pgml-supports-no-pie" + $ noArg $ alterToolSettings $ \s -> s { toolSettings_ccSupportsNoPie = True } + , make_ord_flag defFlag "pgmwindres" + $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_pgm_windres = f } + , make_ord_flag defFlag "pgmar" + $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_pgm_ar = f } + , make_ord_flag defFlag "pgmotool" + $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_pgm_otool = f} + , make_ord_flag defFlag "pgminstall_name_tool" + $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_pgm_install_name_tool = f} + , make_ord_flag defFlag "pgmranlib" + $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_pgm_ranlib = f } + + + -- need to appear before -optl/-opta to be parsed as LLVM flags. + , make_ord_flag defFlag "optlm" + $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_opt_lm = f : toolSettings_opt_lm s } + , make_ord_flag defFlag "optlo" + $ 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" + (hasArg addOptc) + , make_ord_flag defFlag "optcxx" + (hasArg addOptcxx) + , make_ord_flag defFlag "opta" + $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_opt_a = f : toolSettings_opt_a s } + , make_ord_flag defFlag "optl" + (hasArg addOptl) + , make_ord_flag defFlag "optwindres" + $ hasArg $ \f -> + alterToolSettings $ \s -> s { toolSettings_opt_windres = f : toolSettings_opt_windres s } + + -- 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" + (NoArg $ setGeneralFlag Opt_SplitSections) + + -------- ghc -M ----------------------------------------------------- + , make_ord_flag defGhcFlag "dep-suffix" (hasArg addDepSuffix) + , make_ord_flag defGhcFlag "dep-makefile" (hasArg setDepMakefile) + , make_ord_flag defGhcFlag "include-cpp-deps" + (noArg (setDepIncludeCppDeps True)) + , make_ord_flag defGhcFlag "include-pkg-deps" + (noArg (setDepIncludePkgDeps True)) + , make_ord_flag defGhcFlag "exclude-module" (hasArg addDepExcludeMod) + + -------- Linking ---------------------------------------------------- + , make_ord_flag defGhcFlag "no-link" + (noArg (\d -> d { ghcLink=NoLink })) + , make_ord_flag defGhcFlag "shared" + (noArg (\d -> d { ghcLink=LinkDynLib })) + , make_ord_flag defGhcFlag "staticlib" + (noArg (\d -> setGeneralFlag' Opt_LinkRts (d { ghcLink=LinkStaticLib }))) + , make_ord_flag defGhcFlag "-merge-objs" + (noArg (\d -> d { ghcLink=LinkMergedObj })) + , make_ord_flag defGhcFlag "dynload" (hasArg parseDynLibLoaderMode) + , make_ord_flag defGhcFlag "dylib-install-name" (hasArg setDylibInstallName) + + ------- Libraries --------------------------------------------------- + , make_ord_flag defFlag "L" (Prefix addLibraryPath) + , make_ord_flag defFlag "l" (hasArg (addLdInputs . Option . ("-l" ++))) + + ------- Frameworks -------------------------------------------------- + -- -framework-path should really be -F ... + , make_ord_flag defFlag "framework-path" (HasArg addFrameworkPath) + , make_ord_flag defFlag "framework" (hasArg addCmdlineFramework) + + ------- Output Redirection ------------------------------------------ + , make_ord_flag defGhcFlag "odir" (hasArg setObjectDir) + , make_ord_flag defGhcFlag "o" (sepArg (setOutputFile . Just)) + , make_ord_flag defGhcFlag "dyno" + (sepArg (setDynOutputFile . Just)) + , make_ord_flag defGhcFlag "ohi" + (hasArg (setOutputHi . Just )) + , make_ord_flag defGhcFlag "dynohi" + (hasArg (setDynOutputHi . Just )) + , make_ord_flag defGhcFlag "osuf" (hasArg setObjectSuf) + , make_ord_flag defGhcFlag "dynosuf" (hasArg setDynObjectSuf) + , make_ord_flag defGhcFlag "hcsuf" (hasArg setHcSuf) + , make_ord_flag defGhcFlag "hisuf" (hasArg setHiSuf) + , make_ord_flag defGhcFlag "hiesuf" (hasArg setHieSuf) + , make_ord_flag defGhcFlag "dynhisuf" (hasArg setDynHiSuf) + , make_ord_flag defGhcFlag "hidir" (hasArg setHiDir) + , make_ord_flag defGhcFlag "hiedir" (hasArg setHieDir) + , make_ord_flag defGhcFlag "tmpdir" (hasArg setTmpDir) + , make_ord_flag defGhcFlag "stubdir" (hasArg setStubDir) + , make_ord_flag defGhcFlag "dumpdir" (hasArg setDumpDir) + , make_ord_flag defGhcFlag "outputdir" (hasArg setOutputDir) + , make_ord_flag defGhcFlag "ddump-file-prefix" + (hasArg (setDumpPrefixForce . Just . flip (++) ".")) + + , make_ord_flag defGhcFlag "dynamic-too" + (NoArg (setGeneralFlag Opt_BuildDynamicToo)) + + ------- Keeping temporary files ------------------------------------- + -- These can be singular (think ghc -c) or plural (think ghc --make) + , make_ord_flag defGhcFlag "keep-hc-file" + (NoArg (setGeneralFlag Opt_KeepHcFiles)) + , make_ord_flag defGhcFlag "keep-hc-files" + (NoArg (setGeneralFlag Opt_KeepHcFiles)) + , make_ord_flag defGhcFlag "keep-hscpp-file" + (NoArg (setGeneralFlag Opt_KeepHscppFiles)) + , make_ord_flag defGhcFlag "keep-hscpp-files" + (NoArg (setGeneralFlag Opt_KeepHscppFiles)) + , make_ord_flag defGhcFlag "keep-s-file" + (NoArg (setGeneralFlag Opt_KeepSFiles)) + , make_ord_flag defGhcFlag "keep-s-files" + (NoArg (setGeneralFlag Opt_KeepSFiles)) + , make_ord_flag defGhcFlag "keep-llvm-file" + (NoArg $ setObjBackend llvmBackend >> setGeneralFlag Opt_KeepLlvmFiles) + , make_ord_flag defGhcFlag "keep-llvm-files" + (NoArg $ setObjBackend llvmBackend >> setGeneralFlag Opt_KeepLlvmFiles) + -- This only makes sense as plural + , make_ord_flag defGhcFlag "keep-tmp-files" + (NoArg (setGeneralFlag Opt_KeepTmpFiles)) + , make_ord_flag defGhcFlag "keep-hi-file" + (NoArg (setGeneralFlag Opt_KeepHiFiles)) + , make_ord_flag defGhcFlag "no-keep-hi-file" + (NoArg (unSetGeneralFlag Opt_KeepHiFiles)) + , make_ord_flag defGhcFlag "keep-hi-files" + (NoArg (setGeneralFlag Opt_KeepHiFiles)) + , make_ord_flag defGhcFlag "no-keep-hi-files" + (NoArg (unSetGeneralFlag Opt_KeepHiFiles)) + , make_ord_flag defGhcFlag "keep-o-file" + (NoArg (setGeneralFlag Opt_KeepOFiles)) + , make_ord_flag defGhcFlag "no-keep-o-file" + (NoArg (unSetGeneralFlag Opt_KeepOFiles)) + , make_ord_flag defGhcFlag "keep-o-files" + (NoArg (setGeneralFlag Opt_KeepOFiles)) + , make_ord_flag defGhcFlag "no-keep-o-files" + (NoArg (unSetGeneralFlag Opt_KeepOFiles)) + + ------- Miscellaneous ---------------------------------------------- + , make_ord_flag defGhcFlag "no-auto-link-packages" + (NoArg (unSetGeneralFlag Opt_AutoLinkPackages)) + , make_ord_flag defGhcFlag "no-hs-main" + (NoArg (setGeneralFlag Opt_NoHsMain)) + , make_ord_flag defGhcFlag "fno-state-hack" + (NoArg (setGeneralFlag Opt_G_NoStateHack)) + , make_ord_flag defGhcFlag "fno-opt-coercion" + (NoArg (setGeneralFlag Opt_G_NoOptCoercion)) + , make_ord_flag defGhcFlag "with-rtsopts" + (HasArg setRtsOpts) + , make_ord_flag defGhcFlag "rtsopts" + (NoArg (setRtsOptsEnabled RtsOptsAll)) + , make_ord_flag defGhcFlag "rtsopts=all" + (NoArg (setRtsOptsEnabled RtsOptsAll)) + , make_ord_flag defGhcFlag "rtsopts=some" + (NoArg (setRtsOptsEnabled RtsOptsSafeOnly)) + , make_ord_flag defGhcFlag "rtsopts=none" + (NoArg (setRtsOptsEnabled RtsOptsNone)) + , make_ord_flag defGhcFlag "rtsopts=ignore" + (NoArg (setRtsOptsEnabled RtsOptsIgnore)) + , make_ord_flag defGhcFlag "rtsopts=ignoreAll" + (NoArg (setRtsOptsEnabled RtsOptsIgnoreAll)) + , make_ord_flag defGhcFlag "no-rtsopts" + (NoArg (setRtsOptsEnabled RtsOptsNone)) + , make_ord_flag defGhcFlag "no-rtsopts-suggestions" + (noArg (\d -> d {rtsOptsSuggestions = False})) + , make_ord_flag defGhcFlag "dhex-word-literals" + (NoArg (setGeneralFlag Opt_HexWordLiterals)) + + , make_ord_flag defGhcFlag "ghcversion-file" (hasArg addGhcVersionFile) + , make_ord_flag defGhcFlag "main-is" (SepArg setMainIs) + , make_ord_flag defGhcFlag "haddock" (NoArg (setGeneralFlag Opt_Haddock)) + , make_ord_flag defGhcFlag "no-haddock" (NoArg (unSetGeneralFlag Opt_Haddock)) + , make_ord_flag defGhcFlag "haddock-opts" (hasArg addHaddockOpts) + , make_ord_flag defGhcFlag "hpcdir" (SepArg setOptHpcDir) + , make_ord_flag defGhciFlag "ghci-script" (hasArg addGhciScript) + , make_ord_flag defGhciFlag "interactive-print" (hasArg setInteractivePrint) + , make_ord_flag defGhcFlag "ticky-allocd" + (NoArg (setGeneralFlag Opt_Ticky_Allocd)) + , make_ord_flag defGhcFlag "ticky-LNE" + (NoArg (setGeneralFlag Opt_Ticky_LNE)) + , make_ord_flag defGhcFlag "ticky-ap-thunk" + (NoArg (setGeneralFlag Opt_Ticky_AP)) + , make_ord_flag defGhcFlag "ticky-dyn-thunk" + (NoArg (setGeneralFlag Opt_Ticky_Dyn_Thunk)) + , make_ord_flag defGhcFlag "ticky-tag-checks" + (NoArg (setGeneralFlag Opt_Ticky_Tag)) + ------- recompilation checker -------------------------------------- + , make_dep_flag defGhcFlag "recomp" + (NoArg $ unSetGeneralFlag Opt_ForceRecomp) + "Use -fno-force-recomp instead" + , make_dep_flag defGhcFlag "no-recomp" + (NoArg $ setGeneralFlag Opt_ForceRecomp) "Use -fforce-recomp instead" + , make_ord_flag defFlag "fmax-errors" + (intSuffix (\n d -> d { maxErrors = Just (max 1 n) })) + , make_ord_flag defFlag "fno-max-errors" + (noArg (\d -> d { maxErrors = Nothing })) + , make_ord_flag defFlag "freverse-errors" + (noArg (\d -> d {reverseErrors = True} )) + , make_ord_flag defFlag "fno-reverse-errors" + (noArg (\d -> d {reverseErrors = False} )) + + ------ HsCpp opts --------------------------------------------------- + , make_ord_flag defFlag "D" (AnySuffix (upd . addOptP)) + , make_ord_flag defFlag "U" (AnySuffix (upd . addOptP)) + + ------- Include/Import Paths ---------------------------------------- + , make_ord_flag defFlag "I" (Prefix addIncludePath) + , make_ord_flag defFlag "i" (OptPrefix addImportPath) + + ------ Output style options ----------------------------------------- + , make_ord_flag defFlag "dppr-user-length" (intSuffix (\n d -> + d { pprUserLength = n })) + , make_ord_flag defFlag "dppr-cols" (intSuffix (\n d -> + d { pprCols = n })) + , make_ord_flag defFlag "fdiagnostics-color=auto" + (NoArg (upd (\d -> d { useColor = Auto }))) + , make_ord_flag defFlag "fdiagnostics-color=always" + (NoArg (upd (\d -> d { useColor = Always }))) + , 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. + , make_ord_flag defGhcFlag "dsuppress-all" + (NoArg $ do setGeneralFlag Opt_SuppressCoercions + setGeneralFlag Opt_SuppressCoercionTypes + setGeneralFlag Opt_SuppressVarKinds + setGeneralFlag Opt_SuppressModulePrefixes + setGeneralFlag Opt_SuppressTypeApplications + setGeneralFlag Opt_SuppressIdInfo + setGeneralFlag Opt_SuppressTicks + setGeneralFlag Opt_SuppressStgExts + setGeneralFlag Opt_SuppressStgReps + setGeneralFlag Opt_SuppressTypeSignatures + setGeneralFlag Opt_SuppressCoreSizes + setGeneralFlag Opt_SuppressTimestamps) + + ------ Debugging ---------------------------------------------------- + , make_ord_flag defGhcFlag "dstg-stats" + (NoArg (setGeneralFlag Opt_StgStats)) + + , make_ord_flag defGhcFlag "ddump-cmm" + (setDumpFlag Opt_D_dump_cmm) + , make_ord_flag defGhcFlag "ddump-cmm-from-stg" + (setDumpFlag Opt_D_dump_cmm_from_stg) + , make_ord_flag defGhcFlag "ddump-cmm-raw" + (setDumpFlag Opt_D_dump_cmm_raw) + , make_ord_flag defGhcFlag "ddump-cmm-verbose" + (setDumpFlag Opt_D_dump_cmm_verbose) + , make_ord_flag defGhcFlag "ddump-cmm-verbose-by-proc" + (setDumpFlag Opt_D_dump_cmm_verbose_by_proc) + , make_ord_flag defGhcFlag "ddump-cmm-cfg" + (setDumpFlag Opt_D_dump_cmm_cfg) + , make_ord_flag defGhcFlag "ddump-cmm-cbe" + (setDumpFlag Opt_D_dump_cmm_cbe) + , make_ord_flag defGhcFlag "ddump-cmm-switch" + (setDumpFlag Opt_D_dump_cmm_switch) + , make_ord_flag defGhcFlag "ddump-cmm-proc" + (setDumpFlag Opt_D_dump_cmm_proc) + , make_ord_flag defGhcFlag "ddump-cmm-sp" + (setDumpFlag Opt_D_dump_cmm_sp) + , make_ord_flag defGhcFlag "ddump-cmm-sink" + (setDumpFlag Opt_D_dump_cmm_sink) + , make_ord_flag defGhcFlag "ddump-cmm-caf" + (setDumpFlag Opt_D_dump_cmm_caf) + , make_ord_flag defGhcFlag "ddump-cmm-procmap" + (setDumpFlag Opt_D_dump_cmm_procmap) + , make_ord_flag defGhcFlag "ddump-cmm-split" + (setDumpFlag Opt_D_dump_cmm_split) + , make_ord_flag defGhcFlag "ddump-cmm-info" + (setDumpFlag Opt_D_dump_cmm_info) + , make_ord_flag defGhcFlag "ddump-cmm-cps" + (setDumpFlag Opt_D_dump_cmm_cps) + , make_ord_flag defGhcFlag "ddump-cmm-opt" + (setDumpFlag Opt_D_dump_opt_cmm) + , make_ord_flag defGhcFlag "ddump-cmm-thread-sanitizer" + (setDumpFlag Opt_D_dump_cmm_thread_sanitizer) + , make_ord_flag defGhcFlag "ddump-cfg-weights" + (setDumpFlag Opt_D_dump_cfg_weights) + , make_ord_flag defGhcFlag "ddump-core-stats" + (setDumpFlag Opt_D_dump_core_stats) + , make_ord_flag defGhcFlag "ddump-asm" + (setDumpFlag Opt_D_dump_asm) + , make_ord_flag defGhcFlag "ddump-js" + (setDumpFlag Opt_D_dump_js) + , make_ord_flag defGhcFlag "ddump-asm-native" + (setDumpFlag Opt_D_dump_asm_native) + , make_ord_flag defGhcFlag "ddump-asm-liveness" + (setDumpFlag Opt_D_dump_asm_liveness) + , make_ord_flag defGhcFlag "ddump-asm-regalloc" + (setDumpFlag Opt_D_dump_asm_regalloc) + , make_ord_flag defGhcFlag "ddump-asm-conflicts" + (setDumpFlag Opt_D_dump_asm_conflicts) + , make_ord_flag defGhcFlag "ddump-asm-regalloc-stages" + (setDumpFlag Opt_D_dump_asm_regalloc_stages) + , make_ord_flag defGhcFlag "ddump-asm-stats" + (setDumpFlag Opt_D_dump_asm_stats) + , make_ord_flag defGhcFlag "ddump-llvm" + (NoArg $ setDumpFlag' Opt_D_dump_llvm) + , make_ord_flag defGhcFlag "ddump-c-backend" + (NoArg $ setDumpFlag' Opt_D_dump_c_backend) + , make_ord_flag defGhcFlag "ddump-deriv" + (setDumpFlag Opt_D_dump_deriv) + , make_ord_flag defGhcFlag "ddump-ds" + (setDumpFlag Opt_D_dump_ds) + , make_ord_flag defGhcFlag "ddump-ds-preopt" + (setDumpFlag Opt_D_dump_ds_preopt) + , make_ord_flag defGhcFlag "ddump-foreign" + (setDumpFlag Opt_D_dump_foreign) + , make_ord_flag defGhcFlag "ddump-inlinings" + (setDumpFlag Opt_D_dump_inlinings) + , make_ord_flag defGhcFlag "ddump-verbose-inlinings" + (setDumpFlag Opt_D_dump_verbose_inlinings) + , make_ord_flag defGhcFlag "ddump-rule-firings" + (setDumpFlag Opt_D_dump_rule_firings) + , make_ord_flag defGhcFlag "ddump-rule-rewrites" + (setDumpFlag Opt_D_dump_rule_rewrites) + , make_ord_flag defGhcFlag "ddump-simpl-trace" + (setDumpFlag Opt_D_dump_simpl_trace) + , make_ord_flag defGhcFlag "ddump-occur-anal" + (setDumpFlag Opt_D_dump_occur_anal) + , make_ord_flag defGhcFlag "ddump-parsed" + (setDumpFlag Opt_D_dump_parsed) + , make_ord_flag defGhcFlag "ddump-parsed-ast" + (setDumpFlag Opt_D_dump_parsed_ast) + , make_ord_flag defGhcFlag "dkeep-comments" + (NoArg (setGeneralFlag Opt_KeepRawTokenStream)) + , make_ord_flag defGhcFlag "ddump-rn" + (setDumpFlag Opt_D_dump_rn) + , make_ord_flag defGhcFlag "ddump-rn-ast" + (setDumpFlag Opt_D_dump_rn_ast) + , make_ord_flag defGhcFlag "ddump-simpl" + (setDumpFlag Opt_D_dump_simpl) + , make_ord_flag defGhcFlag "ddump-simpl-iterations" + (setDumpFlag Opt_D_dump_simpl_iterations) + , make_ord_flag defGhcFlag "ddump-spec" + (setDumpFlag Opt_D_dump_spec) + , make_ord_flag defGhcFlag "ddump-spec-constr" + (setDumpFlag Opt_D_dump_spec_constr) + , make_ord_flag defGhcFlag "ddump-prep" + (setDumpFlag Opt_D_dump_prep) + , make_ord_flag defGhcFlag "ddump-late-cc" + (setDumpFlag Opt_D_dump_late_cc) + , make_ord_flag defGhcFlag "ddump-stg-from-core" + (setDumpFlag Opt_D_dump_stg_from_core) + , make_ord_flag defGhcFlag "ddump-stg-unarised" + (setDumpFlag Opt_D_dump_stg_unarised) + , make_ord_flag defGhcFlag "ddump-stg-final" + (setDumpFlag Opt_D_dump_stg_final) + , make_ord_flag defGhcFlag "ddump-stg-cg" + (setDumpFlag Opt_D_dump_stg_cg) + , make_dep_flag defGhcFlag "ddump-stg" + (setDumpFlag Opt_D_dump_stg_from_core) + "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_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" + (setDumpFlag Opt_D_dump_cpr_signatures) + , make_ord_flag defGhcFlag "ddump-tc" + (setDumpFlag Opt_D_dump_tc) + , make_ord_flag defGhcFlag "ddump-tc-ast" + (setDumpFlag Opt_D_dump_tc_ast) + , make_ord_flag defGhcFlag "ddump-hie" + (setDumpFlag Opt_D_dump_hie) + , make_ord_flag defGhcFlag "ddump-types" + (setDumpFlag Opt_D_dump_types) + , make_ord_flag defGhcFlag "ddump-rules" + (setDumpFlag Opt_D_dump_rules) + , make_ord_flag defGhcFlag "ddump-cse" + (setDumpFlag Opt_D_dump_cse) + , make_ord_flag defGhcFlag "ddump-float-out" + (setDumpFlag Opt_D_dump_float_out) + , make_ord_flag defGhcFlag "ddump-full-laziness" + (setDumpFlag Opt_D_dump_float_out) + , make_ord_flag defGhcFlag "ddump-float-in" + (setDumpFlag Opt_D_dump_float_in) + , make_ord_flag defGhcFlag "ddump-liberate-case" + (setDumpFlag Opt_D_dump_liberate_case) + , make_ord_flag defGhcFlag "ddump-static-argument-transformation" + (setDumpFlag Opt_D_dump_static_argument_transformation) + , make_ord_flag defGhcFlag "ddump-worker-wrapper" + (setDumpFlag Opt_D_dump_worker_wrapper) + , make_ord_flag defGhcFlag "ddump-rn-trace" + (setDumpFlag Opt_D_dump_rn_trace) + , make_ord_flag defGhcFlag "ddump-if-trace" + (setDumpFlag Opt_D_dump_if_trace) + , make_ord_flag defGhcFlag "ddump-cs-trace" + (setDumpFlag Opt_D_dump_cs_trace) + , make_ord_flag defGhcFlag "ddump-tc-trace" + (NoArg (do setDumpFlag' Opt_D_dump_tc_trace + setDumpFlag' Opt_D_dump_cs_trace)) + , make_ord_flag defGhcFlag "ddump-ec-trace" + (setDumpFlag Opt_D_dump_ec_trace) + , make_ord_flag defGhcFlag "ddump-splices" + (setDumpFlag Opt_D_dump_splices) + , make_ord_flag defGhcFlag "dth-dec-file" + (setDumpFlag Opt_D_th_dec_file) + + , make_ord_flag defGhcFlag "ddump-rn-stats" + (setDumpFlag Opt_D_dump_rn_stats) + , make_ord_flag defGhcFlag "ddump-opt-cmm" --old alias for cmm-opt + (setDumpFlag Opt_D_dump_opt_cmm) + , make_ord_flag defGhcFlag "ddump-simpl-stats" + (setDumpFlag Opt_D_dump_simpl_stats) + , make_ord_flag defGhcFlag "ddump-bcos" + (setDumpFlag Opt_D_dump_BCOs) + , make_ord_flag defGhcFlag "dsource-stats" + (setDumpFlag Opt_D_source_stats) + , make_ord_flag defGhcFlag "dverbose-core2core" + (NoArg $ setVerbosity (Just 2) >> setDumpFlag' Opt_D_verbose_core2core) + , make_ord_flag defGhcFlag "dverbose-stg2stg" + (setDumpFlag Opt_D_verbose_stg2stg) + , make_ord_flag defGhcFlag "ddump-hi" + (setDumpFlag Opt_D_dump_hi) + , make_ord_flag defGhcFlag "ddump-minimal-imports" + (NoArg (setGeneralFlag Opt_D_dump_minimal_imports)) + , make_ord_flag defGhcFlag "ddump-hpc" + (setDumpFlag Opt_D_dump_ticked) -- back compat + , make_ord_flag defGhcFlag "ddump-ticked" + (setDumpFlag Opt_D_dump_ticked) + , make_ord_flag defGhcFlag "ddump-mod-cycles" + (setDumpFlag Opt_D_dump_mod_cycles) + , make_ord_flag defGhcFlag "ddump-mod-map" + (setDumpFlag Opt_D_dump_mod_map) + , make_ord_flag defGhcFlag "ddump-timings" + (setDumpFlag Opt_D_dump_timings) + , make_ord_flag defGhcFlag "ddump-view-pattern-commoning" + (setDumpFlag Opt_D_dump_view_pattern_commoning) + , make_ord_flag defGhcFlag "ddump-to-file" + (NoArg (setGeneralFlag Opt_DumpToFile)) + , make_ord_flag defGhcFlag "ddump-hi-diffs" + (setDumpFlag Opt_D_dump_hi_diffs) + , make_ord_flag defGhcFlag "ddump-rtti" + (setDumpFlag Opt_D_dump_rtti) + , make_ord_flag defGhcFlag "dlint" + (NoArg enableDLint) + , make_ord_flag defGhcFlag "dcore-lint" + (NoArg (setGeneralFlag Opt_DoCoreLinting)) + , make_ord_flag defGhcFlag "dlinear-core-lint" + (NoArg (setGeneralFlag Opt_DoLinearCoreLinting)) + , make_ord_flag defGhcFlag "dstg-lint" + (NoArg (setGeneralFlag Opt_DoStgLinting)) + , make_ord_flag defGhcFlag "dcmm-lint" + (NoArg (setGeneralFlag Opt_DoCmmLinting)) + , make_ord_flag defGhcFlag "dasm-lint" + (NoArg (setGeneralFlag Opt_DoAsmLinting)) + , make_ord_flag defGhcFlag "dannot-lint" + (NoArg (setGeneralFlag Opt_DoAnnotationLinting)) + , make_ord_flag defGhcFlag "dtag-inference-checks" + (NoArg (setGeneralFlag Opt_DoTagInferenceChecks)) + , make_ord_flag defGhcFlag "dshow-passes" + (NoArg $ forceRecompile >> (setVerbosity $ Just 2)) + , make_ord_flag defGhcFlag "dipe-stats" + (setDumpFlag Opt_D_ipe_stats) + , make_ord_flag defGhcFlag "dfaststring-stats" + (setDumpFlag Opt_D_faststring_stats) + , make_ord_flag defGhcFlag "dno-llvm-mangler" + (NoArg (setGeneralFlag Opt_NoLlvmMangler)) -- hidden flag + , make_ord_flag defGhcFlag "dno-typeable-binds" + (NoArg (setGeneralFlag Opt_NoTypeableBinds)) + , make_ord_flag defGhcFlag "ddump-debug" + (setDumpFlag Opt_D_dump_debug) + , 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) + + ------ Machine dependent (-m) stuff --------------------------- + + , make_ord_flag defGhcFlag "msse" (noArg (\d -> + d { sseVersion = Just SSE1 })) + , make_ord_flag defGhcFlag "msse2" (noArg (\d -> + 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 -> + d { sseVersion = Just SSE42 })) + , make_ord_flag defGhcFlag "mbmi" (noArg (\d -> + d { bmiVersion = Just BMI1 })) + , make_ord_flag defGhcFlag "mbmi2" (noArg (\d -> + d { bmiVersion = Just BMI2 })) + , make_ord_flag defGhcFlag "mavx" (noArg (\d -> d { avx = True })) + , make_ord_flag defGhcFlag "mavx2" (noArg (\d -> d { avx2 = True })) + , make_ord_flag defGhcFlag "mavx512cd" (noArg (\d -> + d { avx512cd = True })) + , make_ord_flag defGhcFlag "mavx512er" (noArg (\d -> + d { avx512er = True })) + , make_ord_flag defGhcFlag "mavx512f" (noArg (\d -> d { avx512f = True })) + , make_ord_flag defGhcFlag "mavx512pf" (noArg (\d -> + d { avx512pf = True })) + , make_ord_flag defGhcFlag "mfma" (noArg (\d -> d { fma = True })) + + ------ Plugin flags ------------------------------------------------ + , make_ord_flag defGhcFlag "fplugin-opt" (hasArg addPluginModuleNameOption) + , make_ord_flag defGhcFlag "fplugin-trustworthy" + (NoArg (setGeneralFlag Opt_PluginTrustworthy)) + , make_ord_flag defGhcFlag "fplugin" (hasArg addPluginModuleName) + , make_ord_flag defGhcFlag "fclear-plugins" (noArg clearPluginModuleNames) + , make_ord_flag defGhcFlag "ffrontend-opt" (hasArg addFrontendPluginOption) + + , make_ord_flag defGhcFlag "fplugin-library" (hasArg addExternalPlugin) + + ------ Optimisation flags ------------------------------------------ + , make_dep_flag defGhcFlag "Onot" (noArgM $ setOptLevel 0 ) + "Use -O0 instead" + , make_ord_flag defGhcFlag "O" (optIntSuffixM (\mb_n -> + setOptLevel (mb_n `orElse` 1))) + -- If the number is missing, use 1 + + , make_ord_flag defFlag "fbinary-blob-threshold" + (intSuffix (\n d -> d { binBlobThreshold = case fromIntegral n of + 0 -> Nothing + x -> Just x})) + , make_ord_flag defFlag "fmax-relevant-binds" + (intSuffix (\n d -> d { maxRelevantBinds = Just n })) + , make_ord_flag defFlag "fno-max-relevant-binds" + (noArg (\d -> d { maxRelevantBinds = Nothing })) + + , make_ord_flag defFlag "fmax-valid-hole-fits" + (intSuffix (\n d -> d { maxValidHoleFits = Just n })) + , make_ord_flag defFlag "fno-max-valid-hole-fits" + (noArg (\d -> d { maxValidHoleFits = Nothing })) + , make_ord_flag defFlag "fmax-refinement-hole-fits" + (intSuffix (\n d -> d { maxRefHoleFits = Just n })) + , make_ord_flag defFlag "fno-max-refinement-hole-fits" + (noArg (\d -> d { maxRefHoleFits = Nothing })) + , make_ord_flag defFlag "frefinement-level-hole-fits" + (intSuffix (\n d -> d { refLevelHoleFits = Just n })) + , 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." + , make_ord_flag defFlag "fmax-uncovered-patterns" + (intSuffix (\n d -> d { maxUncoveredPatterns = n })) + , make_ord_flag defFlag "fmax-pmcheck-models" + (intSuffix (\n d -> d { maxPmCheckModels = n })) + , make_ord_flag defFlag "fsimplifier-phases" + (intSuffix (\n d -> d { simplPhases = n })) + , make_ord_flag defFlag "fmax-simplifier-iterations" + (intSuffix (\n d -> d { maxSimplIterations = n })) + , (Deprecated, defFlag "fmax-pmcheck-iterations" + (intSuffixM (\_ d -> + do { deprecate $ "use -fmax-pmcheck-models instead" + ; return d }))) + , make_ord_flag defFlag "fsimpl-tick-factor" + (intSuffix (\n d -> d { simplTickFactor = n })) + , make_ord_flag defFlag "fdmd-unbox-width" + (intSuffix (\n d -> d { dmdUnboxWidth = n })) + , make_ord_flag defFlag "fspec-constr-threshold" + (intSuffix (\n d -> d { specConstrThreshold = Just n })) + , make_ord_flag defFlag "fno-spec-constr-threshold" + (noArg (\d -> d { specConstrThreshold = Nothing })) + , make_ord_flag defFlag "fspec-constr-count" + (intSuffix (\n d -> d { specConstrCount = Just n })) + , make_ord_flag defFlag "fno-spec-constr-count" + (noArg (\d -> d { specConstrCount = Nothing })) + , make_ord_flag defFlag "fspec-constr-recursive" + (intSuffix (\n d -> d { specConstrRecursive = n })) + , make_ord_flag defFlag "fliberate-case-threshold" + (intSuffix (\n d -> d { liberateCaseThreshold = Just n })) + , make_ord_flag defFlag "fno-liberate-case-threshold" + (noArg (\d -> d { liberateCaseThreshold = Nothing })) + , make_ord_flag defFlag "drule-check" + (sepArg (\s d -> d { ruleCheck = Just s })) + , make_ord_flag defFlag "dinline-check" + (sepArg (\s d -> d { unfoldingOpts = updateReportPrefix (Just s) (unfoldingOpts d)})) + , make_ord_flag defFlag "freduction-depth" + (intSuffix (\n d -> d { reductionDepth = treatZeroAsInf n })) + , make_ord_flag defFlag "fconstraint-solver-iterations" + (intSuffix (\n d -> d { solverIterations = treatZeroAsInf n })) + , make_ord_flag defFlag "fgivens-expansion-fuel" + (intSuffix (\n d -> d { givensFuel = n })) + , make_ord_flag defFlag "fwanteds-expansion-fuel" + (intSuffix (\n d -> d { wantedsFuel = n })) + , make_ord_flag defFlag "fqcs-expansion-fuel" + (intSuffix (\n d -> d { qcsFuel = n })) + , (Deprecated, defFlag "fcontext-stack" + (intSuffixM (\n d -> + do { deprecate $ "use -freduction-depth=" ++ show n ++ " instead" + ; return $ d { reductionDepth = treatZeroAsInf n } }))) + , (Deprecated, defFlag "ftype-function-depth" + (intSuffixM (\n d -> + do { deprecate $ "use -freduction-depth=" ++ show n ++ " instead" + ; return $ d { reductionDepth = treatZeroAsInf n } }))) + , make_ord_flag defFlag "fstrictness-before" + (intSuffix (\n d -> d { strictnessBefore = n : strictnessBefore d })) + , make_ord_flag defFlag "ffloat-lam-args" + (intSuffix (\n d -> d { floatLamArgs = Just n })) + , make_ord_flag defFlag "ffloat-all-lams" + (noArg (\d -> d { floatLamArgs = Nothing })) + , make_ord_flag defFlag "fstg-lift-lams-rec-args" + (intSuffix (\n d -> d { liftLamsRecArgs = Just n })) + , make_ord_flag defFlag "fstg-lift-lams-rec-args-any" + (noArg (\d -> d { liftLamsRecArgs = Nothing })) + , make_ord_flag defFlag "fstg-lift-lams-non-rec-args" + (intSuffix (\n d -> d { liftLamsNonRecArgs = Just n })) + , make_ord_flag defFlag "fstg-lift-lams-non-rec-args-any" + (noArg (\d -> d { liftLamsNonRecArgs = Nothing })) + , make_ord_flag defFlag "fstg-lift-lams-known" + (noArg (\d -> d { liftLamsKnown = True })) + , make_ord_flag defFlag "fno-stg-lift-lams-known" + (noArg (\d -> d { liftLamsKnown = False })) + , make_ord_flag defFlag "fproc-alignment" + (intSuffix (\n d -> d { cmmProcAlignment = Just n })) + , make_ord_flag defFlag "fblock-layout-weights" + (HasArg (\s -> + upd (\d -> d { cfgWeights = + parseWeights s (cfgWeights d)}))) + , make_ord_flag defFlag "fhistory-size" + (intSuffix (\n d -> d { historySize = n })) + + , make_ord_flag defFlag "funfolding-creation-threshold" + (intSuffix (\n d -> d { unfoldingOpts = updateCreationThreshold n (unfoldingOpts d)})) + , make_ord_flag defFlag "funfolding-use-threshold" + (intSuffix (\n d -> d { unfoldingOpts = updateUseThreshold n (unfoldingOpts d)})) + , make_ord_flag defFlag "funfolding-fun-discount" + (intSuffix (\n d -> d { unfoldingOpts = updateFunAppDiscount n (unfoldingOpts d)})) + , make_ord_flag defFlag "funfolding-dict-discount" + (intSuffix (\n d -> d { unfoldingOpts = updateDictDiscount n (unfoldingOpts d)})) + + , make_ord_flag defFlag "funfolding-case-threshold" + (intSuffix (\n d -> d { unfoldingOpts = updateCaseThreshold n (unfoldingOpts d)})) + , make_ord_flag defFlag "funfolding-case-scaling" + (intSuffix (\n d -> d { unfoldingOpts = updateCaseScaling n (unfoldingOpts d)})) + + , make_dep_flag defFlag "funfolding-keeness-factor" + (floatSuffix (\_ d -> d)) + "-funfolding-keeness-factor is no longer respected as of GHC 9.0" + + , 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" + (intSuffix (\n d -> d { maxInlineMemcpyInsns = n })) + , make_ord_flag defGhcFlag "fmax-inline-memset-insns" + (intSuffix (\n d -> d { maxInlineMemsetInsns = n })) + , make_ord_flag defGhcFlag "dinitial-unique" + (word64Suffix (\n d -> d { initialUnique = n })) + , make_ord_flag defGhcFlag "dunique-increment" + (intSuffix (\n d -> d { uniqueIncrement = n })) + + ------ Profiling ---------------------------------------------------- + + -- OLD profiling flags + , make_dep_flag defGhcFlag "auto-all" + (noArg (\d -> d { profAuto = ProfAutoAll } )) + "Use -fprof-auto instead" + , make_dep_flag defGhcFlag "no-auto-all" + (noArg (\d -> d { profAuto = NoProfAuto } )) + "Use -fno-prof-auto instead" + , make_dep_flag defGhcFlag "auto" + (noArg (\d -> d { profAuto = ProfAutoExports } )) + "Use -fprof-auto-exported instead" + , make_dep_flag defGhcFlag "no-auto" + (noArg (\d -> d { profAuto = NoProfAuto } )) + "Use -fno-prof-auto instead" + , make_dep_flag defGhcFlag "caf-all" + (NoArg (setGeneralFlag Opt_AutoSccsOnIndividualCafs)) + "Use -fprof-cafs instead" + , make_dep_flag defGhcFlag "no-caf-all" + (NoArg (unSetGeneralFlag Opt_AutoSccsOnIndividualCafs)) + "Use -fno-prof-cafs instead" + + -- NEW profiling flags + , make_ord_flag defGhcFlag "fprof-auto" + (noArg (\d -> d { profAuto = ProfAutoAll } )) + , make_ord_flag defGhcFlag "fprof-auto-top" + (noArg (\d -> d { profAuto = ProfAutoTop } )) + , make_ord_flag defGhcFlag "fprof-auto-exported" + (noArg (\d -> d { profAuto = ProfAutoExports } )) + , make_ord_flag defGhcFlag "fprof-auto-calls" + (noArg (\d -> d { profAuto = ProfAutoCalls } )) + , make_ord_flag defGhcFlag "fno-prof-auto" + (noArg (\d -> d { profAuto = NoProfAuto } )) + + -- Caller-CC + , make_ord_flag defGhcFlag "fprof-callers" + (HasArg setCallerCcFilters) + ------ Compiler flags ----------------------------------------------- + + , make_ord_flag defGhcFlag "fasm" (NoArg (setObjBackend ncgBackend)) + , make_ord_flag defGhcFlag "fvia-c" (NoArg + (deprecate $ "The -fvia-c flag does nothing; " ++ + "it will be removed in a future GHC release")) + , make_ord_flag defGhcFlag "fvia-C" (NoArg + (deprecate $ "The -fvia-C flag does nothing; " ++ + "it will be removed in a future GHC release")) + , make_ord_flag defGhcFlag "fllvm" (NoArg (setObjBackend llvmBackend)) + + , make_ord_flag defFlag "fno-code" (NoArg ((upd $ \d -> + d { ghcLink=NoLink }) >> setBackend noBackend)) + , make_ord_flag defFlag "fbyte-code" + (noArgM $ \dflags -> do + setBackend interpreterBackend + pure $ flip gopt_unset Opt_ByteCodeAndObjectCode (gopt_set dflags Opt_ByteCode)) + , make_ord_flag defFlag "fobject-code" $ noArgM $ \dflags -> do + setBackend $ platformDefaultBackend (targetPlatform dflags) + dflags' <- liftEwM getCmdLineState + pure $ gopt_unset dflags' Opt_ByteCodeAndObjectCode + + , make_dep_flag defFlag "fglasgow-exts" + (NoArg enableGlasgowExts) "Use individual extensions instead" + , make_dep_flag defFlag "fno-glasgow-exts" + (NoArg disableGlasgowExts) "Use individual extensions instead" + + ------ Safe Haskell flags ------------------------------------------- + , make_ord_flag defFlag "fpackage-trust" (NoArg setPackageTrust) + , make_ord_flag defFlag "fno-safe-infer" (noArg (\d -> + d { safeInfer = False })) + , make_ord_flag defFlag "fno-safe-haskell" (NoArg (setSafeHaskell Sf_Ignore)) + + ------ position independent flags ---------------------------------- + , make_ord_flag defGhcFlag "fPIC" (NoArg (setGeneralFlag Opt_PIC)) + , make_ord_flag defGhcFlag "fno-PIC" (NoArg (unSetGeneralFlag Opt_PIC)) + , make_ord_flag defGhcFlag "fPIE" (NoArg (setGeneralFlag Opt_PIE)) + , make_ord_flag defGhcFlag "fno-PIE" (NoArg (unSetGeneralFlag Opt_PIE)) + + ------ Debugging flags ---------------------------------------------- + , make_ord_flag defGhcFlag "g" (OptIntSuffix setDebugLevel) + ] + ++ map (mkFlag turnOn "" setGeneralFlag ) negatableFlagsDeps + ++ map (mkFlag turnOff "no-" unSetGeneralFlag ) negatableFlagsDeps + ++ map (mkFlag turnOn "d" setGeneralFlag ) dFlagsDeps + ++ map (mkFlag turnOff "dno-" unSetGeneralFlag ) dFlagsDeps + ++ map (mkFlag turnOn "f" setGeneralFlag ) fFlagsDeps + ++ map (mkFlag turnOff "fno-" unSetGeneralFlag ) fFlagsDeps + ++ + + ------ Warning flags ------------------------------------------------- + [ make_ord_flag defFlag "W" (NoArg (setWarningGroup W_extra)) + , make_ord_flag defFlag "Werror" + (NoArg (do { setGeneralFlag Opt_WarnIsError + ; setFatalWarningGroup W_everything })) + , make_ord_flag defFlag "Wwarn" + (NoArg (do { unSetGeneralFlag Opt_WarnIsError + ; unSetFatalWarningGroup W_everything })) + -- Opt_WarnIsError is still needed to pass -Werror + -- to CPP; see runCpp in SysTools + , make_dep_flag defFlag "Wnot" (NoArg (unSetWarningGroup W_everything)) + "Use -w or -Wno-everything instead" + , make_ord_flag defFlag "w" (NoArg (unSetWarningGroup W_everything)) + ] + + -- New-style uniform warning sets + -- + -- Note that -Weverything > -Wall > -Wextra > -Wdefault > -Wno-everything + ++ warningControls setWarningGroup unSetWarningGroup setWErrorWarningGroup unSetFatalWarningGroup warningGroupsDeps + ++ warningControls setWarningFlag unSetWarningFlag setWErrorFlag unSetFatalWarningFlag wWarningFlagsDeps + ++ warningControls setCustomWarningFlag unSetCustomWarningFlag setCustomWErrorFlag unSetCustomFatalWarningFlag + [(NotDeprecated, FlagSpec "warnings-deprecations" defaultWarningCategory nop AllModes)] + -- See Note [Warning categories] in GHC.Unit.Module.Warnings. + + ++ [ (NotDeprecated, customOrUnrecognisedWarning "Wno-" unSetCustomWarningFlag) + , (NotDeprecated, customOrUnrecognisedWarning "Werror=" setCustomWErrorFlag) + , (NotDeprecated, customOrUnrecognisedWarning "Wwarn=" unSetCustomFatalWarningFlag) + , (NotDeprecated, customOrUnrecognisedWarning "Wno-error=" unSetCustomFatalWarningFlag) + , (NotDeprecated, customOrUnrecognisedWarning "W" setCustomWarningFlag) + , (Deprecated, customOrUnrecognisedWarning "fwarn-" setCustomWarningFlag) + , (Deprecated, customOrUnrecognisedWarning "fno-warn-" unSetCustomWarningFlag) + ] + + ------ 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 ------------------------------------------------- + ++ map (mkFlag turnOn "f" setExtensionFlag ) fLangFlagsDeps + ++ map (mkFlag turnOff "fno-" unSetExtensionFlag) fLangFlagsDeps + ++ map (mkFlag turnOn "X" setExtensionFlag ) xFlagsDeps + ++ map (mkFlag turnOff "XNo" unSetExtensionFlag) xFlagsDeps + ++ map (mkFlag turnOn "X" setLanguage ) languageFlagsDeps + ++ map (mkFlag turnOn "X" setSafeHaskell ) safeHaskellFlagsDeps + +-- | Warnings have both new-style flags to control their state (@-W@, @-Wno-@, +-- @-Werror=@, @-Wwarn=@) and old-style flags (@-fwarn-@, @-fno-warn-@). We +-- define these uniformly for individual warning flags and groups of warnings. +warningControls :: (warn_flag -> DynP ()) -- ^ Set the warning + -> (warn_flag -> DynP ()) -- ^ Unset the warning + -> (warn_flag -> DynP ()) -- ^ Make the warning an error + -> (warn_flag -> DynP ()) -- ^ Clear the error status + -> [(Deprecation, FlagSpec warn_flag)] + -> [(Deprecation, Flag (CmdLineP DynFlags))] +warningControls set unset set_werror unset_fatal xs = + map (mkFlag turnOn "W" set ) xs + ++ map (mkFlag turnOff "Wno-" unset ) xs + ++ map (mkFlag turnOn "Werror=" set_werror ) xs + ++ map (mkFlag turnOn "Wwarn=" unset_fatal ) xs + ++ map (mkFlag turnOn "Wno-error=" unset_fatal ) xs + ++ map (mkFlag turnOn "fwarn-" set . hideFlag) xs + ++ map (mkFlag turnOff "fno-warn-" unset . hideFlag) xs + +-- | This is where we handle unrecognised warning flags. If the flag is valid as +-- an extended warning category, we call the supplied action. Otherwise, issue a +-- warning if -Wunrecognised-warning-flags is set. See #11429 for context. +-- See Note [Warning categories] in GHC.Unit.Module.Warnings. +customOrUnrecognisedWarning :: String -> (WarningCategory -> DynP ()) -> Flag (CmdLineP DynFlags) +customOrUnrecognisedWarning prefix custom = defHiddenFlag prefix (Prefix action) + where + action :: String -> DynP () + action flag + | validWarningCategory cat = custom cat + | otherwise = unrecognised flag + where + cat = mkWarningCategory (mkFastString flag) + + unrecognised flag = do + -- #23402 and #12056 + -- for unrecognised flags we consider current dynflags, not the final one. + -- But if final state says to not report unrecognised flags, they won't anyway. + f <- wopt Opt_WarnUnrecognisedWarningFlags <$> liftEwM getCmdLineState + when f $ addFlagWarn (DriverUnrecognisedFlag (prefix ++ flag)) + +-- See Note [Supporting CLI completion] +package_flags_deps :: [(Deprecation, Flag (CmdLineP DynFlags))] +package_flags_deps = [ + ------- Packages ---------------------------------------------------- + make_ord_flag defFlag "package-db" + (HasArg (addPkgDbRef . PkgDbPath)) + , make_ord_flag defFlag "clear-package-db" (NoArg clearPkgDb) + , make_ord_flag defFlag "no-global-package-db" (NoArg removeGlobalPkgDb) + , make_ord_flag defFlag "no-user-package-db" (NoArg removeUserPkgDb) + , make_ord_flag defFlag "global-package-db" + (NoArg (addPkgDbRef GlobalPkgDb)) + , make_ord_flag defFlag "user-package-db" + (NoArg (addPkgDbRef UserPkgDb)) + -- backwards compat with GHC<=7.4 : + , make_dep_flag defFlag "package-conf" + (HasArg $ addPkgDbRef . PkgDbPath) "Use -package-db instead" + , make_dep_flag defFlag "no-user-package-conf" + (NoArg removeUserPkgDb) "Use -no-user-package-db instead" + , make_ord_flag defGhcFlag "package-name" (HasArg $ \name -> + upd (setUnitId name)) + , make_ord_flag defGhcFlag "this-unit-id" (hasArg setUnitId) + + , make_ord_flag defGhcFlag "working-dir" (hasArg setWorkingDirectory) + , make_ord_flag defGhcFlag "this-package-name" (hasArg setPackageName) + , make_ord_flag defGhcFlag "hidden-module" (HasArg addHiddenModule) + , make_ord_flag defGhcFlag "reexported-module" (HasArg addReexportedModule) + + , make_ord_flag defFlag "package" (HasArg exposePackage) + , make_ord_flag defFlag "plugin-package-id" (HasArg exposePluginPackageId) + , make_ord_flag defFlag "plugin-package" (HasArg exposePluginPackage) + , make_ord_flag defFlag "package-id" (HasArg exposePackageId) + , make_ord_flag defFlag "hide-package" (HasArg hidePackage) + , make_ord_flag defFlag "hide-all-packages" + (NoArg (setGeneralFlag Opt_HideAllPackages)) + , make_ord_flag defFlag "hide-all-plugin-packages" + (NoArg (setGeneralFlag Opt_HideAllPluginPackages)) + , make_ord_flag defFlag "package-env" (HasArg setPackageEnv) + , make_ord_flag defFlag "ignore-package" (HasArg ignorePackage) + , make_dep_flag defFlag "syslib" (HasArg exposePackage) "Use -package instead" + , make_ord_flag defFlag "distrust-all-packages" + (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 } + +-- | Make a list of flags for shell completion. +-- Filter all available flags into two groups, for interactive GHC vs all other. +flagsForCompletion :: Bool -> [String] +flagsForCompletion isInteractive + = [ '-':flagName flag + | flag <- flagsAll + , modeFilter (flagGhcMode flag) + ] + where + modeFilter AllModes = True + modeFilter OnlyGhci = isInteractive + modeFilter OnlyGhc = not isInteractive + modeFilter HiddenFlag = False + +data FlagSpec flag + = FlagSpec + { flagSpecName :: String -- ^ Flag in string form + , flagSpecFlag :: flag -- ^ Flag in internal form + , flagSpecAction :: (TurnOnFlag -> DynP ()) + -- ^ Extra action to run when the flag is found + -- Typically, emit a warning or error + , flagSpecGhcMode :: GhcFlagMode + -- ^ In which ghc mode the flag has effect + } + +-- | Define a new flag. +flagSpec :: String -> flag -> (Deprecation, FlagSpec flag) +flagSpec name flag = flagSpec' name flag nop + +-- | Define a new flag with an effect. +flagSpec' :: String -> flag -> (TurnOnFlag -> DynP ()) + -> (Deprecation, FlagSpec flag) +flagSpec' name flag act = (NotDeprecated, FlagSpec name flag act AllModes) + +-- | Define a warning flag. +warnSpec :: WarningFlag -> [(Deprecation, FlagSpec WarningFlag)] +warnSpec flag = warnSpec' flag nop + +-- | Define a warning flag with an effect. +warnSpec' :: WarningFlag -> (TurnOnFlag -> DynP ()) + -> [(Deprecation, FlagSpec WarningFlag)] +warnSpec' flag act = [ (NotDeprecated, FlagSpec name flag act AllModes) + | name <- NE.toList (warnFlagNames flag) + ] + +-- | Define a new deprecated flag with an effect. +depFlagSpecOp :: String -> flag -> (TurnOnFlag -> DynP ()) -> String + -> (Deprecation, FlagSpec flag) +depFlagSpecOp name flag act dep = + (Deprecated, snd (flagSpec' name flag (\f -> act f >> deprecate dep))) + +-- | Define a new deprecated flag. +depFlagSpec :: String -> flag -> String + -> (Deprecation, FlagSpec flag) +depFlagSpec name flag dep = depFlagSpecOp name flag nop dep + +-- | Define a deprecated warning flag. +depWarnSpec :: WarningFlag -> String + -> [(Deprecation, FlagSpec WarningFlag)] +depWarnSpec flag dep = [ depFlagSpecOp name flag nop dep + | name <- NE.toList (warnFlagNames flag) + ] + +-- | Define a deprecated warning name substituted by another. +subWarnSpec :: String -> WarningFlag -> String + -> [(Deprecation, FlagSpec WarningFlag)] +subWarnSpec oldname flag dep = [ depFlagSpecOp oldname flag nop dep ] + + +-- | Define a new deprecated flag with an effect where the deprecation message +-- depends on the flag value +depFlagSpecOp' :: String + -> flag + -> (TurnOnFlag -> DynP ()) + -> (TurnOnFlag -> String) + -> (Deprecation, FlagSpec flag) +depFlagSpecOp' name flag act dep = + (Deprecated, FlagSpec name flag (\f -> act f >> (deprecate $ dep f)) + AllModes) + +-- | Define a new deprecated flag where the deprecation message +-- depends on the flag value +depFlagSpec' :: String + -> flag + -> (TurnOnFlag -> String) + -> (Deprecation, FlagSpec flag) +depFlagSpec' name flag dep = depFlagSpecOp' name flag nop dep + +-- | Define a new flag for GHCi. +flagGhciSpec :: String -> flag -> (Deprecation, FlagSpec flag) +flagGhciSpec name flag = flagGhciSpec' name flag nop + +-- | Define a new flag for GHCi with an effect. +flagGhciSpec' :: String -> flag -> (TurnOnFlag -> DynP ()) + -> (Deprecation, FlagSpec flag) +flagGhciSpec' name flag act = (NotDeprecated, FlagSpec name flag act OnlyGhci) + +-- | Define a new flag invisible to CLI completion. +flagHiddenSpec :: String -> flag -> (Deprecation, FlagSpec flag) +flagHiddenSpec name flag = flagHiddenSpec' name flag nop + +-- | Define a new flag invisible to CLI completion with an effect. +flagHiddenSpec' :: String -> flag -> (TurnOnFlag -> DynP ()) + -> (Deprecation, FlagSpec flag) +flagHiddenSpec' name flag act = (NotDeprecated, FlagSpec name flag act + HiddenFlag) + +-- | Hide a 'FlagSpec' from being displayed in @--show-options@. +-- +-- This is for example useful for flags that are obsolete, but should not +-- (yet) be deprecated for compatibility reasons. +hideFlag :: (Deprecation, FlagSpec a) -> (Deprecation, FlagSpec a) +hideFlag (dep, fs) = (dep, fs { flagSpecGhcMode = HiddenFlag }) + +mkFlag :: TurnOnFlag -- ^ True <=> it should be turned on + -> String -- ^ The flag prefix + -> (flag -> DynP ()) -- ^ What to do when the flag is found + -> (Deprecation, FlagSpec flag) -- ^ Specification of + -- this particular flag + -> (Deprecation, Flag (CmdLineP DynFlags)) +mkFlag turn_on flagPrefix f (dep, (FlagSpec name flag extra_action mode)) + = (dep, + Flag (flagPrefix ++ name) (NoArg (f flag >> extra_action turn_on)) mode) + +deprecate :: String -> DynP () +deprecate s = do + arg <- getArg + addFlagWarn (DriverDeprecatedFlag arg s) + +deprecatedForExtension :: String -> TurnOnFlag -> String +deprecatedForExtension lang turn_on + = "use -X" ++ flag ++ + " or pragma {-# LANGUAGE " ++ flag ++ " #-} instead" + where + flag | turn_on = lang + | otherwise = "No" ++ lang + +deprecatedForExtensions :: [String] -> TurnOnFlag -> String +deprecatedForExtensions [] _ = panic "new extension has not been specified" +deprecatedForExtensions [lang] turn_on = deprecatedForExtension lang turn_on +deprecatedForExtensions langExts turn_on + = "use " ++ xExt flags ++ " instead" + where + flags | turn_on = langExts + | otherwise = ("No" ++) <$> langExts + + xExt fls = intercalate " and " $ (\flag -> "-X" ++ flag) <$> fls + +useInstead :: String -> String -> TurnOnFlag -> String +useInstead prefix flag turn_on + = "Use " ++ prefix ++ no ++ flag ++ " instead" + where + no = if turn_on then "" else "no-" + +nop :: TurnOnFlag -> DynP () +nop _ = return () + +-- | Find the 'FlagSpec' for a 'WarningFlag'. +flagSpecOf :: WarningFlag -> Maybe (FlagSpec WarningFlag) +flagSpecOf = flip Map.lookup wWarningFlagMap + +wWarningFlagMap :: Map.Map WarningFlag (FlagSpec WarningFlag) +wWarningFlagMap = Map.fromListWith (\_ x -> x) $ map (flagSpecFlag &&& id) wWarningFlags + +-- | These @-W\@ flags can all be reversed with @-Wno-\@ +wWarningFlags :: [FlagSpec WarningFlag] +wWarningFlags = map snd (sortBy (comparing fst) wWarningFlagsDeps) + +wWarningFlagsDeps :: [(Deprecation, FlagSpec WarningFlag)] +wWarningFlagsDeps = [minBound..maxBound] >>= \x -> case x of +-- See Note [Updating flag description in the User's Guide] +-- See Note [Supporting CLI completion] + Opt_WarnAlternativeLayoutRuleTransitional -> warnSpec x + Opt_WarnAmbiguousFields -> warnSpec x + 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 + Opt_WarnDeprecatedFlags -> warnSpec x + Opt_WarnDerivingDefaults -> warnSpec x + Opt_WarnDerivingTypeable -> warnSpec x + Opt_WarnDodgyExports -> warnSpec x + Opt_WarnDodgyForeignImports -> warnSpec x + Opt_WarnDodgyImports -> warnSpec x + Opt_WarnEmptyEnumerations -> warnSpec x + Opt_WarnDuplicateConstraints + -> subWarnSpec "duplicate-constraints" x "it is subsumed by -Wredundant-constraints" + Opt_WarnRedundantConstraints -> warnSpec x + Opt_WarnDuplicateExports -> warnSpec x + Opt_WarnHiShadows + -> 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_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 -> 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" + ++ warnSpec x + Opt_WarnMissingMethods -> warnSpec x + Opt_WarnMissingMonadFailInstances + -> depWarnSpec x "fail is no longer a method of Monad" + Opt_WarnSemigroup -> depWarnSpec x "Semigroup is now a superclass of Monoid" + Opt_WarnMissingSignatures -> warnSpec x + Opt_WarnMissingKindSignatures -> warnSpec x + Opt_WarnMissingPolyKindSignatures -> warnSpec x + Opt_WarnMissingExportedSignatures + -> subWarnSpec "missing-exported-sigs" x + "it is replaced by -Wmissing-exported-signatures" + ++ warnSpec x + 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_WarnNonCanonicalMonoidInstances -> warnSpec x + Opt_WarnOrphans -> warnSpec x + Opt_WarnOverflowedLiterals -> warnSpec x + Opt_WarnOverlappingPatterns -> warnSpec x + Opt_WarnMissedSpecs -> warnSpec x + Opt_WarnAllMissedSpecs -> warnSpec x + Opt_WarnSafe -> warnSpec' x setWarnSafe + Opt_WarnTrustworthySafe -> warnSpec x + Opt_WarnInferredSafeImports -> warnSpec x + Opt_WarnMissingSafeHaskellMode -> warnSpec x + Opt_WarnTabs -> warnSpec x + Opt_WarnTypeDefaults -> warnSpec x + Opt_WarnTypedHoles -> warnSpec x + Opt_WarnPartialTypeSignatures -> warnSpec x + Opt_WarnUnrecognisedPragmas -> warnSpec x + Opt_WarnMisplacedPragmas -> warnSpec x + Opt_WarnUnsafe -> warnSpec' x setWarnUnsafe + Opt_WarnUnsupportedCallingConventions -> warnSpec x + Opt_WarnUnsupportedLlvmVersion -> warnSpec x + Opt_WarnMissedExtraSharedLib -> warnSpec x + Opt_WarnUntickedPromotedConstructors -> warnSpec x + Opt_WarnUnusedDoBind -> warnSpec x + Opt_WarnUnusedForalls -> warnSpec x + Opt_WarnUnusedImports -> warnSpec x + Opt_WarnUnusedLocalBinds -> warnSpec x + Opt_WarnUnusedMatches -> warnSpec x + Opt_WarnUnusedPatternBinds -> warnSpec x + Opt_WarnUnusedTopBinds -> warnSpec x + Opt_WarnUnusedTypePatterns -> warnSpec x + Opt_WarnUnusedRecordWildcards -> warnSpec x + Opt_WarnRedundantBangPatterns -> warnSpec x + Opt_WarnRedundantRecordWildcards -> warnSpec x + Opt_WarnRedundantStrictnessFlags -> warnSpec x + Opt_WarnWrongDoBind -> warnSpec x + Opt_WarnMissingPatternSynonymSignatures -> warnSpec x + Opt_WarnMissingDerivingStrategies -> warnSpec x + Opt_WarnSimplifiableClassConstraints -> warnSpec x + Opt_WarnMissingHomeModules -> warnSpec x + Opt_WarnUnrecognisedWarningFlags -> warnSpec x + Opt_WarnStarBinder -> warnSpec x + Opt_WarnStarIsType -> warnSpec x + Opt_WarnSpaceAfterBang + -> depWarnSpec x "bang patterns can no longer be written with a space" + Opt_WarnPartialFields -> warnSpec x + Opt_WarnPrepositiveQualifiedModule -> warnSpec x + Opt_WarnUnusedPackages -> 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 + -> depWarnSpec x "forall is no longer a valid identifier" + Opt_WarnUnicodeBidirectionalFormatCharacters -> warnSpec x + Opt_WarnGADTMonoLocalBinds -> warnSpec x + Opt_WarnTypeEqualityOutOfScope -> warnSpec x + Opt_WarnTypeEqualityRequiresOperators -> warnSpec x + Opt_WarnTermVariableCapture -> warnSpec x + 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 + where + mk g = (NotDeprecated, FlagSpec (warningGroupName g) g nop AllModes) + +-- | These @-\@ flags can all be reversed with @-no-\@ +negatableFlagsDeps :: [(Deprecation, FlagSpec GeneralFlag)] +negatableFlagsDeps = [ + flagGhciSpec "ignore-dot-ghci" Opt_IgnoreDotGhci ] + +-- | These @-d\@ flags can all be reversed with @-dno-\@ +dFlagsDeps :: [(Deprecation, FlagSpec GeneralFlag)] +dFlagsDeps = [ +-- See Note [Updating flag description in the User's Guide] +-- See Note [Supporting CLI completion] +-- Please keep the list of flags below sorted alphabetically + flagSpec "ppr-case-as-let" Opt_PprCaseAsLet, + depFlagSpec' "ppr-ticks" Opt_PprShowTicks + (\turn_on -> useInstead "-d" "suppress-ticks" (not turn_on)), + flagSpec "suppress-ticks" Opt_SuppressTicks, + depFlagSpec' "suppress-stg-free-vars" Opt_SuppressStgExts + (useInstead "-d" "suppress-stg-exts"), + flagSpec "suppress-stg-exts" Opt_SuppressStgExts, + flagSpec "suppress-stg-reps" Opt_SuppressStgReps, + flagSpec "suppress-coercions" Opt_SuppressCoercions, + flagSpec "suppress-coercion-types" Opt_SuppressCoercionTypes, + flagSpec "suppress-idinfo" Opt_SuppressIdInfo, + flagSpec "suppress-unfoldings" Opt_SuppressUnfoldings, + flagSpec "suppress-module-prefixes" Opt_SuppressModulePrefixes, + flagSpec "suppress-timestamps" Opt_SuppressTimestamps, + flagSpec "suppress-type-applications" Opt_SuppressTypeApplications, + flagSpec "suppress-type-signatures" Opt_SuppressTypeSignatures, + flagSpec "suppress-uniques" Opt_SuppressUniques, + flagSpec "suppress-var-kinds" Opt_SuppressVarKinds, + flagSpec "suppress-core-sizes" Opt_SuppressCoreSizes + ] + +-- | These @-f\@ flags can all be reversed with @-fno-\@ +fFlags :: [FlagSpec GeneralFlag] +fFlags = map snd fFlagsDeps + +fFlagsDeps :: [(Deprecation, FlagSpec GeneralFlag)] +fFlagsDeps = [ +-- See Note [Updating flag description in the User's Guide] +-- See Note [Supporting CLI completion] +-- Please keep the list of flags below sorted alphabetically + flagSpec "asm-shortcutting" Opt_AsmShortcutting, + flagGhciSpec "break-on-error" Opt_BreakOnError, + flagGhciSpec "break-on-exception" Opt_BreakOnException, + flagSpec "building-cabal-package" Opt_BuildingCabalPackage, + flagSpec "call-arity" Opt_CallArity, + flagSpec "exitification" Opt_Exitification, + flagSpec "case-merge" Opt_CaseMerge, + flagSpec "case-folding" Opt_CaseFolding, + flagSpec "cmm-elim-common-blocks" Opt_CmmElimCommonBlocks, + flagSpec "cmm-sink" Opt_CmmSink, + flagSpec "cmm-static-pred" Opt_CmmStaticPred, + flagSpec "cse" Opt_CSE, + flagSpec "stg-cse" Opt_StgCSE, + flagSpec "stg-lift-lams" Opt_StgLiftLams, + flagSpec "cpr-anal" Opt_CprAnal, + flagSpec "defer-diagnostics" Opt_DeferDiagnostics, + flagSpec "defer-type-errors" Opt_DeferTypeErrors, + 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, + flagSpec "dicts-cheap" Opt_DictsCheap, + flagSpec "dicts-strict" Opt_DictsStrict, + depFlagSpec "dmd-tx-dict-sel" + 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, + flagSpec "family-application-cache" Opt_FamAppCache, + flagSpec "float-in" Opt_FloatIn, + flagSpec "force-recomp" Opt_ForceRecomp, + flagSpec "ignore-optim-changes" Opt_IgnoreOptimChanges, + flagSpec "ignore-hpc-changes" Opt_IgnoreHpcChanges, + flagSpec "full-laziness" Opt_FullLaziness, + depFlagSpec' "fun-to-thunk" Opt_FunToThunk + (useInstead "-f" "full-laziness"), + flagSpec "local-float-out" Opt_LocalFloatOut, + flagSpec "local-float-out-top-level" Opt_LocalFloatOutTopLevel, + 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, + flagSpec "ignore-interface-pragmas" Opt_IgnoreInterfacePragmas, + flagGhciSpec "implicit-import-qualified" Opt_ImplicitImportQualified, + flagSpec "irrefutable-tuples" Opt_IrrefutableTuples, + flagSpec "keep-going" Opt_KeepGoing, + flagSpec "late-dmd-anal" Opt_LateDmdAnal, + flagSpec "late-specialise" Opt_LateSpecialise, + flagSpec "liberate-case" Opt_LiberateCase, + flagHiddenSpec "llvm-fill-undef-with-garbage" Opt_LlvmFillUndefWithGarbage, + flagSpec "loopification" Opt_Loopification, + flagSpec "block-layout-cfg" Opt_CfgBlocklayout, + flagSpec "block-layout-weightless" Opt_WeightlessBlocklayout, + flagSpec "omit-interface-pragmas" Opt_OmitInterfacePragmas, + flagSpec "omit-yields" Opt_OmitYields, + flagSpec "optimal-applicative-do" Opt_OptimalApplicativeDo, + flagSpec "pedantic-bottoms" Opt_PedanticBottoms, + flagSpec "pre-inlining" Opt_SimplPreInlining, + flagGhciSpec "print-bind-contents" Opt_PrintBindContents, + flagGhciSpec "print-bind-result" Opt_PrintBindResult, + flagGhciSpec "print-evld-with-show" Opt_PrintEvldWithShow, + flagSpec "print-explicit-foralls" Opt_PrintExplicitForalls, + flagSpec "print-explicit-kinds" Opt_PrintExplicitKinds, + flagSpec "print-explicit-coercions" Opt_PrintExplicitCoercions, + flagSpec "print-explicit-runtime-reps" Opt_PrintExplicitRuntimeReps, + flagSpec "print-equality-relations" Opt_PrintEqualityRelations, + flagSpec "print-axiom-incomps" Opt_PrintAxiomIncomps, + flagSpec "print-unicode-syntax" Opt_PrintUnicodeSyntax, + flagSpec "print-expanded-synonyms" Opt_PrintExpandedSynonyms, + flagSpec "print-potential-instances" Opt_PrintPotentialInstances, + flagSpec "print-redundant-promotion-ticks" Opt_PrintRedundantPromotionTicks, + flagSpec "print-typechecker-elaboration" Opt_PrintTypecheckerElaboration, + 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, + flagSpec "regs-iterative" Opt_RegsIterative, + depFlagSpec' "rewrite-rules" Opt_EnableRewriteRules + (useInstead "-f" "enable-rewrite-rules"), + flagSpec "shared-implib" Opt_SharedImplib, + flagSpec "spec-constr" Opt_SpecConstr, + flagSpec "spec-constr-keen" Opt_SpecConstrKeen, + flagSpec "specialise" Opt_Specialise, + flagSpec "specialize" Opt_Specialise, + flagSpec "specialise-aggressively" Opt_SpecialiseAggressively, + flagSpec "specialize-aggressively" Opt_SpecialiseAggressively, + flagSpec "cross-module-specialise" Opt_CrossModuleSpecialise, + flagSpec "cross-module-specialize" Opt_CrossModuleSpecialise, + flagSpec "polymorphic-specialisation" Opt_PolymorphicSpecialisation, + flagSpec "specialise-incoherents" Opt_SpecialiseIncoherents, + flagSpec "inline-generics" Opt_InlineGenerics, + flagSpec "inline-generics-aggressively" Opt_InlineGenericsAggressively, + flagSpec "static-argument-transformation" Opt_StaticArgumentTransformation, + flagSpec "strictness" Opt_Strictness, + 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, + flagSpec "unoptimized-core-for-interpreter" Opt_UnoptimizedCoreForInterpreter, + flagSpec "version-macros" Opt_VersionMacros, + flagSpec "worker-wrapper" Opt_WorkerWrapper, + flagSpec "worker-wrapper-cbv" Opt_WorkerWrapperUnlift, -- See Note [Worker/wrapper for strict arguments] + flagSpec "solve-constant-dicts" Opt_SolveConstantDicts, + 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, + flagSpec "show-loaded-modules" Opt_ShowLoadedModules, + flagSpec "whole-archive-hs-libs" Opt_WholeArchiveHsLibs, + flagSpec "keep-cafs" Opt_KeepCAFs, + 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) + (addWarn "-compact-unwind is only implemented by the darwin platform. Ignoring.") + return dflags)), + flagSpec "show-error-context" Opt_ShowErrorContext, + flagSpec "cmm-thread-sanitizer" Opt_CmmThreadSanitizer, + flagSpec "split-sections" Opt_SplitSections, + flagSpec "break-points" Opt_InsertBreakpoints, + flagSpec "distinct-constructor-tables" Opt_DistinctConstructorTables, + flagSpec "info-table-map" Opt_InfoTableMap, + flagSpec "info-table-map-with-stack" Opt_InfoTableMapWithStack, + flagSpec "info-table-map-with-fallback" Opt_InfoTableMapWithFallback + ] + ++ fHoleFlags + +-- | These @-f\@ flags have to do with the typed-hole error message or +-- the valid hole fits in that message. See Note [Valid hole fits include ...] +-- in the "GHC.Tc.Errors.Hole" module. These flags can all be reversed with +-- @-fno-\@ +fHoleFlags :: [(Deprecation, FlagSpec GeneralFlag)] +fHoleFlags = [ + flagSpec "show-hole-constraints" Opt_ShowHoleConstraints, + depFlagSpec' "show-valid-substitutions" Opt_ShowValidHoleFits + (useInstead "-f" "show-valid-hole-fits"), + flagSpec "show-valid-hole-fits" Opt_ShowValidHoleFits, + -- Sorting settings + flagSpec "sort-valid-hole-fits" Opt_SortValidHoleFits, + flagSpec "sort-by-size-hole-fits" Opt_SortBySizeHoleFits, + flagSpec "sort-by-subsumption-hole-fits" Opt_SortBySubsumHoleFits, + flagSpec "abstract-refinement-hole-fits" Opt_AbstractRefHoleFits, + -- Output format settings + flagSpec "show-hole-matches-of-hole-fits" Opt_ShowMatchesOfHoleFits, + flagSpec "show-provenance-of-hole-fits" Opt_ShowProvOfHoleFits, + flagSpec "show-type-of-hole-fits" Opt_ShowTypeOfHoleFits, + flagSpec "show-type-app-of-hole-fits" Opt_ShowTypeAppOfHoleFits, + flagSpec "show-type-app-vars-of-hole-fits" Opt_ShowTypeAppVarsOfHoleFits, + flagSpec "show-docs-of-hole-fits" Opt_ShowDocsOfHoleFits, + flagSpec "unclutter-valid-hole-fits" Opt_UnclutterValidHoleFits + ] + +-- | These @-f\@ flags can all be reversed with @-fno-\@ +fLangFlags :: [FlagSpec LangExt.Extension] +fLangFlags = map snd fLangFlagsDeps + +fLangFlagsDeps :: [(Deprecation, FlagSpec LangExt.Extension)] +fLangFlagsDeps = [ +-- See Note [Updating flag description in the User's Guide] +-- See Note [Supporting CLI completion] + depFlagSpecOp' "th" LangExt.TemplateHaskell + checkTemplateHaskellOk + (deprecatedForExtension "TemplateHaskell"), + depFlagSpec' "fi" LangExt.ForeignFunctionInterface + (deprecatedForExtension "ForeignFunctionInterface"), + depFlagSpec' "ffi" LangExt.ForeignFunctionInterface + (deprecatedForExtension "ForeignFunctionInterface"), + depFlagSpec' "arrows" LangExt.Arrows + (deprecatedForExtension "Arrows"), + depFlagSpec' "implicit-prelude" LangExt.ImplicitPrelude + (deprecatedForExtension "ImplicitPrelude"), + depFlagSpec' "bang-patterns" LangExt.BangPatterns + (deprecatedForExtension "BangPatterns"), + depFlagSpec' "monomorphism-restriction" LangExt.MonomorphismRestriction + (deprecatedForExtension "MonomorphismRestriction"), + depFlagSpec' "extended-default-rules" LangExt.ExtendedDefaultRules + (deprecatedForExtension "ExtendedDefaultRules"), + depFlagSpec' "implicit-params" LangExt.ImplicitParams + (deprecatedForExtension "ImplicitParams"), + depFlagSpec' "scoped-type-variables" LangExt.ScopedTypeVariables + (deprecatedForExtension "ScopedTypeVariables"), + depFlagSpec' "allow-overlapping-instances" LangExt.OverlappingInstances + (deprecatedForExtension "OverlappingInstances"), + depFlagSpec' "allow-undecidable-instances" LangExt.UndecidableInstances + (deprecatedForExtension "UndecidableInstances"), + depFlagSpec' "allow-incoherent-instances" LangExt.IncoherentInstances + (deprecatedForExtension "IncoherentInstances") + ] + +supportedLanguages :: [String] +supportedLanguages = map (flagSpecName . snd) languageFlagsDeps + +supportedLanguageOverlays :: [String] +supportedLanguageOverlays = map (flagSpecName . snd) safeHaskellFlagsDeps + +supportedExtensions :: ArchOS -> [String] +supportedExtensions (ArchOS arch os) = concatMap toFlagSpecNamePair xFlags + where + toFlagSpecNamePair flg + -- IMPORTANT! Make sure that `ghc --supported-extensions` omits + -- "TemplateHaskell"/"QuasiQuotes" when it's known not to work out of the + -- box. See also GHC #11102 and #16331 for more details about + -- the rationale + | isAIX, flagSpecFlag flg == LangExt.TemplateHaskell = [noName] + | isAIX, flagSpecFlag flg == LangExt.QuasiQuotes = [noName] + -- "JavaScriptFFI" is only supported on the JavaScript/Wasm backend + | notJSOrWasm, flagSpecFlag flg == LangExt.JavaScriptFFI = [noName] + | otherwise = [name, noName] + where + isAIX = os == OSAIX + notJSOrWasm = not $ arch `elem` [ ArchJavaScript, ArchWasm32 ] + noName = "No" ++ name + name = flagSpecName flg + +supportedLanguagesAndExtensions :: ArchOS -> [String] +supportedLanguagesAndExtensions arch_os = + supportedLanguages ++ supportedLanguageOverlays ++ supportedExtensions arch_os + +-- | These -X flags cannot be reversed with -XNo +languageFlagsDeps :: [(Deprecation, FlagSpec Language)] +languageFlagsDeps = [ + flagSpec "Haskell98" Haskell98, + flagSpec "Haskell2010" Haskell2010, + flagSpec "GHC2021" GHC2021, + flagSpec "GHC2024" GHC2024 + ] + +-- | These -X flags cannot be reversed with -XNo +-- They are used to place hard requirements on what GHC Haskell language +-- features can be used. +safeHaskellFlagsDeps :: [(Deprecation, FlagSpec SafeHaskellMode)] +safeHaskellFlagsDeps = [mkF Sf_Unsafe, mkF Sf_Trustworthy, mkF Sf_Safe] + where mkF flag = flagSpec (show flag) flag + +-- | These -X flags can all be reversed with -XNo +xFlags :: [FlagSpec LangExt.Extension] +xFlags = map snd xFlagsDeps + +makeExtensionFlags :: LangExt.Extension -> [(Deprecation, FlagSpec LangExt.Extension)] +makeExtensionFlags ext = [ makeExtensionFlag name depr ext | (depr, name) <- extensionNames ext ] + +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 () +enableDLint = do + mapM_ setGeneralFlag dLintFlags + addWayDynP WayDebug + where + dLintFlags :: [GeneralFlag] + dLintFlags = + [ Opt_DoCoreLinting + , Opt_DoStgLinting + , Opt_DoCmmLinting + , Opt_DoAsmLinting + , Opt_CatchNonexhaustiveCases + , Opt_LlvmFillUndefWithGarbage + ] + +enableGlasgowExts :: DynP () +enableGlasgowExts = do setGeneralFlag Opt_PrintExplicitForalls + mapM_ setExtensionFlag glasgowExtsFlags + +disableGlasgowExts :: DynP () +disableGlasgowExts = do unSetGeneralFlag Opt_PrintExplicitForalls + mapM_ unSetExtensionFlag glasgowExtsFlags + + +setWarnSafe :: Bool -> DynP () +setWarnSafe True = getCurLoc >>= \l -> upd (\d -> d { warnSafeOnLoc = l }) +setWarnSafe False = return () + +setWarnUnsafe :: Bool -> DynP () +setWarnUnsafe True = getCurLoc >>= \l -> upd (\d -> d { warnUnsafeOnLoc = l }) +setWarnUnsafe False = return () + +setPackageTrust :: DynP () +setPackageTrust = do + setGeneralFlag Opt_PackageTrust + l <- getCurLoc + upd $ \d -> d { pkgTrustOnLoc = l } + +setGenDeriving :: TurnOnFlag -> DynP () +setGenDeriving True = getCurLoc >>= \l -> upd (\d -> d { newDerivOnLoc = l }) +setGenDeriving False = return () + +setDeriveVia :: TurnOnFlag -> DynP () +setDeriveVia True = getCurLoc >>= \l -> upd (\d -> d { deriveViaOnLoc = l }) +setDeriveVia False = return () + +setOverlappingInsts :: TurnOnFlag -> DynP () +setOverlappingInsts False = return () +setOverlappingInsts True = do + l <- getCurLoc + upd (\d -> d { overlapInstLoc = l }) + +setIncoherentInsts :: TurnOnFlag -> DynP () +setIncoherentInsts False = return () +setIncoherentInsts True = do + l <- getCurLoc + upd (\d -> d { incoherentOnLoc = l }) + +checkTemplateHaskellOk :: TurnOnFlag -> DynP () +checkTemplateHaskellOk _turn_on + = getCurLoc >>= \l -> upd (\d -> d { thOnLoc = l }) + +{- ********************************************************************** +%* * + DynFlags constructors +%* * +%********************************************************************* -} + +type DynP = EwM (CmdLineP DynFlags) + +upd :: (DynFlags -> DynFlags) -> DynP () +upd f = liftEwM (do dflags <- getCmdLineState + putCmdLineState $! f dflags) + +updM :: (DynFlags -> DynP DynFlags) -> DynP () +updM f = do dflags <- liftEwM getCmdLineState + dflags' <- f dflags + liftEwM $ putCmdLineState $! dflags' + +--------------- Constructor functions for OptKind ----------------- +noArg :: (DynFlags -> DynFlags) -> OptKind (CmdLineP DynFlags) +noArg fn = NoArg (upd fn) + +noArgM :: (DynFlags -> DynP DynFlags) -> OptKind (CmdLineP DynFlags) +noArgM fn = NoArg (updM fn) + +hasArg :: (String -> DynFlags -> DynFlags) -> OptKind (CmdLineP DynFlags) +hasArg fn = HasArg (upd . fn) + +sepArg :: (String -> DynFlags -> DynFlags) -> OptKind (CmdLineP DynFlags) +sepArg fn = SepArg (upd . fn) + +intSuffix :: (Int -> DynFlags -> DynFlags) -> OptKind (CmdLineP DynFlags) +intSuffix fn = IntSuffix (\n -> upd (fn n)) + +intSuffixM :: (Int -> DynFlags -> DynP DynFlags) -> OptKind (CmdLineP DynFlags) +intSuffixM fn = IntSuffix (\n -> updM (fn n)) + +word64Suffix :: (Word64 -> DynFlags -> DynFlags) -> OptKind (CmdLineP DynFlags) +word64Suffix fn = Word64Suffix (\n -> upd (fn n)) + +floatSuffix :: (Float -> DynFlags -> DynFlags) -> OptKind (CmdLineP DynFlags) +floatSuffix fn = FloatSuffix (\n -> upd (fn n)) + +optIntSuffixM :: (Maybe Int -> DynFlags -> DynP DynFlags) + -> OptKind (CmdLineP DynFlags) +optIntSuffixM fn = OptIntSuffix (\mi -> updM (fn mi)) + +setDumpFlag :: DumpFlag -> OptKind (CmdLineP DynFlags) +setDumpFlag dump_flag = NoArg (setDumpFlag' dump_flag) + +-------------------------- +addWayDynP :: Way -> DynP () +addWayDynP = upd . addWay' + +addWay' :: Way -> DynFlags -> DynFlags +addWay' w dflags0 = + let platform = targetPlatform dflags0 + dflags1 = dflags0 { targetWays_ = addWay w (targetWays_ dflags0) } + dflags2 = foldr setGeneralFlag' dflags1 + (wayGeneralFlags platform w) + dflags3 = foldr unSetGeneralFlag' dflags2 + (wayUnsetGeneralFlags platform w) + in dflags3 + +removeWayDynP :: Way -> DynP () +removeWayDynP w = upd (\dfs -> dfs { targetWays_ = removeWay w (targetWays_ dfs) }) + +-------------------------- +setGeneralFlag, unSetGeneralFlag :: GeneralFlag -> DynP () +setGeneralFlag f = upd (setGeneralFlag' f) +unSetGeneralFlag f = upd (unSetGeneralFlag' f) + +setGeneralFlag' :: GeneralFlag -> DynFlags -> DynFlags +setGeneralFlag' f dflags = foldr ($) (gopt_set dflags f) deps + where + deps = [ if turn_on then setGeneralFlag' d + else unSetGeneralFlag' d + | (f', turn_on, d) <- impliedGFlags, f' == f ] + -- When you set f, set the ones it implies + -- NB: use setGeneralFlag recursively, in case the implied flags + -- implies further flags + +unSetGeneralFlag' :: GeneralFlag -> DynFlags -> DynFlags +unSetGeneralFlag' f dflags = foldr ($) (gopt_unset dflags f) deps + where + deps = [ if turn_on then setGeneralFlag' d + else unSetGeneralFlag' d + | (f', turn_on, d) <- impliedOffGFlags, f' == f ] + -- In general, when you un-set f, we don't un-set the things it implies. + -- There are however some exceptions, e.g., -fno-strictness implies + -- -fno-worker-wrapper. + -- + -- NB: use unSetGeneralFlag' recursively, in case the implied off flags + -- imply further flags. + +-------------------------- +setWarningGroup :: WarningGroup -> DynP () +setWarningGroup g = do + mapM_ setWarningFlag (warningGroupFlags g) + when (warningGroupIncludesExtendedWarnings g) $ upd wopt_set_all_custom + +unSetWarningGroup :: WarningGroup -> DynP () +unSetWarningGroup g = do + mapM_ unSetWarningFlag (warningGroupFlags g) + when (warningGroupIncludesExtendedWarnings g) $ upd wopt_unset_all_custom + +setWErrorWarningGroup :: WarningGroup -> DynP () +setWErrorWarningGroup g = + do { setWarningGroup g + ; setFatalWarningGroup g } + +setFatalWarningGroup :: WarningGroup -> DynP () +setFatalWarningGroup g = do + mapM_ setFatalWarningFlag (warningGroupFlags g) + when (warningGroupIncludesExtendedWarnings g) $ upd wopt_set_all_fatal_custom + +unSetFatalWarningGroup :: WarningGroup -> DynP () +unSetFatalWarningGroup g = do + mapM_ unSetFatalWarningFlag (warningGroupFlags g) + when (warningGroupIncludesExtendedWarnings g) $ upd wopt_unset_all_fatal_custom + + +setWarningFlag, unSetWarningFlag :: WarningFlag -> DynP () +setWarningFlag f = upd (\dfs -> wopt_set dfs f) +unSetWarningFlag f = upd (\dfs -> wopt_unset dfs f) + +setFatalWarningFlag, unSetFatalWarningFlag :: WarningFlag -> DynP () +setFatalWarningFlag f = upd (\dfs -> wopt_set_fatal dfs f) +unSetFatalWarningFlag f = upd (\dfs -> wopt_unset_fatal dfs f) + +setWErrorFlag :: WarningFlag -> DynP () +setWErrorFlag flag = + do { setWarningFlag flag + ; setFatalWarningFlag flag } + + +setCustomWarningFlag, unSetCustomWarningFlag :: WarningCategory -> DynP () +setCustomWarningFlag f = upd (\dfs -> wopt_set_custom dfs f) +unSetCustomWarningFlag f = upd (\dfs -> wopt_unset_custom dfs f) + +setCustomFatalWarningFlag, unSetCustomFatalWarningFlag :: WarningCategory -> DynP () +setCustomFatalWarningFlag f = upd (\dfs -> wopt_set_fatal_custom dfs f) +unSetCustomFatalWarningFlag f = upd (\dfs -> wopt_unset_fatal_custom dfs f) + +setCustomWErrorFlag :: WarningCategory -> DynP () +setCustomWErrorFlag flag = + do { setCustomWarningFlag flag + ; setCustomFatalWarningFlag flag } + + +-------------------------- +setExtensionFlag, unSetExtensionFlag :: LangExt.Extension -> DynP () +setExtensionFlag f = upd (setExtensionFlag' f) +unSetExtensionFlag f = upd (unSetExtensionFlag' f) + +setExtensionFlag', unSetExtensionFlag' :: LangExt.Extension -> DynFlags -> DynFlags +setExtensionFlag' f dflags = foldr ($) (xopt_set dflags f) deps + where + 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) + +-------------------------- + +alterToolSettings :: (ToolSettings -> ToolSettings) -> DynFlags -> DynFlags +alterToolSettings f dynFlags = dynFlags { toolSettings = f (toolSettings dynFlags) } + +-------------------------- +setDumpFlag' :: DumpFlag -> DynP () +setDumpFlag' dump_flag + = do upd (\dfs -> dopt_set dfs dump_flag) + when want_recomp forceRecompile + where -- Certain dumpy-things are really interested in what's going + -- on during recompilation checking, so in those cases we + -- don't want to turn it off. + want_recomp = dump_flag `notElem` [Opt_D_dump_if_trace, + Opt_D_dump_hi_diffs, + Opt_D_no_debug_output] + +forceRecompile :: DynP () +-- Whenever we -ddump, force recompilation (by switching off the +-- recompilation checker), else you don't see the dump! However, +-- don't switch it off in --make mode, else *everything* gets +-- recompiled which probably isn't what you want +forceRecompile = do dfs <- liftEwM getCmdLineState + when (force_recomp dfs) (setGeneralFlag Opt_ForceRecomp) + where + force_recomp dfs = isOneShot (ghcMode dfs) + + +setVerbosity :: Maybe Int -> DynP () +setVerbosity mb_n = upd (\dfs -> dfs{ verbosity = mb_n `orElse` 3 }) + +setDebugLevel :: Maybe Int -> DynP () +setDebugLevel mb_n = + upd (\dfs -> exposeSyms $ dfs{ debugLevel = n }) + where + n = mb_n `orElse` 2 + exposeSyms + | n > 2 = setGeneralFlag' Opt_ExposeInternalSymbols + | otherwise = id + +addPkgDbRef :: PkgDbRef -> DynP () +addPkgDbRef p = upd $ \s -> + s { packageDBFlags = PackageDB p : packageDBFlags s } + +removeUserPkgDb :: DynP () +removeUserPkgDb = upd $ \s -> + s { packageDBFlags = NoUserPackageDB : packageDBFlags s } + +removeGlobalPkgDb :: DynP () +removeGlobalPkgDb = upd $ \s -> + s { packageDBFlags = NoGlobalPackageDB : packageDBFlags s } + +clearPkgDb :: DynP () +clearPkgDb = upd $ \s -> + s { packageDBFlags = ClearPackageDBs : packageDBFlags s } + +parsePackageFlag :: String -- the flag + -> ReadP PackageArg -- type of argument + -> String -- string to parse + -> PackageFlag +parsePackageFlag flag arg_parse str + = case filter ((=="").snd) (readP_to_S parse str) of + [(r, "")] -> r + _ -> throwGhcException $ CmdLineError ("Can't parse package flag: " ++ str) + where doc = flag ++ " " ++ str + parse = do + pkg_arg <- tok arg_parse + let mk_expose = ExposePackage doc pkg_arg + ( do _ <- tok $ string "with" + fmap (mk_expose . ModRenaming True) parseRns + <++ fmap (mk_expose . ModRenaming False) parseRns + <++ return (mk_expose (ModRenaming True []))) + parseRns = do _ <- tok $ R.char '(' + rns <- tok $ sepBy parseItem (tok $ R.char ',') + _ <- tok $ R.char ')' + return rns + parseItem = do + orig <- tok $ parseModuleName + (do _ <- tok $ string "as" + new <- tok $ parseModuleName + return (orig, new) + +++ + return (orig, orig)) + tok m = m >>= \x -> skipSpaces >> return x + +exposePackage, exposePackageId, hidePackage, + exposePluginPackage, exposePluginPackageId, + ignorePackage, + trustPackage, distrustPackage :: String -> DynP () +exposePackage p = upd (exposePackage' p) +exposePackageId p = + upd (\s -> s{ packageFlags = + parsePackageFlag "-package-id" parseUnitArg p : packageFlags s }) +exposePluginPackage p = + upd (\s -> s{ pluginPackageFlags = + parsePackageFlag "-plugin-package" parsePackageArg p : pluginPackageFlags s }) +exposePluginPackageId p = + upd (\s -> s{ pluginPackageFlags = + parsePackageFlag "-plugin-package-id" parseUnitArg p : pluginPackageFlags s }) +hidePackage p = + upd (\s -> s{ packageFlags = HidePackage p : packageFlags s }) +ignorePackage p = + upd (\s -> s{ ignorePackageFlags = IgnorePackage p : ignorePackageFlags s }) + +trustPackage p = exposePackage p >> -- both trust and distrust also expose a package + upd (\s -> s{ trustFlags = TrustPackage p : trustFlags s }) +distrustPackage p = exposePackage p >> + upd (\s -> s{ trustFlags = DistrustPackage p : trustFlags s }) + +exposePackage' :: String -> DynFlags -> DynFlags +exposePackage' p dflags + = dflags { packageFlags = + parsePackageFlag "-package" parsePackageArg p : packageFlags dflags } + +parsePackageArg :: ReadP PackageArg +parsePackageArg = + fmap PackageArg (munch1 (\c -> isAlphaNum c || c `elem` ":-_.")) + +parseUnitArg :: ReadP PackageArg +parseUnitArg = + fmap UnitIdArg parseUnit + +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 } + +{- +Note [Filepaths and Multiple Home Units] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +It is common to assume that a package is compiled in the directory where its +cabal file resides. Thus, all paths used in the compiler are assumed to be relative +to this directory. When there are multiple home units the compiler is often +not operating in the standard directory and instead where the cabal.project +file is located. In this case the `-working-dir` option can be passed which specifies +the path from the current directory to the directory the unit assumes to be it's root, +normally the directory which contains the cabal file. + +When the flag is passed, any relative paths used by the compiler are offset +by the working directory. Notably this includes `-i`, `-I⟨dir⟩`, `-hidir`, `-odir` etc and +the location of input files. + +-} + +augmentByWorkingDirectory :: DynFlags -> FilePath -> FilePath +augmentByWorkingDirectory dflags fp | isRelative fp, Just offset <- workingDirectory dflags = offset fp +augmentByWorkingDirectory _ fp = fp + +setPackageName :: String -> DynFlags -> DynFlags +setPackageName p d = d { thisPackageName = Just p } + +addHiddenModule :: String -> DynP () +addHiddenModule p = + upd (\s -> s{ hiddenModules = Set.insert (mkModuleName p) (hiddenModules s) }) + +addReexportedModule :: String -> DynP () +addReexportedModule p = + 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 () +setBackend l = upd $ \ dfs -> + if ghcLink dfs /= LinkBinary || backendWritesFiles l + then dfs{ backend = l } + else dfs + +-- Changes the target only if we're compiling object code. This is +-- used by -fasm and -fllvm, which switch from one to the other, but +-- not from bytecode to object-code. The idea is that -fasm/-fllvm +-- can be safely used in an OPTIONS_GHC pragma. +setObjBackend :: Backend -> DynP () +setObjBackend l = updM set + where + set dflags + | backendWritesFiles (backend dflags) + = return $ dflags { backend = l } + | otherwise = return dflags + +setOptLevel :: Int -> DynFlags -> DynP DynFlags +setOptLevel n dflags = return (updOptLevel n dflags) + +setCallerCcFilters :: String -> DynP () +setCallerCcFilters arg = + case parseCallerCcFilter arg of + Right filt -> upd $ \d -> d { callerCcFilters = filt : callerCcFilters d } + Left err -> addErr err + +setMainIs :: String -> DynP () +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 + + -- dummy parser state. + p_state str = initParserState + (mkParserOpts mempty emptyDiagOpts False False False True) + (stringToStringBuffer str) + (mkRealSrcLoc (mkFastString []) 1 1) + + 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]} + +-- ----------------------------------------------------------------------------- +-- Load dynflags from environment files. + +setFlagsFromEnvFile :: FilePath -> String -> DynP () +setFlagsFromEnvFile envfile content = do + setGeneralFlag Opt_HideAllPackages + parseEnvFile envfile content + +parseEnvFile :: FilePath -> String -> DynP () +parseEnvFile envfile = mapM_ parseEntry . lines + where + parseEntry str = case words str of + ("package-db": _) -> addPkgDbRef (PkgDbPath (envdir db)) + -- relative package dbs are interpreted relative to the env file + where envdir = takeDirectory envfile + db = drop 11 str + ["clear-package-db"] -> clearPkgDb + ["hide-package", pkg] -> hidePackage pkg + ["global-package-db"] -> addPkgDbRef GlobalPkgDb + ["user-package-db"] -> addPkgDbRef UserPkgDb + ["package-id", pkgid] -> exposePackageId pkgid + (('-':'-':_):_) -> return () -- comments + -- and the original syntax introduced in 7.10: + [pkgid] -> exposePackageId pkgid + [] -> return () + _ -> throwGhcException $ CmdLineError $ + "Can't parse environment file entry: " + ++ envfile ++ ": " ++ str + + +----------------------------------------------------------------------------- +-- Paths & Libraries + +addImportPath, addLibraryPath, addIncludePath, addFrameworkPath :: FilePath -> DynP () + +-- -i on its own deletes the import paths +addImportPath "" = upd (\s -> s{importPaths = []}) +addImportPath p = upd (\s -> s{importPaths = importPaths s ++ splitPathList p}) + +addLibraryPath p = + upd (\s -> s{libraryPaths = libraryPaths s ++ splitPathList p}) + +addIncludePath p = + upd (\s -> s{includePaths = + addGlobalInclude (includePaths s) (splitPathList p)}) + +addFrameworkPath p = + upd (\s -> s{frameworkPaths = frameworkPaths s ++ splitPathList p}) + +#if !defined(mingw32_HOST_OS) +split_marker :: Char +split_marker = ':' -- not configurable (ToDo) +#endif + +splitPathList :: String -> [String] +splitPathList s = filter notNull (splitUp s) + -- empty paths are ignored: there might be a trailing + -- ':' in the initial list, for example. Empty paths can + -- cause confusion when they are translated into -I options + -- for passing to gcc. + where +#if !defined(mingw32_HOST_OS) + splitUp xs = split split_marker xs +#else + -- Windows: 'hybrid' support for DOS-style paths in directory lists. + -- + -- That is, if "foo:bar:baz" is used, this interpreted as + -- consisting of three entries, 'foo', 'bar', 'baz'. + -- However, with "c:/foo:c:\\foo;x:/bar", this is interpreted + -- as 3 elts, "c:/foo", "c:\\foo", "x:/bar" + -- + -- Notice that no attempt is made to fully replace the 'standard' + -- split marker ':' with the Windows / DOS one, ';'. The reason being + -- that this will cause too much breakage for users & ':' will + -- work fine even with DOS paths, if you're not insisting on being silly. + -- So, use either. + splitUp [] = [] + splitUp (x:':':div:xs) | div `elem` dir_markers + = ((x:':':div:p): splitUp rs) + where + (p,rs) = findNextPath xs + -- we used to check for existence of the path here, but that + -- required the IO monad to be threaded through the command-line + -- parser which is quite inconvenient. The + splitUp xs = cons p (splitUp rs) + where + (p,rs) = findNextPath xs + + cons "" xs = xs + cons x xs = x:xs + + -- will be called either when we've consumed nought or the + -- ":/" part of a DOS path, so splitting is just a Q of + -- finding the next split marker. + findNextPath xs = + case break (`elem` split_markers) xs of + (p, _:ds) -> (p, ds) + (p, xs) -> (p, xs) + + split_markers :: [Char] + split_markers = [':', ';'] + + dir_markers :: [Char] + dir_markers = ['/', '\\'] +#endif + +-- ----------------------------------------------------------------------------- +-- tmpDir, where we store temporary files. + +setTmpDir :: FilePath -> DynFlags -> DynFlags +setTmpDir dir d = d { tmpDir = TempDir (normalise dir) } + -- we used to fix /cygdrive/c/.. on Windows, but this doesn't + -- seem necessary now --SDM 7/2/2008 + +----------------------------------------------------------------------------- +-- RTS opts + +setRtsOpts :: String -> DynP () +setRtsOpts arg = upd $ \ d -> d {rtsOpts = Just arg} + +setRtsOptsEnabled :: RtsOptsEnabled -> DynP () +setRtsOptsEnabled arg = upd $ \ d -> d {rtsOptsEnabled = arg} + +----------------------------------------------------------------------------- +-- Hpc stuff + +setOptHpcDir :: String -> DynP () +setOptHpcDir arg = upd $ \ d -> d {hpcDir = arg} + +----------------------------------------------------------------------------- +-- Via-C compilation stuff + +-- There are some options that we need to pass to gcc when compiling +-- Haskell code via C, but are only supported by recent versions of +-- gcc. The configure script decides which of these options we need, +-- and puts them in the "settings" file in $topdir. The advantage of +-- having these in a separate file is that the file can be created at +-- install-time depending on the available gcc version, and even +-- re-generated later if gcc is upgraded. +-- +-- The options below are not dependent on the version of gcc, only the +-- platform. + +picCCOpts :: DynFlags -> [String] +picCCOpts dflags = + case platformOS (targetPlatform dflags) of + OSDarwin + -- Apple prefers to do things the other way round. + -- PIC is on by default. + -- -mdynamic-no-pic: + -- Turn off PIC code generation. + -- -fno-common: + -- Don't generate "common" symbols - these are unwanted + -- in dynamic libraries. + + | gopt Opt_PIC dflags -> ["-fno-common", "-U__PIC__", "-D__PIC__"] + | otherwise -> ["-mdynamic-no-pic"] + OSMinGW32 -- no -fPIC for Windows + | gopt Opt_PIC dflags -> ["-U__PIC__", "-D__PIC__"] + | otherwise -> [] + _ + -- we need -fPIC for C files when we are compiling with -dynamic, + -- otherwise things like stub.c files don't get compiled + -- correctly. They need to reference data in the Haskell + -- 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__"] ++ + -- 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"] + +pieCCLDOpts :: DynFlags -> [String] +pieCCLDOpts dflags + | gopt Opt_PICExecutable dflags = ["-pie"] + -- See Note [No PIE when linking] + | toolSettings_ccSupportsNoPie (toolSettings dflags) = ["-no-pie"] + | otherwise = [] + + +{- +Note [No PIE when linking] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +As of 2016 some Linux distributions (e.g. Debian) have started enabling -pie by +default in their gcc builds. This is incompatible with -r as it implies that we +are producing an executable. Consequently, we must manually pass -no-pie to gcc +when joining object files or linking dynamic libraries. Unless, of course, the +user has explicitly requested a PIE executable with -pie. See #12759. +-} + +picPOpts :: DynFlags -> [String] +picPOpts dflags + | gopt Opt_PIC dflags = ["-U__PIC__", "-D__PIC__"] + | otherwise = [] + +-- ----------------------------------------------------------------------------- +-- Compiler Info + +compilerInfo :: DynFlags -> [(String, String)] +compilerInfo dflags + = -- We always make "Project name" be first to keep parsing in + -- other languages simple, i.e. when looking for other fields, + -- you don't have to worry whether there is a leading '[' or not + ("Project name", cProjectName) + -- Next come the settings, so anything else can be overridden + -- in the settings file (as "lookup" uses the first match for the + -- key) + : map (fmap $ expandDirectories (topDir dflags) (toolDir dflags)) + (rawSettings dflags) + ++ [("Project version", projectVersion dflags), + ("Project Git commit id", cProjectGitCommitId), + ("Project Version Int", cProjectVersionInt), + ("Project Patch Level", cProjectPatchLevel), + ("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), + ("target has RTS linker", showBool $ platformHasRTSLinker platform), + ("Target default backend", show $ platformDefaultBackend platform), + -- Whether or not we support @-dynamic-too@ + ("Support dynamic-too", showBool $ not isWindows), + -- Whether or not we support the @-j@ flag with @--make@. + ("Support parallel --make", "YES"), + -- Whether or not we support "Foo from foo-0.1-XXX:Foo" syntax in + -- installed package info. + ("Support reexported-modules", "YES"), + -- Whether or not we support extended @-package foo (Foo)@ syntax. + ("Support thinning and renaming package flags", "YES"), + -- Whether or not we support Backpack. + ("Support Backpack", "YES"), + -- If true, we require that the 'id' field in installed package info + -- match what is passed to the @-this-unit-id@ flag for modules + -- built in it + ("Requires unified installed package IDs", "YES"), + -- Whether or not we support the @-this-package-key@ flag. Prefer + -- "Uses unit IDs" over it. We still say yes even if @-this-package-key@ + -- flag has been removed, otherwise it breaks Cabal... + ("Uses package keys", "YES"), + -- Whether or not we support the @-this-unit-id@ flag + ("Uses unit IDs", "YES"), + -- Whether or not GHC was compiled using -dynamic + ("GHC Dynamic", showBool hostIsDynamic), + -- Whether or not GHC was compiled using -prof + ("GHC Profiled", showBool hostIsProfiled), + ("Debug on", showBool debugIsOn), + ("LibDir", topDir dflags), + -- This is always an absolute path, unlike "Relative Global Package DB" which is + -- in the settings file. + ("Global Package DB", globalPackageDatabasePath dflags) + ] + where + showBool True = "YES" + showBool False = "NO" + platform = targetPlatform dflags + isWindows = platformOS platform == OSMinGW32 + useInplaceMinGW = toolSettings_useInplaceMinGW $ toolSettings dflags + 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] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +There are a number of number of DynFlags configurations which either +do not make sense or lead to unimplemented or buggy codepaths in the +compiler. makeDynFlagsConsistent is responsible for verifying the validity +of a set of DynFlags, fixing any issues, and reporting them back to the +caller. + +GHCi and -O +--------------- + +When using optimization, the compiler can introduce several things +(such as unboxed tuples) into the intermediate code, which GHCi later +chokes on since the bytecode interpreter can't handle this (and while +this is arguably a bug these aren't handled, there are no plans to fix +it.) + +While the driver pipeline always checks for this particular erroneous +combination when parsing flags, we also need to check when we update +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, 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! +makeDynFlagsConsistent dflags + -- Disable -dynamic-too on Windows (#8228, #7134, #5987) + | os == OSMinGW32 && gopt Opt_BuildDynamicToo dflags + = let dflags' = gopt_unset dflags Opt_BuildDynamicToo + warn = "-dynamic-too is not supported on Windows" + in loop dflags' warn + -- Disable -dynamic-too if we are are compiling with -dynamic already, otherwise + -- you get two dynamic object files (.o and .dyn_o). (#20436) + | ways dflags `hasWay` WayDyn && gopt Opt_BuildDynamicToo dflags + = let dflags' = gopt_unset dflags Opt_BuildDynamicToo + warn = "-dynamic-too is ignored when using -dynamic" + in loop dflags' warn + + | gopt Opt_SplitSections dflags + , platformHasSubsectionsViaSymbols (targetPlatform dflags) + = let dflags' = gopt_unset dflags Opt_SplitSections + warn = "-fsplit-sections is not useful on this platform " ++ + "since it uses subsections-via-symbols. Ignoring." + in loop dflags' warn + + -- Via-C backend only supports unregisterised ABI. Switch to a backend + -- supporting it if possible. + | backendUnregisterisedAbiOnly (backend dflags) && + not (platformUnregisterised (targetPlatform dflags)) + = let b = platformDefaultBackend (targetPlatform dflags) + in if backendSwappableWithViaC b then + let dflags' = dflags { backend = b } + warn = "Target platform doesn't use unregisterised ABI, so using " ++ + backendDescription b ++ " rather than " ++ + backendDescription (backend dflags) + in loop dflags' warn + else + pgmError (backendDescription (backend dflags) ++ + " supports only unregisterised ABI but target platform doesn't use it.") + + | gopt Opt_Hpc dflags && not (backendSupportsHpc (backend dflags)) + = let dflags' = gopt_unset dflags Opt_Hpc + warn = "Hpc can't be used with " ++ backendDescription (backend dflags) ++ + ". Ignoring -fhpc." + in loop dflags' warn + + | backendSwappableWithViaC (backend dflags) && + platformUnregisterised (targetPlatform dflags) + = loop (dflags { backend = viaCBackend }) + "Target platform uses unregisterised ABI, so compiling via C" + + | backendNeedsPlatformNcgSupport (backend dflags) && + not (platformNcgSupported $ targetPlatform dflags) + = let dflags' = dflags { backend = llvmBackend } + warn = "Native code generator doesn't support target platform, so using LLVM" + in loop dflags' warn + + | not (osElfTarget os) && gopt Opt_PIE dflags + = loop (gopt_unset dflags Opt_PIE) + "Position-independent only supported on ELF platforms" + | os == OSDarwin && + arch == ArchX86_64 && + not (gopt Opt_PIC dflags) + = loop (gopt_set dflags Opt_PIC) + "Enabling -fPIC as it is always on for this platform" + + | backendForcesOptimization0 (backend dflags) + , gopt Opt_UnoptimizedCoreForInterpreter dflags + , let (dflags', changed) = updOptLevelChanged 0 dflags + , changed + = loop dflags' $ + "Ignoring optimization flags since they are experimental for the " ++ + backendDescription (backend dflags) ++ + ". Pass -fno-unoptimized-core-for-interpreter to enable this feature." + + | LinkInMemory <- ghcLink dflags + , not (gopt Opt_ExternalInterpreter dflags) + , hostIsProfiled + , backendWritesFiles (backend dflags) + , ways dflags `hasNotWay` WayProf + = 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" + + | 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, 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 + + +setUnsafeGlobalDynFlags :: DynFlags -> IO () +setUnsafeGlobalDynFlags dflags = do + writeIORef v_unsafeHasPprDebug (hasPprDebug dflags) + writeIORef v_unsafeHasNoDebugOutput (hasNoDebugOutput dflags) + writeIORef v_unsafeHasNoStateHack (hasNoStateHack dflags) + + +-- ----------------------------------------------------------------------------- + +-- | Indicate if cost-centre profiling is enabled +sccProfilingEnabled :: DynFlags -> Bool +sccProfilingEnabled dflags = profileIsProfiling (targetProfile dflags) + +-- | Indicate whether we need to generate source notes +needSourceNotes :: DynFlags -> Bool +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 + +{- +Note [-fno-use-rpaths] +~~~~~~~~~~~~~~~~~~~~~~ + +First read, Note [Dynamic linking on macOS] to understand why on darwin we never +use `-XLinker -rpath`. + +The specification of `Opt_RPath` is as follows: + +The default case `-fuse-rpaths`: +* On darwin, never use `-Xlinker -rpath -Xlinker`, always inject the rpath + afterwards, see `runInjectRPaths`. There is no way to use `-Xlinker` on darwin + as things stand but it wasn't documented in the user guide before this patch how + `-fuse-rpaths` should behave and the fact it was always disabled on darwin. +* Otherwise, use `-Xlinker -rpath -Xlinker` to set the rpath of the executable, + this is the normal way you should set the rpath. + +The case of `-fno-use-rpaths` +* Never inject anything into the rpath. + +When this was first implemented, `Opt_RPath` was disabled on darwin, but +the rpath was still always augmented by `runInjectRPaths`, and there was no way to +stop this. This was problematic because you couldn't build an executable in CI +with a clean rpath. + +-} + +-- ----------------------------------------------------------------------------- +-- RTS hooks + +-- Convert sizes like "3.5M" into integers +decodeSize :: String -> Integer +decodeSize str + | c == "" = truncate n + | c == "K" || c == "k" = truncate (n * 1000) + | c == "M" || c == "m" = truncate (n * 1000 * 1000) + | c == "G" || c == "g" = truncate (n * 1000 * 1000 * 1000) + | otherwise = throwGhcException (CmdLineError ("can't decode size: " ++ str)) + where (m, c) = span pred str + n = readRational m + pred c = isDigit c || c == '.' + +foreign import ccall unsafe "setHeapSize" setHeapSize :: Int -> IO () +foreign import ccall unsafe "enableTimingStats" enableTimingStats :: IO () + +outputFile :: DynFlags -> Maybe String +outputFile dflags + | dynamicNow dflags = dynOutputFile_ dflags + | otherwise = outputFile_ dflags + +objectSuf :: DynFlags -> String +objectSuf dflags + | dynamicNow dflags = dynObjectSuf_ dflags + | otherwise = objectSuf_ dflags -- | Pretty-print the difference between 2 DynFlags. -- 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,15 +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 :: AnnList + 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,5 +1,7 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} -- used to pass the phase to ppr_mult_ann since MultAnn is a type family {-# LANGUAGE CPP #-} {-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} @@ -24,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 @@ -45,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) @@ -70,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 @@ -84,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) @@ -113,26 +116,52 @@ -- 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 , ( [CoreTickish] -- Ticks to put on the rhs, if any , [[CoreTickish]] ) ) -- and ticks to put on the bound variables. -type instance XVarBind (GhcPass pL) (GhcPass pR) = NoExtField +type instance XVarBind (GhcPass pL) (GhcPass pR) = XVarBindGhc pL pR +type family XVarBindGhc pL pR where + XVarBindGhc 'Typechecked 'Typechecked = NoExtField + XVarBindGhc _ _ = DataConCantHappen + type instance XPatSynBind (GhcPass pL) (GhcPass pR) = NoExtField type instance XXHsBindsLR GhcPs pR = DataConCantHappen 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. @@ -427,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" @@ -437,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, @@ -455,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 @@ -483,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)) @@ -511,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, @@ -540,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 @@ -586,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 @@ -601,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 @@ -618,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 - {- ************************************************************************ * * @@ -645,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 @@ -670,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 @@ -697,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 [] @@ -745,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 -> text src + 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) @@ -773,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 @@ -792,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 @@ -818,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 @@ -828,7 +970,7 @@ -- | Using SourceText in case the pragma was spelled differently or used mixed -- case pragSrcBrackets :: SourceText -> String -> SDoc -> SDoc -pragSrcBrackets (SourceText src) _ doc = text src <+> doc <+> text "#-}" +pragSrcBrackets (SourceText src) _ doc = ftext src <+> doc <+> text "#-}" pragSrcBrackets NoSourceText alt doc = text alt <+> doc <+> text "#-}" pprVarSig :: (OutputableBndr id) => [id] -> SDoc -> SDoc @@ -849,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) + {- ************************************************************************ * * @@ -865,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 @@ -124,12 +134,12 @@ import GHC.Types.SrcLoc import GHC.Types.SourceText import GHC.Core.Type -import GHC.Core.TyCon (TyConFlavour(NewtypeFlavour,DataTypeFlavour)) import GHC.Types.ForeignCall +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 = [] @@ -703,7 +840,7 @@ | isTypeDataDefnCons condecls = text "type" | otherwise = empty pp_ct = case mb_ct of - Nothing -> empty + Nothing -> empty Just ct -> ppr ct pp_sig = case mb_sig of Nothing -> empty @@ -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 @@ -911,9 +1085,10 @@ Just (L _ (Overlapping s)) -> maybe_stext s "{-# OVERLAPPING #-}" Just (L _ (Overlaps s)) -> maybe_stext s "{-# OVERLAPS #-}" Just (L _ (Incoherent s)) -> maybe_stext s "{-# INCOHERENT #-}" + Just (L _ (NonCanonical s)) -> maybe_stext s "{-# INCOHERENT #-}" -- No surface syntax for NONCANONICAL yet where maybe_stext NoSourceText alt = text alt - maybe_stext (SourceText src) _ = text src <+> text "#-}" + maybe_stext (SourceText src) _ = ftext src <+> text "#-}" instance (OutputableBndrId p) => Outputable (InstDecl (GhcPass p)) where @@ -934,14 +1109,10 @@ do_one (L _ (TyFamInstD {})) = [] -- | Convert a 'NewOrData' to a 'TyConFlavour' -newOrDataToFlavour :: NewOrData -> TyConFlavour +newOrDataToFlavour :: NewOrData -> TyConFlavour tc 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 @@ -958,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 ] @@ -982,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 @@ -998,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 @@ -1037,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 @@ -1045,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)) {- ************************************************************************ @@ -1056,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 @@ -1125,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 }) @@ -1172,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) @@ -1206,20 +1388,20 @@ ************************************************************************ -} -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 instance OutputableBndrId p => Outputable (WarnDecls (GhcPass p)) where ppr (Warnings ext decls) - = text src <+> vcat (punctuate comma (map ppr decls)) <+> text "#-}" + = ftext src <+> vcat (punctuate semi (map ppr decls)) <+> text "#-}" where src = case ghcPass @p of GhcPs | (_, SourceText src) <- ext -> src GhcRn | SourceText src <- ext -> src @@ -1228,9 +1410,15 @@ instance OutputableBndrId p => Outputable (WarnDecl (GhcPass p)) where - ppr (Warning _ thing txt) - = hsep ( punctuate comma (map ppr thing)) + ppr (Warning (ns_spec, _) thing txt) + = ppr_category + <+> ppr ns_spec + <+> hsep (punctuate comma (map ppr thing)) <+> ppr txt + where + ppr_category = case txt of + WarningTxt (Just cat) _ _ -> ppr cat + _ -> empty {- ************************************************************************ @@ -1240,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 @@ -1262,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) @@ -1294,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 @@ -1313,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 @@ -123,8 +123,8 @@ data DocStructureItem = DsiSectionHeading !Int !(HsDoc GhcRn) | DsiDocChunk !(HsDoc GhcRn) - | DsiNamedChunkRef !(String) - | DsiExports !Avails + | DsiNamedChunkRef !String + | 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,16 +223,17 @@ } 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) $ nonDetEltsUniqMap $ docs_decls docs) - put_ bh (sortBy (\a b -> (fst a) `stableNameCmp` fst b) $ nonDetEltsUniqMap $ docs_args 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) put_ bh (Map.toList $ docs_named_chunks docs) put_ bh (docs_haddock_opts 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" <+> text src - BlankSrcSpanFile -> parens $ text "SourceText" <+> text 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,2151 +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.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.Core.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 (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.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 "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 = NoExtField -type instance XCase GhcTc = NoExtField - -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. - -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 -> text 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 - Left rbinds -> hang (ppr aexp) 2 (braces (fsep (punctuate comma (map ppr rbinds)))) - Right 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 (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 (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 = panic "matchContextErrString" -- Not used at runtime -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 - -- match checker trace -matchSeparator ThPatSplice = panic "unused" -matchSeparator ThPatQuote = panic "unused" -matchSeparator PatSyn = 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 construct" -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 @@ -21,25 +23,29 @@ , module GHC.Hs.ImpExp ) where +import Language.Haskell.Syntax.Extension +import Language.Haskell.Syntax.Module.Name +import Language.Haskell.Syntax.ImpExp + import GHC.Prelude import GHC.Types.SourceText ( SourceText(..) ) -import GHC.Types.FieldLabel ( FieldLabel ) - -import GHC.Utils.Outputable -import GHC.Utils.Panic import GHC.Types.SrcLoc -import GHC.Parser.Annotation -import GHC.Hs.Extension import GHC.Types.Name import GHC.Types.PkgQual +import GHC.Parser.Annotation +import GHC.Hs.Extension + +import GHC.Utils.Outputable +import GHC.Utils.Panic + +import GHC.Unit.Module.Warnings + import Data.Data import Data.Maybe +import GHC.Hs.Doc (LHsDoc) -import Language.Haskell.Syntax.Extension -import Language.Haskell.Syntax.Module.Name -import Language.Haskell.Syntax.ImpExp {- ************************************************************************ @@ -53,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 @@ -70,6 +68,7 @@ isImportDeclQualified _ = True + type instance ImportDeclPkgQual GhcPs = RawPkgQual type instance ImportDeclPkgQual GhcRn = PkgQual type instance ImportDeclPkgQual GhcTc = PkgQual @@ -77,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 @@ -93,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) @@ -108,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 @@ -125,6 +136,7 @@ ideclPkgQual = NoRawPkgQual, ideclSource = NotBoot, ideclSafe = False, + ideclLevelSpec = NotLevelled, ideclQualified = NotQualified, ideclAs = Nothing, ideclImportList = Nothing @@ -170,7 +182,7 @@ GhcTc -> dataConCantHappen ext in case mSrcText of NoSourceText -> text "{-# SOURCE #-}" - SourceText src -> text src <+> text "#-}" + SourceText src -> ftext src <+> text "#-}" ppr_imp _ NotBoot = empty pp_spec Nothing = empty @@ -189,28 +201,51 @@ -} 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 type instance Anno (IE (GhcPass p)) = SrcSpanAnnA -type instance XIEVar GhcPs = NoExtField -type instance XIEVar GhcRn = NoExtField -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 XIEVar GhcPs = Maybe (LWarningTxt GhcPs) +type instance XIEVar GhcRn = Maybe (LWarningTxt GhcRn) +type instance XIEVar GhcTc = NoExtField -type instance XIEThingAbs (GhcPass _) = EpAnn [AddEpAnn] -type instance XIEThingAll (GhcPass _) = EpAnn [AddEpAnn] +-- 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 (LWarningTxt GhcPs) +type instance XIEThingAbs GhcRn = Maybe (LWarningTxt GhcRn) +type instance XIEThingAbs GhcTc = () --- See Note [IEThingWith] -type instance XIEThingWith (GhcPass 'Parsed) = EpAnn [AddEpAnn] -type instance XIEThingWith (GhcPass 'Renamed) = [Located FieldLabel] -type instance XIEThingWith (GhcPass 'Typechecked) = 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 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 ")") -type instance XIEModuleContents GhcPs = EpAnn [AddEpAnn] -type instance XIEModuleContents GhcRn = 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 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 (LWarningTxt GhcPs), EpToken "module") +type instance XIEModuleContents GhcRn = Maybe (LWarningTxt GhcRn) type instance XIEModuleContents GhcTc = NoExtField type instance XIEGroup (GhcPass _) = NoExtField @@ -220,55 +255,48 @@ type instance Anno (LocatedA (IE (GhcPass p))) = SrcSpanAnnA -{- -Note [IEThingWith] -~~~~~~~~~~~~~~~~~~ -A definition like - - {-# LANGUAGE DuplicateRecordFields #-} - module M ( T(MkT, x) ) where - data T = MkT { x :: Int } - -gives rise to this in the output of the parser: - - IEThingWith NoExtField T [MkT, x] NoIEWildcard - -But in the renamer we need to attach the correct field label, -because the selector Name is mangled (see Note [FieldLabel] in -GHC.Types.FieldLabel). Hence we change this to: - - IEThingWith [FieldLabel "x" True $sel:x:MkT)] T [MkT] NoIEWildcard - -using the TTG extension field to store the list of fields in renamed syntax -only. (Record fields always appear in this list, regardless of whether -DuplicateRecordFields was in use at the definition site or not.) - -See Note [Representing fields in AvailInfo] in GHC.Types.Avail for more details. --} +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 {}) = [] ieNames (IEDocNamed {}) = [] +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 (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 (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 @@ -281,20 +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 (IEVar _ var) = ppr (unLoc var) - ppr (IEThingAbs _ thing) = ppr (unLoc thing) - ppr (IEThingAll _ thing) = hcat [ppr (unLoc thing), text "(..)"] - ppr (IEThingWith flds thing wc withs) - = ppr (unLoc thing) <> parens (fsep (punctuate comma - (ppWiths ++ ppFields) )) + 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 @@ -303,12 +351,8 @@ IEWildcard pos -> let (bs, as) = splitAt pos (map (ppr . unLoc) withs) in bs ++ [text ".."] ++ as - ppFields = - case ghcPass @p of - GhcRn -> map ppr flds - _ -> [] - ppr (IEModuleContents _ mod') - = text "module" <+> ppr mod' + ppr ie@(IEModuleContents _ mod') + = sep $ catMaybes [ppr <$> ieDeprecation ie, Just $ text "module" <+> ppr mod'] ppr (IEGroup _ n _) = text ("") ppr (IEDoc _ doc) = ppr doc ppr (IEDocNamed _ string) = text ("") @@ -322,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) @@ -287,6 +297,14 @@ deriving instance Data (FieldLabelStrings GhcRn) deriving instance Data (FieldLabelStrings GhcTc) +deriving instance Data (HsRecUpdParent GhcPs) +deriving instance Data (HsRecUpdParent GhcRn) +deriving instance Data (HsRecUpdParent GhcTc) + +deriving instance Data (LHsRecUpdFields GhcPs) +deriving instance Data (LHsRecUpdFields GhcRn) +deriving instance Data (LHsRecUpdFields GhcTc) + deriving instance Data (DotFieldOcc GhcPs) deriving instance Data (DotFieldOcc GhcRn) deriving instance Data (DotFieldOcc GhcTc) @@ -366,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) @@ -417,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) @@ -437,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) @@ -450,6 +479,11 @@ -- --------------------------------------------------------------------- -- Data derivations from GHC.Hs.Type ---------------------------------- +-- deriving instance Data (HsBndrVis p) +deriving instance Data (HsBndrVis GhcPs) +deriving instance Data (HsBndrVis GhcRn) +deriving instance Data (HsBndrVis GhcTc) + -- deriving instance (DataIdLR p p) => Data (LHsQTyVars p) deriving instance Data (LHsQTyVars GhcPs) deriving instance Data (LHsQTyVars GhcRn) @@ -475,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) @@ -485,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 (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 (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 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 (Data a, Data b) => Data (HsArg a b) --- deriving instance Data (HsArg (Located (HsType GhcPs)) (Located (HsKind GhcPs))) --- deriving instance Data (HsArg (Located (HsType GhcRn)) (Located (HsKind GhcRn))) --- deriving instance Data (HsArg (Located (HsType GhcTc)) (Located (HsKind 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) => Data (ConDeclField p) -deriving instance Data (ConDeclField GhcPs) -deriving instance Data (ConDeclField GhcRn) -deriving instance Data (ConDeclField 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) @@ -548,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 @@ -556,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,18 +49,40 @@ 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 type instance XHsWordPrim (GhcPass _) = SourceText +type instance XHsInt8Prim (GhcPass _) = SourceText +type instance XHsInt16Prim (GhcPass _) = SourceText +type instance XHsInt32Prim (GhcPass _) = SourceText type instance XHsInt64Prim (GhcPass _) = SourceText +type instance XHsWord8Prim (GhcPass _) = SourceText +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] @@ -120,37 +145,55 @@ -- -- 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 (HsFloatPrim {}) = False + go (HsDoublePrim {}) = False go (HsIntPrim {}) = False - go (HsWordPrim {}) = False + go (HsInt8Prim {}) = False + go (HsInt16Prim {}) = False + go (HsInt32Prim {}) = False go (HsInt64Prim {}) = False + go (HsWordPrim {}) = False + go (HsWord8Prim {}) = False + go (HsWord16Prim {}) = False go (HsWord64Prim {}) = False - go (HsInteger _ x _) = p > topPrec && x < 0 - go (HsRat _ x _) = p > topPrec && fl_neg x - go (HsFloatPrim {}) = False - go (HsDoublePrim {}) = False - go (XLit _) = False + go (HsWord32Prim {}) = 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 convertLit (HsWordPrim a x) = HsWordPrim a x +convertLit (HsInt8Prim a x) = HsInt8Prim a x +convertLit (HsInt16Prim a x) = HsInt16Prim a x +convertLit (HsInt32Prim a x) = HsInt32Prim a x convertLit (HsInt64Prim a x) = HsInt64Prim a x +convertLit (HsWord8Prim a x) = HsWord8Prim a x +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 @@ -170,21 +213,33 @@ -} -- 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) - ppr (HsWordPrim st w) = pprWithSourceText st (pprPrimWord w) + ppr (HsInt8Prim st i) = pprWithSourceText st (pprPrimInt8 i) + ppr (HsInt16Prim st i) = pprWithSourceText st (pprPrimInt16 i) + ppr (HsInt32Prim st i) = pprWithSourceText st (pprPrimInt32 i) ppr (HsInt64Prim st i) = pprWithSourceText st (pprPrimInt64 i) + ppr (HsWordPrim st w) = pprWithSourceText st (pprPrimWord w) + ppr (HsWord8Prim st w) = pprWithSourceText st (pprPrimWord8 w) + 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 @@ -203,18 +258,43 @@ -- 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 pmPprHsLit (HsWordPrim _ w) = integer w +pmPprHsLit (HsInt8Prim _ i) = integer i +pmPprHsLit (HsInt16Prim _ i) = integer i +pmPprHsLit (HsInt32Prim _ i) = integer i pmPprHsLit (HsInt64Prim _ i) = integer i +pmPprHsLit (HsWord8Prim _ w) = integer w +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, + collectEvVarsPat, collectEvVarsPats, pprParendLPat, pprConArgs, @@ -72,20 +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.Driver.Session -import qualified GHC.LanguageExtensions as LangExt +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 @@ -93,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 @@ -117,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. @@ -145,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. @@ -204,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 @@ -241,18 +335,18 @@ cpt_wrap :: HsWrapper } -hsRecFieldId :: HsRecField GhcTc arg -> Id -hsRecFieldId = hsRecFieldSel -hsRecUpdFieldRdr :: HsRecUpdField (GhcPass p) -> Located RdrName -hsRecUpdFieldRdr = fmap rdrNameAmbiguousFieldOcc . 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 {- ************************************************************************ @@ -262,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))) @@ -283,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) @@ -328,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 @@ -348,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)` @@ -378,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 @@ -402,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 @@ -421,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 = [] @@ -474,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 @@ -487,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 @@ -495,30 +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 -isIrrefutableHsPat :: forall p. (OutputableBndrId p) - => DynFlags -> LPat (GhcPass p) -> Bool --- (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. --- --- But if it returns True, the pattern is definitely irrefutable -isIrrefutableHsPat dflags = - isIrrefutableHsPat' (xopt LangExt.Strict dflags) - {- Note [-XStrict and irrefutability] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -545,43 +628,55 @@ See also Note [decideBangHood] in GHC.HsToCore.Utils. -} -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 +-- | @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.) +-- +-- If isIrrefutableHsPat returns 'True', the pattern is definitely irrefutable. +-- +-- 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 @@ -590,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 @@ -609,16 +706,157 @@ -- - 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 VarPat _ x -> Just (unLoc x) _ -> Nothing +-- | Is this pattern boring from the perspective of pattern-match checking, +-- i.e. introduces no new pieces of long-distance information +-- which could influence pattern-match checking? +-- +-- See Note [Boring patterns]. +isBoringHsPat :: forall p. OutputableBndrId p => LPat (GhcPass p) -> Bool +-- NB: it's always safe to return 'False' in this function; that just means +-- performing potentially-redundant pattern-match checking. +isBoringHsPat = goL + where + goL :: forall p. OutputableBndrId p => LPat (GhcPass p) -> Bool + goL = go . unLoc -{- Note [Unboxed sum patterns aren't irrefutable] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + go :: forall p. OutputableBndrId p => Pat (GhcPass p) -> Bool + go = \case + WildPat {} -> True + VarPat {} -> True + LazyPat {} -> True + BangPat _ 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 + SigPat _ pat _ -> goL pat + TuplePat _ pats _ -> all goL pats + SumPat _ pat _ _ -> goL pat + ListPat _ pats -> all goL pats + ConPat { pat_con = con, pat_args = details } + -> case ghcPass @p of + GhcPs -> False -- conservative + GhcRn -> False -- conservative + GhcTc + | isVanillaConLike (unLoc con) + -> all goL (hsConPatArgs details) + | otherwise + -- 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 + HsPatExpanded _ pat -> go pat + GhcTc -> case ext of + CoPat _ pat _ -> go pat + ExpansionPat _ pat -> go pat + +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: @@ -637,8 +875,182 @@ Failing to mark unboxed sum patterns as non-irrefutable would cause the Just' case in foo to be unreachable, as GHC would mistakenly believe that Nothing' is the only thing that could possibly be matched! + +Note [Boring patterns] +~~~~~~~~~~~~~~~~~~~~~~ +A pattern is called boring when no new information is gained upon successfully +matching on the pattern. + +Some examples of boring patterns: + + - x, for a variable x. We learn nothing about x upon matching this pattern. + - Just y. This pattern can fail, but if it matches, we don't learn anything + about y. + +Some examples of non-boring patterns: + + - x@(Just y). A match on this pattern introduces the fact that x is headed + by the constructor Just, which means that a subsequent pattern match such as + + case x of { Just z -> ... } + + should not be marked as incomplete. + - a@b. Matching on this pattern introduces a relation between 'a' and 'b', + which means that we shouldn't emit any warnings in code of the form + + case a of + True -> case b of { True -> .. } -- no warning here! + False -> ... + - GADT patterns. For example, with the GADT + + data G i where { MkGInt :: G Int } + + a match on the pattern 'MkGInt' introduces type-level information: + + foo :: G i -> i + foo MkGInt = 3 + + Here we learn that i ~ Int after matching on 'MkGInt', so this pattern + is not boring. + +When a pattern is boring, and we are only interested in additional long-distance +information (not whether the pattern itself is fallible), we can skip pattern-match +checking entirely. Doing this saves about 10% allocations in test T11195. + +This happens when we are checking pattern-matches in do-notation, for example: + + do { x@(Just y) <- z + ; ... + ; return $ case x of { Just w -> ... } } + +Here we *do not* want to emit a pattern-match warning on the first line for the +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 @@ -648,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 @@ -683,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@. @@ -705,6 +1122,7 @@ | patNeedsParens p pat = L loc (gParPat lpat) | otherwise = lpat + {- % Collect all EvVars from all constructor patterns -} @@ -720,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 @@ -751,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,26 +63,37 @@ 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 hsLitType (HsWordPrim _ _) = wordPrimTy +hsLitType (HsInt8Prim _ _) = int8PrimTy +hsLitType (HsInt16Prim _ _) = int16PrimTy +hsLitType (HsInt32Prim _ _) = int32PrimTy hsLitType (HsInt64Prim _ _) = int64PrimTy +hsLitType (HsWord8Prim _ _) = word8PrimTy +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. @@ -92,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 @@ -112,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 @@ -136,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 @@ -187,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 @@ -1,5 +1,6 @@ {-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE DeriveDataTypeable #-} @@ -22,19 +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, @@ -44,33 +51,36 @@ 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, - rdrNameAmbiguousFieldOcc, selectorAmbiguousFieldOcc, - unambiguousFieldOcc, ambiguousFieldOcc, + fieldOccRdrName, fieldOccLRdrName, + OpName(..), + mkAnonWildCardTy, pprAnonWildCard, hsOuterTyVarNames, hsOuterExplicitBndrs, mapHsOuterImplicit, mkHsOuterImplicit, mkHsOuterExplicit, mkHsImplicitSigType, mkHsExplicitSigType, - mkHsWildCardBndrs, mkHsPatSigType, + mkHsWildCardBndrs, mkHsPatSigType, mkHsTyPat, mkEmptyWildCardBndrs, mkHsForAllVisTele, mkHsForAllInvisTele, mkHsQTvs, hsQTvExplicit, emptyLHsQTvs, - isHsKindedTyVar, hsTvbAllKinded, - hsScopedTvs, hsWcScopedTvs, dropWildCards, - hsTyVarName, hsAllLTyVarNames, hsLTyVarLocNames, - hsLTyVarName, hsLTyVarNames, hsLTyVarLocName, hsExplicitLTyVarNames, + isHsKindedTyVar, hsBndrVar, hsBndrKind, hsTvbAllKinded, + hsScopedTvs, hsScopedKvs, hsWcScopedTvs, dropWildCards, + hsTyVarLName, hsTyVarName, + hsAllLTyVarNames, hsLTyVarLocNames, + hsLTyVarName, hsLTyVarNames, + hsForAllTelescopeBndrs, + hsForAllTelescopeNames, + hsLTyVarLocName, hsExplicitLTyVarNames, splitLHsInstDeclTy, getLHsInstDeclHead, getLHsInstDeclClass_maybe, splitLHsPatSynTy, splitLHsForAllTyInvis, splitLHsForAllTyInvis_KP, splitLHsQualTy, @@ -79,10 +89,10 @@ mkHsOpTy, mkHsAppTy, mkHsAppTys, mkHsAppKindTy, ignoreParens, hsSigWcType, hsPatSigType, hsTyKindSig, - setHsTyVarBndrFlag, hsTyVarBndrFlag, + setHsTyVarBndrFlag, hsTyVarBndrFlag, updateHsTyVarBndrFlag, -- Printing - pprHsType, pprHsForAll, + pprHsType, pprHsForAll, pprHsForAllTelescope, pprHsOuterFamEqnTyVarBndrs, pprHsOuterSigTyVarBndrs, pprLHsContext, hsTypeNeedsParens, parenthesizeHsType, parenthesizeHsContext @@ -95,18 +105,20 @@ import {-# SOURCE #-} GHC.Hs.Expr ( pprUntypedSplice, HsUntypedSpliceResult(..) ) 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( Name, NamedThing(getName), tcName, dataName ) -import GHC.Types.Name.Reader ( RdrName ) +import GHC.Types.Name +import GHC.Types.Name.Reader ( RdrName, WithUserRdr(..), noUserRdr ) import GHC.Types.Var ( VarBndr, visArgTypeLike ) import GHC.Core.TyCo.Rep ( Type(..) ) -import GHC.Builtin.Types( manyDataConName, oneDataConName, mkTupleStr ) +import GHC.Builtin.Names ( negateName ) +import GHC.Builtin.Types( oneDataConName, mkTupleStr ) import GHC.Core.Ppr ( pprOccWithTick) import GHC.Core.Type import GHC.Core.Multiplicity( pprArrowWithMultiplicity ) @@ -120,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 {- ************************************************************************ @@ -151,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) = ... @@ -172,17 +165,17 @@ 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 } -mkHsQTvs :: [LHsTyVarBndr () GhcPs] -> LHsQTyVars GhcPs +mkHsQTvs :: [LHsTyVarBndr (HsBndrVis GhcPs) GhcPs] -> LHsQTyVars GhcPs mkHsQTvs tvs = HsQTvs { hsq_ext = noExtField, hsq_explicit = tvs } emptyLHsQTvs :: LHsQTyVars GhcRn @@ -195,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] @@ -211,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 @@ -219,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 @@ -243,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 } @@ -253,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 = @@ -268,133 +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 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 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 _) = SrcSpan -- Where the `@` lives +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: @@ -414,20 +614,40 @@ = hsLTyVarNames (hsOuterExplicitBndrs outer_bndrs) -- See Note [hsScopedTvs and visible foralls] +hsScopedKvs :: LHsKind GhcRn -> [Name] +-- Same as hsScopedTvs, but for a LHsKind +hsScopedKvs (L _ HsForAllTy { hst_tele = HsForAllInvis { hsf_invis_bndrs = bndrs }}) + = hsLTyVarNames bndrs + -- See Note [hsScopedTvs and visible foralls] +hsScopedKvs _ = [] + --------------------- -hsTyVarName :: HsTyVarBndr flag (GhcPass p) -> IdP (GhcPass p) -hsTyVarName (UserTyVar _ _ (L _ n)) = n -hsTyVarName (KindedTyVar _ _ (L _ n) _) = n +hsTyVarLName :: HsTyVarBndr flag (GhcPass p) -> Maybe (LIdP (GhcPass p)) +hsTyVarLName tvb = + case hsBndrVar tvb of + HsBndrVar _ n -> Just n + HsBndrWildCard _ -> Nothing -hsLTyVarName :: LHsTyVarBndr flag (GhcPass p) -> IdP (GhcPass p) +hsTyVarName :: HsTyVarBndr flag (GhcPass p) -> Maybe (IdP (GhcPass p)) +hsTyVarName = fmap unLoc . hsTyVarLName + +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 @@ -435,11 +655,13 @@ , hsq_explicit = tvs }) = kvs ++ hsLTyVarNames tvs -hsLTyVarLocName :: LHsTyVarBndr flag (GhcPass p) -> LocatedN (IdP (GhcPass p)) -hsLTyVarLocName (L l a) = L (l2l l) (hsTyVarName a) +hsLTyVarLocName :: Anno (IdGhcP p) ~ SrcSpanAnnN + => LHsTyVarBndr flag (GhcPass p) -> Maybe (LocatedN (IdP (GhcPass p))) +hsLTyVarLocName (L _ a) = hsTyVarLName a -hsLTyVarLocNames :: LHsQTyVars (GhcPass p) -> [LocatedN (IdP (GhcPass p))] -hsLTyVarLocNames qtvs = map hsLTyVarLocName (hsQTvExplicit qtvs) +hsLTyVarLocNames :: Anno (IdGhcP p) ~ SrcSpanAnnN + => LHsQTyVars (GhcPass p) -> [LocatedN (IdP (GhcPass p))] +hsLTyVarLocNames qtvs = mapMaybe hsLTyVarLocName (hsQTvExplicit qtvs) -- | Get the kind signature of a type, ignoring parentheses: -- @@ -472,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 :: XAppKindTy (GhcPass p) -> LHsType (GhcPass p) -> LHsType (GhcPass p) +mkHsAppKindTy :: XAppKindTy (GhcPass p) + -> LHsType (GhcPass p) -> LHsType (GhcPass p) -> LHsType (GhcPass p) -mkHsAppKindTy ext ty k - = addCLocAA ty k (HsAppKindTy ext ty k) +mkHsAppKindTy at ty k = addCLocA ty k (HsAppKindTy at ty k) {- ************************************************************************ @@ -508,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 -> at `combineSrcSpans` getLocA ty + HsValArg _ tm -> getLocA tm + HsTypeArg at ty -> getEpTokenSrcSpan at `combineSrcSpans` getLocA ty HsArgPar sp -> sp -------------------------------- -numVisibleArgs :: [HsArg tm ty] -> Arity +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 -------------------------------- @@ -576,7 +803,7 @@ -- pprHsArgsApp (++) Infix [HsValArg Char, HsValArg Double, HsVarArg Ordering] = (Char ++ Double) Ordering -- @ pprHsArgsApp :: (OutputableBndr id, Outputable tm, Outputable ty) - => id -> LexicalFixity -> [HsArg 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 @@ -591,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 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 @@ -601,8 +828,8 @@ -- | Pretty-print an 'HsArg' in isolation. ppr_single_hs_arg :: (Outputable tm, Outputable ty) - => HsArg 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 @@ -611,9 +838,9 @@ -- | 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 tm ty) where - ppr (HsValArg tm) = text "HsValArg" <+> ppr tm - ppr (HsTypeArg sp ty) = text "HsTypeArg" <+> ppr sp <+> ppr ty +instance (Outputable tm, Outputable ty) => Outputable (HsArg (GhcPass p) tm ty) where + ppr (HsValArg _ tm) = text "HsValArg" <+> ppr tm + ppr (HsTypeArg _ ty) = text "HsTypeArg" <+> ppr ty ppr (HsArgPar sp) = text "HsArgPar" <+> ppr sp -------------------------------- @@ -643,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. @@ -666,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. @@ -686,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). @@ -712,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 @@ -730,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. @@ -791,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 @@ -890,57 +1129,85 @@ 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 . rdrNameAmbiguousFieldOcc +-------------------------------------------------------------------------------- -instance OutputableBndr (AmbiguousFieldOcc (GhcPass p)) where - pprInfixOcc = pprInfixOcc . rdrNameAmbiguousFieldOcc - pprPrefixOcc = pprPrefixOcc . rdrNameAmbiguousFieldOcc +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 -rdrNameAmbiguousFieldOcc :: AmbiguousFieldOcc (GhcPass p) -> RdrName -rdrNameAmbiguousFieldOcc (Unambiguous _ (L _ rdr)) = rdr -rdrNameAmbiguousFieldOcc (Ambiguous _ (L _ rdr)) = rdr +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) -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 +{- +************************************************************************ +* * + OpName +* * +************************************************************************ +-} -ambiguousFieldOcc :: FieldOcc GhcTc -> AmbiguousFieldOcc GhcTc -ambiguousFieldOcc (FieldOcc sel rdr) = Unambiguous sel rdr +-- | Name of an operator in an operator application or section +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 + ppr NegateOp = ppr negateName + ppr (UnboundOp uv) = ppr uv + ppr (RecFldOp fld) = ppr fld + {- ************************************************************************ * * @@ -949,19 +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 (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 + +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 @@ -1006,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 @@ -1017,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)) @@ -1057,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. @@ -1065,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 @@ -1095,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 @@ -1136,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) @@ -1166,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 '_' @@ -1194,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 @@ -1206,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 @@ -1235,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 @@ -1246,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 @@ -1278,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 @@ -1303,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 @@ -1312,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] @@ -1327,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 @@ -1340,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 @@ -1,8 +1,10 @@ {-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE TupleSections #-} + {-| 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 @@ -12,7 +14,7 @@ ---------------- ------------- GhcPs/RdrName GHC.Parser.PostProcess GhcRn/Name GHC.Rename.* - GhcTc/Id GHC.Tc.Utils.Zonk + GhcTc/Id GHC.Tc.Zonk.Type The @mk*@ functions attempt to construct a not-completely-useless SrcSpan from their components, compared with the @nl*@ functions which @@ -33,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, @@ -86,7 +93,7 @@ mkLetStmt, -- * Collecting binders - isUnliftedHsBind, isBangedHsBind, + isUnliftedHsBind, isUnliftedHsBinds, isBangedHsBind, collectLocalBinders, collectHsValBinders, collectHsBindListBinders, collectHsIdBinders, @@ -97,12 +104,15 @@ collectLStmtBinders, collectStmtBinders, CollectPass(..), CollectFlag(..), + TyDeclBinders(..), LConsWithFields(..), hsLTyClDeclBinders, hsTyClForeignBinders, hsPatSynSelectors, getPatSynBinds, hsForeignDeclsBinders, hsGroupBinders, hsDataFamInstBinders, -- * Collecting implicit binders - lStmtsImplicits, hsValBindsImplicits, lPatImplicits + ImplicitFieldBinders(..), + lStmtsImplicits, hsValBindsImplicits, lPatImplicits, + lHsRecFieldsImplicits ) where import GHC.Prelude hiding (head, init, last, tail) @@ -113,6 +123,7 @@ import GHC.Hs.Pat import GHC.Hs.Type import GHC.Hs.Lit +import Language.Haskell.Syntax.Decls import Language.Haskell.Syntax.Extension import GHC.Hs.Extension import GHC.Parser.Annotation @@ -126,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 @@ -140,19 +151,22 @@ 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 Data.Either +import Control.Arrow ( first ) import Data.Foldable ( toList ) -import Data.Function -import Data.List ( partition, deleteBy ) -import Data.List.NonEmpty ( nonEmpty ) +import Data.List ( partition ) +import Data.List.NonEmpty ( NonEmpty (..), nonEmpty ) import qualified Data.List.NonEmpty as NE +import Data.IntMap ( IntMap ) +import qualified Data.IntMap.Strict as IntMap +import Data.Map ( Map ) +import qualified Data.Map.Strict as Map + {- ************************************************************************ * * @@ -166,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 @@ -186,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)) @@ -248,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 - (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 @@ -297,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) ------------------------------- @@ -307,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 @@ -326,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)) @@ -336,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)) @@ -349,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 } @@ -364,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 @@ -383,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 = [] @@ -442,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) @@ -476,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) @@ -500,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) @@ -519,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) @@ -542,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 } @@ -584,13 +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 (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 @@ -599,42 +616,68 @@ nlHsIf cond true false = noLocA (HsIf noAnn cond true false) nlHsCase expr matches - = noLocA (HsCase noAnn expr (mkMatchGroup Generated (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 _ ki) = noLocA (HsAppKindTy noSrcSpan fun (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 noSrcSpan f (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 @@ -646,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) @@ -656,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 @@ -690,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 @@ -738,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 --------- @@ -749,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 @@ -773,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 @@ -808,15 +861,15 @@ } 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 (GhcPass p) -> LHsExpr (GhcPass p) -> LHsBind (GhcPass p) +mkVarBind :: IdP GhcTc -> LHsExpr GhcTc -> LHsBind GhcTc mkVarBind var rhs = L (getLoc rhs) $ VarBind { var_ext = noExtField, 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 @@ -827,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 @@ -839,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)) @@ -855,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] - -> LHsExpr GhcPs -> LHsBind GhcPs +mkSimpleGeneratedFunBind :: SrcSpan -> RdrName -> LocatedE [LPat GhcPs] + -> LHsExpr GhcPs -> LHsBind GhcPs mkSimpleGeneratedFunBind loc fun pats expr - = L (noAnnSrcSpan loc) $ mkFunBind Generated (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 }) {- @@ -905,60 +961,111 @@ and wild-card mechanism makes it hard to know what is bound. So these functions should not be applied to (HsSyn RdrName) -Note [Unlifted id check in isUnliftedHsBind] +Note [isUnliftedHsBind] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The function isUnliftedHsBind is used to complain if we make a top-level -binding for a variable of unlifted type. +The function isUnliftedHsBind tells if the binding binds a variable of +unlifted type. e.g. -Such a binding is illegal if the top-level binding would be unlifted; -but also if the local letrec generated by desugaring AbsBinds would be. -E.g. - f :: Num a => (# a, a #) - g :: Num a => a -> a - f = ...g... - g = ...g... + - I# x = blah + - Just (I# x) = blah -The top-level bindings for f,g are not unlifted (because of the Num a =>), -but the local, recursive, monomorphic bindings are: +isUnliftedHsBind is used in two ways: +* To complain if we make a top-level binding for a variable of unlifted + type. E.g. any of the above bindings are illegal at top level + +* To generate a case expression for a non-recursive local let. E.g. + let Just (I# x) = blah in body + ==> + case blah of Just (I# x) -> body + See GHC.HsToCore.Expr.dsUnliftedBind. + +Wrinkles: + +(W1) For AbsBinds we must check if the local letrec generated by desugaring + AbsBinds would be unlifted; so we just recurse into the abs_binds. E.g. + f :: Num a => (# a, a #) + g :: Num a => a -> a + f = ...g... + g = ...g... + + The top-level bindings for f,g are not unlifted (because of the Num a =>), + but the local, recursive, monomorphic bindings are: t = /\a \(d:Num a). letrec fm :: (# a, a #) = ...g... gm :: a -> a = ...f... in (fm, gm) -Here the binding for 'fm' is illegal. So generally we check the abe_mono types. + Here the binding for 'fm' is illegal. So we recurse into the abs_binds -BUT we have a special case when abs_sig is true; - see Note [The abs_sig field of AbsBinds] in GHC.Hs.Binds +(W2) BUT we have a special case when abs_sig is true; + see Note [The abs_sig field of AbsBinds] in GHC.Hs.Binds + +(W3) isUnliftedHsBind returns False even if the binding itself is + unlifted, provided it binds only lifted variables. E.g. + - (# a,b #) = (# reverse xs, xs #) + + - x = sqrt# y# :: Float# + + - type Unl :: UnliftedType + data Unl = MkUnl Int + MkUnl z = blah + + In each case the RHS of the "=" has unlifted type, but isUnliftedHsBind + returns False. Reason: see GHC Proposal #35 + https://github.com/ghc-proposals/ghc-proposals/blob/master/ + proposals/0035-unbanged-strict-patterns.rst + +(W4) In particular, (W3) applies to a pattern that binds no variables at all. + So { _ = sqrt# y :: Float# } returns False from isUnliftedHsBind, but + { x = sqrt# y :: Float# } returns True. + This is arguably a bit confusing (see #22719) -} ----------------- Bindings -------------------------- -- | Should we treat this as an unlifted bind? This will be true for any -- bind that binds an unlifted variable, but we must be careful around --- AbsBinds. See Note [Unlifted id check in isUnliftedHsBind]. For usage +-- AbsBinds. See Note [isUnliftedHsBind]. For usage -- information, see Note [Strict binds checks] is GHC.HsToCore.Binds. isUnliftedHsBind :: HsBind GhcTc -> Bool -- works only over typechecked binds -isUnliftedHsBind bind - | XHsBindsLR (AbsBinds { abs_exports = exports, abs_sig = has_sig }) <- bind - = if has_sig - then any (is_unlifted_id . abe_poly) exports - else any (is_unlifted_id . abe_mono) exports +isUnliftedHsBind (XHsBindsLR (AbsBinds { abs_exports = exports + , abs_sig = has_sig + , abs_binds = binds })) + | has_sig = any (is_unlifted_id . abe_poly) exports + | otherwise = isUnliftedHsBinds binds + -- See wrinkle (W1) and (W2) in Note [isUnliftedHsBind] -- If has_sig is True we will never generate a binding for abe_mono, -- so we don't need to worry about it being unlifted. The abe_poly -- binding might not be: e.g. forall a. Num a => (# a, a #) + -- If has_sig is False, just recurse - | otherwise - = any is_unlifted_id (collectHsBindBinders CollNoDictBinders bind) - where - is_unlifted_id id = isUnliftedType (idType id) - -- bindings always have a fixed RuntimeRep, so it's OK - -- to call isUnliftedType here +isUnliftedHsBind (FunBind { fun_id = L _ fun }) + = is_unlifted_id fun +isUnliftedHsBind (VarBind { var_id = var }) + = is_unlifted_id var + +isUnliftedHsBind (PatBind { pat_lhs = pat }) + = any is_unlifted_id (collectPatBinders CollNoDictBinders pat) + -- If we changed our view on (W3) you could add + -- || isUnliftedType pat_ty + -- to this check + +isUnliftedHsBind (PatSynBind {}) = panic "isUnliftedBind: PatSynBind" + +isUnliftedHsBinds :: LHsBinds GhcTc -> Bool +isUnliftedHsBinds = any (isUnliftedHsBind . unLoc) + +is_unlifted_id :: Id -> Bool +is_unlifted_id id = isUnliftedType (idType id) + -- Bindings always have a fixed RuntimeRep, so it's OK + -- to call isUnliftedType here + -- | 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 @@ -1064,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)] @@ -1095,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 -------------------------- @@ -1121,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 @@ -1136,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 @@ -1154,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 @@ -1210,8 +1350,7 @@ 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.Utils.Zonk + -- binding (hence see AbsBinds) is in zonking in GHC.Tc.Zonk.Type collectXSplicePat flag ext = case ghcPass @p of @@ -1305,17 +1444,31 @@ hsTyClForeignBinders tycl_decls foreign_decls = map unLoc (hsForeignDeclsBinders foreign_decls) ++ getSelectorNames - (foldMap (foldMap hsLTyClDeclBinders . group_tyclds) tycl_decls + (foldMap (foldMap (tyDeclBinders . hsLTyClDeclBinders) . group_tyclds) tycl_decls `mappend` - foldMap (foldMap hsLInstDeclBinders . group_instds) tycl_decls) + (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 ------------------- -hsLTyClDeclBinders :: IsPass p + +data TyDeclBinders p + = TyDeclBinders + { tyDeclMainBinder :: !(LocatedA (IdP (GhcPass p)), TyConFlavour ()) + , tyDeclATs :: ![(LocatedA (IdP (GhcPass p)), TyConFlavour ())] + , tyDeclOpSigs :: ![LocatedA (IdP (GhcPass p))] + , tyDeclConsWithFields :: !(LConsWithFields p) } + +tyDeclBinders :: TyDeclBinders p -> ([LocatedA (IdP (GhcPass p))], [LFieldOcc (GhcPass p)]) +tyDeclBinders (TyDeclBinders main ats sigs consWithFields) + = (fst main : (fmap fst ats ++ sigs ++ cons), flds) + where + (cons, flds) = lconsWithFieldsBinders consWithFields + +hsLTyClDeclBinders :: (IsPass p, OutputableBndrId p) => LocatedA (TyClDecl (GhcPass p)) - -> ([LocatedA (IdP (GhcPass p))], [LFieldOcc (GhcPass p)]) + -> TyDeclBinders p -- ^ Returns all the /binding/ names of the decl. The first one is -- guaranteed to be the name of the decl. The first component -- represents all binding names except record fields; the second @@ -1326,27 +1479,40 @@ -- See Note [SrcSpan for binders] hsLTyClDeclBinders (L loc (FamDecl { tcdFam = FamilyDecl - { fdLName = (L _ name) } })) - = ([L loc name], []) + { fdLName = (L _ name) + , fdInfo = fd_info } })) + = TyDeclBinders + { tyDeclMainBinder = (L loc name, familyInfoTyConFlavour Nothing fd_info) + , tyDeclATs = [], tyDeclOpSigs = [] + , tyDeclConsWithFields = emptyLConsWithFields } hsLTyClDeclBinders (L loc (SynDecl { tcdLName = (L _ name) })) - = ([L loc name], []) + = TyDeclBinders + { tyDeclMainBinder = (L loc name, TypeSynonymFlavour) + , tyDeclATs = [], tyDeclOpSigs = [] + , tyDeclConsWithFields = emptyLConsWithFields } hsLTyClDeclBinders (L loc (ClassDecl { tcdLName = (L _ cls_name) , tcdSigs = sigs , tcdATs = ats })) - = (L loc cls_name : - [ L fam_loc fam_name | (L fam_loc (FamilyDecl - { fdLName = L _ fam_name })) <- ats ] - ++ - [ L mem_loc mem_name - | (L mem_loc (ClassOpSig _ False ns _)) <- sigs - , (L _ mem_name) <- ns ] - , []) + = TyDeclBinders + { tyDeclMainBinder = (L loc cls_name, ClassFlavour) + , tyDeclATs = [ (L fam_loc fam_name, familyInfoTyConFlavour (Just ()) fd_info) + | (L fam_loc (FamilyDecl { fdLName = L _ fam_name + , fdInfo = fd_info })) <- ats ] + , tyDeclOpSigs = [ L mem_loc mem_name + | (L mem_loc (ClassOpSig _ False ns _)) <- sigs + , (L _ mem_name) <- ns ] + , tyDeclConsWithFields = emptyLConsWithFields } hsLTyClDeclBinders (L loc (DataDecl { tcdLName = (L _ name) , tcdDataDefn = defn })) - = (\ (xs, ys) -> (L loc name : xs, ys)) $ hsDataDefnBinders defn - + = TyDeclBinders + { tyDeclMainBinder = (L loc name, flav ) + , tyDeclATs = [] + , tyDeclOpSigs = [] + , tyDeclConsWithFields = hsDataDefnBinders defn } + where + flav = newOrDataToFlavour $ dataDefnConsNewOrData $ dd_cons defn ------------------- hsForeignDeclsBinders :: forall p a. (UnXRec (GhcPass p), IsSrcSpanAnn p a) @@ -1364,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 @@ -1376,97 +1542,173 @@ => [(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 +hsLInstDeclBinders :: (IsPass p, OutputableBndrId p) => LInstDecl (GhcPass p) - -> ([LocatedA (IdP (GhcPass p))], [LFieldOcc (GhcPass p)]) + -> ([(LocatedA (IdP (GhcPass p)))], [LFieldOcc (GhcPass p)]) hsLInstDeclBinders (L _ (ClsInstD { cid_inst = ClsInstDecl { cid_datafam_insts = dfis }})) - = foldMap (hsDataFamInstBinders . unLoc) dfis + = foldMap (lconsWithFieldsBinders . hsDataFamInstBinders . unLoc) dfis hsLInstDeclBinders (L _ (DataFamInstD { dfid_inst = fi })) - = hsDataFamInstBinders fi + = lconsWithFieldsBinders $ hsDataFamInstBinders fi hsLInstDeclBinders (L _ (TyFamInstD {})) = mempty ------------------- -- | the 'SrcLoc' returned are for the whole declarations, not just the names -hsDataFamInstBinders :: IsPass p +hsDataFamInstBinders :: (IsPass p, OutputableBndrId p) => DataFamInstDecl (GhcPass p) - -> ([LocatedA (IdP (GhcPass p))], [LFieldOcc (GhcPass p)]) + -> LConsWithFields p hsDataFamInstBinders (DataFamInstDecl { dfid_eqn = FamEqn { feqn_rhs = defn }}) = hsDataDefnBinders defn -- There can't be repeated symbols because only data instances have binders ------------------- -- | the 'SrcLoc' returned are for the whole declarations, not just the names -hsDataDefnBinders :: IsPass p +hsDataDefnBinders :: (IsPass p, OutputableBndrId p) => HsDataDefn (GhcPass p) - -> ([LocatedA (IdP (GhcPass p))], [LFieldOcc (GhcPass p)]) + -> LConsWithFields p hsDataDefnBinders (HsDataDefn { dd_cons = cons }) = hsConDeclsBinders (toList cons) -- See Note [Binders in family instances] ------------------- -type Seen p = [LFieldOcc (GhcPass p)] -> [LFieldOcc (GhcPass p)] - -- Filters out ones that have already been seen -hsConDeclsBinders :: forall p. IsPass p +{- Note [Collecting record fields in data declarations] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When renaming a data declaration that includes record constructors, we are, in +the end, going to to create a mapping from constructor to its field labels, +to store in 'GREInfo' (see 'IAmConLike'). This allows us to know, in the renamer, +which constructor has what fields. + +In order to achieve this, we return the constructor and field information from +hsConDeclsBinders in the following format: + + - [(ConRdrName, [Located Int])], a list of the constructors, each associated + with its record fields, in the form of a list of Int indices into... + - IntMap FieldOcc, an IntMap of record fields. + +(In actual fact, we use [(ConRdrName, Maybe [Located Int])], with Nothing indicating +that the constructor has unlabelled fields: see Note [Local constructor info in the renamer] +in GHC.Types.GREInfo.) + +This allows us to do the following (see GHC.Rename.Names.getLocalNonValBinders.new_tc): + + - create 'Name's for each of the record fields, to get IntMap FieldLabel, + - create 'Name's for each of the constructors, to get [(ConName, [Int])], + - look up the FieldLabels of each constructor, to get [(ConName, [FieldLabel])]. + +NB: This can be a bit tricky to get right in the presence of data types with +duplicate constructors or fields. Storing locations allows us to report an error +for duplicate field declarations, see test cases T9156 T9156_DF. +Other relevant test cases: rnfail015. + +-} + +-- | A mapping from constructors to all of their fields. +-- +-- See Note [Collecting record fields in data declarations]. +data LConsWithFields p = + LConsWithFields + { consWithFieldIndices :: [(LocatedA (IdP (GhcPass p)), Maybe [Located Int])] + , consFields :: IntMap (LFieldOcc (GhcPass p)) + } + +lconsWithFieldsBinders :: LConsWithFields p + -> ([(LocatedA (IdP (GhcPass p)))], [LFieldOcc (GhcPass p)]) +lconsWithFieldsBinders (LConsWithFields cons fields) + = (map fst cons, IntMap.elems fields) + +emptyLConsWithFields :: LConsWithFields p +emptyLConsWithFields = LConsWithFields [] IntMap.empty + +hsConDeclsBinders :: forall p. (IsPass p, OutputableBndrId p) => [LConDecl (GhcPass p)] - -> ([LocatedA (IdP (GhcPass p))], [LFieldOcc (GhcPass p)]) - -- See hsLTyClDeclBinders for what this does - -- The function is boringly complicated because of the records - -- And since we only have equality, we have to be a little careful -hsConDeclsBinders cons - = go id cons + -> LConsWithFields p + -- The function is boringly complicated because of the records + -- And since we only have equality, we have to be a little careful +hsConDeclsBinders cons = go emptyFieldIndices cons where - go :: Seen p -> [LConDecl (GhcPass p)] - -> ([LocatedA (IdP (GhcPass p))], [LFieldOcc (GhcPass p)]) - go _ [] = ([], []) - go remSeen (r:rs) + go :: FieldIndices p -> [LConDecl (GhcPass p)] -> LConsWithFields p + go seen [] = LConsWithFields [] (fields seen) + go seen (r:rs) -- Don't re-mangle the location of field names, because we don't -- have a record of the full location of the field declaration anyway = let loc = getLoc r in case unLoc r of - -- remove only the first occurrence of any seen field in order to - -- avoid circumventing detection of duplicate fields (#9156) ConDeclGADT { con_names = names, con_g_args = args } - -> (toList (L loc . unLoc <$> names) ++ ns, flds ++ fs) + -> LConsWithFields (cons ++ ns) fs where - (remSeen', flds) = get_flds_gadt remSeen args - (ns, fs) = go remSeen' rs + cons = map ( , con_flds ) $ toList (L loc . unLoc <$> names) + (con_flds, seen') = get_flds_gadt seen args + LConsWithFields ns fs = go seen' rs ConDeclH98 { con_name = name, con_args = args } - -> ([L loc (unLoc name)] ++ ns, flds ++ fs) + -> LConsWithFields ([(L loc (unLoc name), con_flds)] ++ ns) fs where - (remSeen', flds) = get_flds_h98 remSeen args - (ns, fs) = go remSeen' rs + (con_flds, seen') = get_flds_h98 seen args + LConsWithFields ns fs = go seen' rs - get_flds_h98 :: Seen p -> HsConDeclH98Details (GhcPass p) - -> (Seen p, [LFieldOcc (GhcPass p)]) - get_flds_h98 remSeen (RecCon flds) = get_flds remSeen flds - get_flds_h98 remSeen _ = (remSeen, []) + 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 _ = (Nothing, seen) - get_flds_gadt :: Seen p -> HsConDeclGADTDetails (GhcPass p) - -> (Seen p, [LFieldOcc (GhcPass p)]) - get_flds_gadt remSeen (RecConGADT flds _) = get_flds remSeen flds - get_flds_gadt remSeen _ = (remSeen, []) + 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 _ = (Nothing, seen) - get_flds :: Seen p -> LocatedL [LConDeclField (GhcPass p)] - -> (Seen p, [LFieldOcc (GhcPass p)]) - get_flds remSeen flds = (remSeen', fld_names) - where - fld_names = remSeen (concatMap (cd_fld_names . unLoc) (unLoc flds)) - remSeen' = foldr (.) remSeen - [deleteBy ((==) `on` unLoc . foLabel . unLoc) v - | v <- fld_names] + get_flds :: FieldIndices p -> LocatedL [LHsConDeclRecField (GhcPass p)] + -> ([Located Int], FieldIndices p) + get_flds seen flds = + foldr add_fld ([], seen) fld_names + where + add_fld fld (is, ixs) = + let (i, ixs') = insertField fld ixs + in (i:is, ixs') + 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]. +data FieldIndices p = + FieldIndices + { fields :: IntMap (LFieldOcc (GhcPass p)) + -- ^ Look up a field from its index. + , fieldIndices :: Map RdrName Int + -- ^ Look up the index of a field label in the previous 'IntMap'. + , newInt :: !Int + -- ^ An integer @i@ such that no integer @i' >= i@ appears in the 'IntMap'. + } + +emptyFieldIndices :: FieldIndices p +emptyFieldIndices = + FieldIndices { fields = IntMap.empty + , fieldIndices = Map.empty + , newInt = 0 } + +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) + | otherwise + = (L loc new_idx, + FieldIndices (IntMap.insert new_idx new_fld flds) + (Map.insert rdr new_idx idxs) + (new_idx + 1)) + where + loc = getLocA new_fld + rdr = fieldOccRdrName . unLoc $ new_fld + {- Note [SrcSpan for binders] ~~~~~~~~~~~~~~~~~~~~~~~~~~ -When extracting the (Located RdrNme) for a binder, at least for the +When extracting the (Located RdrName) for a binder, at least for the main name (the TyCon of a type declaration etc), we want to give it the @SrcSpan@ of the whole /declaration/, not just the name itself (which is how it appears in the syntax tree). This SrcSpan (for the @@ -1487,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 @@ -1529,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) @@ -1550,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 @@ -18,18 +18,16 @@ import GHC.Prelude -import GHC.Driver.Session +import GHC.Driver.DynFlags 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 - , backendWantsBreakpointTicks (backend 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,11 +177,11 @@ 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 { ds_ev_binds <- dsEvBinds ev_binds - ; core_prs <- dsTopLHsBinds binds_cvr + do { dsEvBinds ev_binds $ \ ds_ev_binds -> do + { core_prs <- dsTopLHsBinds binds_cvr ; core_prs <- patchMagicDefns core_prs ; (spec_prs, spec_rules) <- dsImpSpecs imp_specs ; (ds_fords, foreign_prs) <- dsForeigns fords @@ -194,7 +192,7 @@ ; return ( ds_ev_binds , foreign_prs `appOL` core_prs `appOL` spec_prs , spec_rules ++ ds_rules - , ds_fords `appendStubC` hpc_init) } + , ds_fords `appendStubC` hpc_init) } } ; case mb_res of { Nothing -> return (msgs, Nothing) ; @@ -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] - , mkHeteroPrimEqPred k 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))) @@ -158,9 +158,9 @@ -- = case v of v { (x1, .., xn) -> body } -- But the matching may be nested if the tuple is very big -coreCaseTuple :: UniqSupply -> Id -> [Id] -> CoreExpr -> CoreExpr -coreCaseTuple uniqs scrut_var vars body - = mkBigTupleCase uniqs vars body (Var scrut_var) +coreCaseTuple :: Id -> [Id] -> CoreExpr -> DsM CoreExpr +coreCaseTuple scrut_var vars body + = mkBigTupleCase vars body (Var scrut_var) coreCasePair :: Id -> Id -> Id -> CoreExpr -> CoreExpr coreCasePair scrut_var var1 var2 body @@ -231,10 +231,9 @@ -> CoreExpr -- e -> DsM CoreExpr matchEnvStack env_ids stack_id body = do - uniqs <- newUniqueSupply - tup_var <- newSysLocalDs ManyTy (mkBigCoreVarTupTy env_ids) - let match_env = coreCaseTuple uniqs tup_var env_ids body - pair_id <- newSysLocalDs ManyTy (mkCorePairTy (idType tup_var) (idType stack_id)) + tup_var <- newSysLocalMDs (mkBigCoreVarTupTy env_ids) + match_env <- coreCaseTuple tup_var env_ids body + pair_id <- newSysLocalMDs (mkCorePairTy (idType tup_var) (idType stack_id)) return (Lam pair_id (coreCasePair pair_id tup_var stack_id match_env)) ---------------------------------------------- @@ -250,9 +249,9 @@ -> CoreExpr -- e -> DsM CoreExpr matchEnv env_ids body = do - uniqs <- newUniqueSupply - tup_id <- newSysLocalDs ManyTy (mkBigCoreVarTupTy env_ids) - return (Lam tup_id (coreCaseTuple uniqs tup_id env_ids body)) + tup_id <- newSysLocalMDs (mkBigCoreVarTupTy env_ids) + tup_case <- coreCaseTuple tup_id env_ids body + return (Lam tup_id tup_case) ---------------------------------------------- -- matchVarStack @@ -266,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 @@ -296,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) @@ -344,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) @@ -370,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) @@ -397,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) @@ -416,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 @@ -443,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 @@ -505,13 +497,13 @@ -} 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' in_ty = envStackType env_ids stack_ty - core_body <- dsExpr (HsCase noExtField exp match') + core_body <- dsExpr (HsCase (ArrowMatchCtxt ArrowCaseAlt) exp match') core_matches <- matchEnvStack env_ids stack_id core_body return (do_premap ids in_ty sum_ty res_ty core_matches core_choices, @@ -536,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 @@ -563,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 @@ -592,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 @@ -635,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 @@ -644,10 +643,8 @@ dsCmd ids local_vars stack_ty res_ty (XCmd (HsWrap wrap cmd)) env_ids = do (core_cmd, env_ids') <- dsCmd ids local_vars stack_ty res_ty cmd env_ids - core_wrap <- dsHsWrapper wrap - return (core_wrap core_cmd, env_ids') - -dsCmd _ _ _ _ c _ = pprPanic "dsCmd" (ppr c) + dsHsWrapper wrap $ \core_wrap -> + return (core_wrap core_cmd, env_ids') -- D; ys |-a c : stk --> t (ys <= xs) -- --------------------- @@ -665,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 @@ -729,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 @@ -739,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 @@ -786,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, @@ -810,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 + , mg_ext = MatchGroupTc [Scaled ManyTy void_ty] res_ty (Generated OtherExpansion SkipPmc) })) -- Replace the commands in the case with these tagged tuples, @@ -854,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 @@ -956,18 +954,17 @@ -- projection function -- \ (p, (xs2)) -> (zs) - env_id <- newSysLocalDs ManyTy env_ty2 - uniqs <- newUniqueSupply + env_id <- newSysLocalMDs env_ty2 let after_c_ty = mkCorePairTy pat_ty env_ty2 out_ty = mkBigCoreVarTupTy out_ids - body_expr = coreCaseTuple uniqs env_id env_ids2 (mkBigCoreVarTup out_ids) + body_expr <- coreCaseTuple env_id env_ids2 (mkBigCoreVarTup out_ids) 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) @@ -1029,12 +1026,11 @@ -- post_loop_fn = \((later_ids),(env2_ids)) -> (out_ids) - uniqs <- newUniqueSupply - 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 - post_loop_body = coreCaseTuple uniqs env2_id env2_ids (mkBigCoreVarTup out_ids) + post_loop_body <- coreCaseTuple env2_id env2_ids (mkBigCoreVarTup out_ids) post_loop_fn <- matchEnvStack later_ids env2_id post_loop_body @@ -1117,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 @@ -1194,7 +1190,7 @@ -- Match a list of expressions against a list of patterns, left-to-right. matchSimplys :: [CoreExpr] -- Scrutinees - -> HsMatchContext GhcRn -- 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 @@ -1202,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) @@ -1219,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 @@ -1237,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,1339 +1,1820 @@ {-# 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, dsEvTerm, dsTcEvBinds, dsTcEvBinds_s, dsEvBinds - , dsWarnOrphanRule - ) -where - -import GHC.Prelude - -import GHC.Driver.Session -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.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.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 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 { (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 - - ; core_wrap <- dsHsWrapper co_fn - ; 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] - - ; ds_ev_binds <- dsTcEvBinds_s ev_binds - - -- 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 { core_wrap <- dsHsWrapper wrap -- 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 { core_wrap <- dsHsWrapper wrap - ; 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 [AbsBinds wrappers] in "GHC.Hs.Binds" - = do { tup_id <- newSysLocalDs ManyTy tup_ty - ; core_wrap <- dsHsWrapper wrap - ; 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 - - ; core_app <- dsHsWrapper spec_app - - ; 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.Utils.Zonk 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.Utils.Zonk". - -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). --} - -dsHsWrapper :: HsWrapper -> DsM (CoreExpr -> CoreExpr) -dsHsWrapper WpHole = return $ \e -> e -dsHsWrapper (WpTyApp ty) = return $ \e -> App e (Type ty) -dsHsWrapper (WpEvLam ev) = return $ Lam ev -dsHsWrapper (WpTyLam tv) = return $ Lam tv -dsHsWrapper (WpLet ev_binds) = do { bs <- dsTcEvBinds ev_binds - ; return (mkCoreLets bs) } -dsHsWrapper (WpCompose c1 c2) = do { w1 <- dsHsWrapper c1 - ; w2 <- dsHsWrapper c2 - ; return (w1 . w2) } -dsHsWrapper (WpFun c1 c2 (Scaled w t1)) -- See Note [Desugaring WpFun] - = do { x <- newSysLocalDs w t1 - ; w1 <- dsHsWrapper c1 - ; w2 <- dsHsWrapper c2 - ; let app f a = mkCoreAppDs (text "dsHsWrapper") f a - arg = w1 (Var x) - ; return (\e -> (Lam x (w2 (app e arg)))) } -dsHsWrapper (WpCast co) = assert (coercionRole co == Representational) $ - return $ \e -> mkCastDs e co -dsHsWrapper (WpEvApp tm) = do { core_tm <- dsEvTerm tm - ; return (\e -> App e core_tm) } - -- See Note [Wrapper returned from tcSubMult] in GHC.Tc.Utils.Unify. -dsHsWrapper (WpMultCoercion co) = do { when (not (isReflexiveCo co)) $ - diagnosticDs DsMultiplicityCoercionsNotSupported - ; return $ \e -> e } --------------------------------------- -dsTcEvBinds_s :: [TcEvBinds] -> DsM [CoreBind] -dsTcEvBinds_s [] = return [] -dsTcEvBinds_s (b:rest) = assert (null rest) $ -- Zonker ensures null - dsTcEvBinds b - -dsTcEvBinds :: TcEvBinds -> DsM [CoreBind] -dsTcEvBinds (TcEvBinds {}) = panic "dsEvBinds" -- Zonker has got rid of this -dsTcEvBinds (EvBinds bs) = dsEvBinds bs - -dsEvBinds :: Bag EvBind -> DsM [CoreBind] -dsEvBinds bs - = do { ds_bs <- mapBagM dsEvBind bs - ; return (mk_ev_binds ds_bs) } - -mk_ev_binds :: Bag (Id,CoreExpr) -> [CoreBind] --- 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. -mk_ev_binds ds_binds - = map ds_scc (stronglyConnCompFromEdgedVerticesUniq edges) - where - edges :: [ Node EvVar (EvVar,CoreExpr) ] - edges = foldr ((:) . mk_node) [] ds_binds - - mk_node :: (Id, CoreExpr) -> Node EvVar (EvVar,CoreExpr) - mk_node b@(var, rhs) - = DigraphNode { node_payload = b - , node_key = var - , node_dependencies = nonDetEltsUniqSet $ - exprFreeVars rhs `unionVarSet` - coVarsOfType (varType var) } - -- It's OK to use nonDetEltsUniqSet 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. - - ds_scc (AcyclicSCC (v,r)) = NonRec v r - ds_scc (CyclicSCC prs) = Rec prs - -dsEvBind :: EvBind -> DsM (Id, CoreExpr) -dsEvBind (EvBind { eb_lhs = v, eb_rhs = r}) = liftM ((,) v) (dsEvTerm r) - - -{-********************************************************************** -* * - 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 { ds_ev_binds <- dsTcEvBinds 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 - ; 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 - ; return expr - } - -ds_ev_typeable ty (EvTypeableTrFun evm ev1 ev2) - | Just (_af,m,t1,t2) <- splitFunTy_maybe ty - = do { e1 <- getRep ev1 t1 - ; e2 <- getRep ev2 t2 - ; em <- getRep evm m - ; mkTrFun <- dsLookupGlobalId mkTrFunName - -- mkTrFun :: forall (m :: Multiplicity) r1 r2 (a :: TYPE r1) (b :: TYPE r2). - -- TypeRep m -> TypeRep a -> TypeRep b -> TypeRep (a % m -> b) - ; let r1 = getRuntimeRep t1 - r2 = getRuntimeRep t2 - ; return $ mkApps (mkTyApps (Var mkTrFun) [m, r1, r2, t1, t2]) - [ em, e1, e2 ] - } - -ds_ev_typeable ty (EvTypeableTyLit ev) - = -- See Note [Typeable for Nat and Symbol] in GHC.Tc.Solver.Interact +{-# 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 + } + +ds_ev_typeable ty (EvTypeableTrFun evm ev1 ev2) + | Just (_af,m,t1,t2) <- splitFunTy_maybe ty + = do { e1 <- getRep ev1 t1 + ; e2 <- getRep ev2 t2 + ; em <- getRep evm m + ; mkTrFun <- dsLookupGlobalId mkTrFunName + -- mkTrFun :: forall (m :: Multiplicity) r1 r2 (a :: TYPE r1) (b :: TYPE r2). + -- TypeRep m -> TypeRep a -> TypeRep b -> TypeRep (a % m -> b) + ; let r1 = getRuntimeRep t1 + r2 = getRuntimeRep t2 + ; return $ mkApps (mkTyApps (Var mkTrFun) [m, r1, r2, t1, t2]) + [ em, e1, e2 ] + } + +ds_ev_typeable ty (EvTypeableTyLit ev) + = -- See Note [Typeable for Nat and Symbol] in GHC.Tc.Instance.Class do { fun <- dsLookupGlobalId tr_fun ; dict <- dsEvTerm ev -- Of type KnownNat/KnownSymbol ; return (mkApps (mkTyApps (Var fun) [ty]) [ dict ]) } diff --git a/GHC/HsToCore/Binds.hs-boot b/GHC/HsToCore/Binds.hs-boot --- a/GHC/HsToCore/Binds.hs-boot +++ b/GHC/HsToCore/Binds.hs-boot @@ -3,4 +3,4 @@ import GHC.Core ( CoreExpr ) import GHC.Tc.Types.Evidence (HsWrapper) -dsHsWrapper :: HsWrapper -> DsM (CoreExpr -> CoreExpr) +dsHsWrapper :: HsWrapper -> ((CoreExpr -> CoreExpr) -> DsM a) -> DsM a 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,19 +30,20 @@ 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 -import GHC.Driver.Session +import GHC.Driver.DynFlags 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,16 @@ 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 [avail]) + Nothing -> noLoc (DsiExports (sortAvails [])) + + -- This causes the associated data family to be incorrectly documented + -- separately from its class: + -- Nothing -> noLoc (DsiExports [avail]) + + -- This panics on the associated data family: -- Nothing -> panicDoc "mkDocStructureFromDecls: No loc found for" -- (ppr avail) @@ -235,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) @@ -249,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 @@ -263,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] ] @@ -355,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) @@ -372,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 . @@ -405,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 @@ -428,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 @@ -481,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 @@ -497,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. @@ -551,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 @@ -26,10 +26,9 @@ instance Diagnostic DsMessage where type DiagnosticOpts DsMessage = NoDiagnosticOpts - defaultDiagnosticOpts = NoDiagnosticOpts - diagnosticMessage _ = \case - DsUnknownMessage (UnknownDiagnostic @e m) - -> diagnosticMessage (defaultDiagnosticOpts @e) m + diagnosticMessage opts = \case + DsUnknownMessage (UnknownDiagnostic f _ m) + -> diagnosticMessage (f opts) m DsEmptyEnumeration -> mkSimpleDecorated $ text "Enumeration is empty" DsIdentitiesFound conv_fn type_of_conv @@ -84,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 @@ -112,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 $ @@ -168,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 $ @@ -208,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 @@ -221,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 @@ -238,6 +275,7 @@ DsRecBindsNotAllowedForUnliftedTys{} -> ErrorWithoutFlag DsRuleMightInlineFirst{} -> WarningWithFlag Opt_WarnInlineRuleShadowing DsAnotherRuleMightFireFirst{} -> WarningWithFlag Opt_WarnInlineRuleShadowing + DsIncompleteRecordSelector{} -> WarningWithFlag Opt_WarnIncompleteRecordSelectors diagnosticHints = \case DsUnknownMessage m -> diagnosticHints m @@ -257,9 +295,7 @@ DsMaxPmCheckModelsReached{} -> [SuggestIncreaseMaxPmCheckModels] DsNonExhaustivePatterns{} -> noHints DsTopLevelBindsNotAllowed{} -> noHints - DsUselessSpecialiseForClassMethodSelector{} -> noHints - DsUselessSpecialiseForNoInlineFunction{} -> noHints - DsMultiplicityCoercionsNotSupported -> noHints + DsUselessSpecialisePragma{} -> noHints DsOrphanRule{} -> noHints DsRuleLhsTooComplicated{} -> noHints DsRuleIgnoredDueToConstructor{} -> noHints @@ -274,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] @@ -299,11 +336,11 @@ 2 (quotes (ppr elt_ty)) -- Print a single clause (for redundant/with-inaccessible-rhs) -pprEqn :: HsMatchContext GhcRn -> 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 GhcRn -> 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,8 +9,10 @@ import GHC.Core (CoreRule, CoreExpr, RuleName) import GHC.Core.DataCon +import GHC.Core.ConLike import GHC.Core.Type -import GHC.Driver.Session +import GHC.Driver.DynFlags (DynFlags, xopt) +import GHC.Driver.Flags (WarningFlag) import GHC.Hs import GHC.HsToCore.Pmc.Solver.Types import GHC.Types.Basic (Activation) @@ -29,7 +32,7 @@ -- | Diagnostics messages emitted during desugaring. data DsMessage -- | Simply wraps a generic 'Diagnostic' message. - = DsUnknownMessage UnknownDiagnostic + = DsUnknownMessage (UnknownDiagnosticFor DsMessage) {-| DsEmptyEnumeration is a warning (controlled by the -Wempty-enumerations flag) that is emitted if an enumeration is empty. @@ -84,18 +87,18 @@ -- FIXME(adn) Use a proper type instead of 'SDoc', but unfortunately -- 'SrcInfo' gives us an 'SDoc' to begin with. - | DsRedundantBangPatterns !(HsMatchContext GhcRn) !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 GhcRn) !SDoc + | DsOverlappingPatterns !HsMatchContextRn !SDoc -- FIXME(adn) Use a proper type instead of 'SDoc' - | DsInaccessibleRhs !(HsMatchContext GhcRn) !SDoc + | DsInaccessibleRhs !HsMatchContextRn !SDoc | DsMaxPmCheckModelsReached !MaxPmCheckModels - | DsNonExhaustivePatterns !(HsMatchContext GhcRn) + | DsNonExhaustivePatterns !HsMatchContextRn !ExhaustivityCheckType !MaxUncoveredPatterns [Id] @@ -103,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 @@ -146,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) @@ -154,7 +183,7 @@ -- | Why TemplateHaskell rejected the splice. Used in the 'DsNotYetHandledByTH' -- constructor of a 'DsMessage'. data ThRejectionReason - = ThAmbiguousRecordUpdates !(HsRecUpdField GhcRn) + = ThAmbiguousRecordUpdates !(HsRecUpdField GhcRn GhcRn) | ThAbstractClosedTypeFamily !(LFamilyDecl GhcRn) | ThForeignLabel !CLabelString | ThForeignExport !(LForeignDecl GhcRn) @@ -175,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 @@ -28,45 +29,54 @@ import GHC.HsToCore.Utils import GHC.HsToCore.Arrows import GHC.HsToCore.Monad -import GHC.HsToCore.Pmc ( addTyCs, pmcGRHSs ) +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 -import GHC.HsToCore.Ticks (stripTicksTopHsExpr) {- ************************************************************************ @@ -86,32 +96,36 @@ -- 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" ------------------------- dsIPBinds :: HsIPBinds GhcTc -> CoreExpr -> DsM CoreExpr dsIPBinds (IPBinds ev_binds ip_binds) body - = do { ds_binds <- dsTcEvBinds ev_binds - ; let inner = mkCoreLets ds_binds body + = do { dsTcEvBinds ev_binds $ \ ds_binds -> do + { let inner = mkCoreLets ds_binds body -- The dict bindings may not be in -- dependency order; hence Rec - ; foldrM ds_ip_bind inner ip_binds } + ; 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 = [] @@ -182,8 +227,8 @@ bind_export export b = bindNonRec (abe_poly export) (Var (abe_mono export)) b ; body2 <- foldlM (\body lbind -> dsUnliftedBind (unLoc lbind) body) body1 lbinds - ; ds_binds <- dsTcEvBinds_s ev_binds - ; return (mkCoreLets ds_binds body2) } + ; dsTcEvBinds_s ev_binds $ \ ds_binds -> do + { return (mkCoreLets ds_binds body2) } } dsUnliftedBind (FunBind { fun_id = L l fun , fun_matches = matches @@ -191,23 +236,20 @@ }) 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 - ; core_wrap <- dsHsWrapper co_fn -- Can be non-identity (#21516) - ; let rhs' = core_wrap (mkOptTickBox tick rhs) - ; return (bindNonRec fun rhs' body) } + ; 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 +dsUnliftedBind (PatBind { pat_lhs = pat, pat_rhs = grhss , pat_ext = (ty, _) }) body = -- let C x# y# = rhs in body -- ==> 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) @@ -223,36 +265,26 @@ ************************************************************************ -} - --- | Replace the body of the function with this block to test the hsExprType --- function in GHC.Tc.Utils.Zonk: --- putSrcSpanDs loc $ do --- { core_expr <- dsExpr e --- ; massertPpr (exprType core_expr `eqType` hsExprType e) --- (ppr e <+> dcolon <+> ppr (hsExprType e) $$ --- ppr core_expr <+> dcolon <+> ppr (exprType core_expr)) --- ; return core_expr } +-- | Desugar a located typechecked expression. dsLExpr :: LHsExpr GhcTc -> DsM CoreExpr -dsLExpr (L loc e) = - putSrcSpanDsA loc $ dsExpr e +dsLExpr (L loc e) = putSrcSpanDsA loc $ dsExpr e +-- | 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 @@ -260,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 @@ -281,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 @@ -291,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"] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -351,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 @@ -370,28 +399,37 @@ 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 _ discrim matches) +dsExpr (HsCase ctxt discrim matches) = do { core_discrim <- dsLExpr discrim - ; ([discrim_var], matching_code) <- matchWrapper CaseAlt (Just [discrim]) matches + ; ([discrim_var], matching_code) <- matchWrapper ctxt (Just [discrim]) matches ; return (bindNonRec discrim_var core_discrim matching_code) } -- 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 @@ -400,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 @@ -413,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) @@ -427,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 } @@ -485,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') @@ -502,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 @@ -521,49 +542,425 @@ -- 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 - ; core_arg_wraps <- mapM dsHsWrapper arg_wraps - ; core_res_wrap <- dsHsWrapper res_wrap - ; 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] findField rbinds sel = [hfbRHS fld | L _ fld <- rbinds - , sel == idName (hsRecFieldId fld) ] + , sel == idName (hsRecFieldId fld) ] {- %-------------------------------------------------------------------- +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 @@ -669,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" @@ -682,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] } @@ -691,45 +1096,19 @@ ; dsLocalBinds binds rest } go _ (BindStmt xbs pat rhs) stmts - = do { body <- goL stmts - ; rhs' <- dsLExpr rhs - ; var <- selectSimpleMatchVarL (xbstc_boundResultMult xbs) pat + -- 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 - (xbstc_boundResultType xbs) (cantFailMatchResult body) - ; match_code <- dsHandleMonadicFailure ctx pat match (xbstc_failOp xbs) + (xbstc_boundResultType xbs) (MR_Infallible $ goL stmts) + -- 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 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 @@ -755,11 +1134,12 @@ later_pats = rec_tup_pats rets = map noLocA rec_rets mfix_app = nlHsSyntaxApps mfix_op [mfix_arg] - 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] - , mg_ext = MatchGroupTc [unrestricted tup_ty] body_ty Generated + (LamAlt LamSingle) + (noLocA [mfix_pat]) body] + , mg_ext = match_group }) mfix_pat = noLocA $ LazyPat noExtField $ mkBigLHsPatTupId rec_tup_pats body = noLocA $ HsDo body_ty @@ -770,53 +1150,87 @@ -- 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" -{- -************************************************************************ -* * - Desugaring Variables -* * -************************************************************************ --} +{- Note [Long-distance information in do notation] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider T21360: -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] + data Foo = A Int | B -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) + swooble :: Foo -> Maybe Foo + swooble foo = do + bar@A{} <- Just foo + return $ case bar of { A _ -> A 9 } --- | 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) } +The pattern-match checker **should not** complain that the case statement +is incomplete, because we know that 'bar' is headed by the constructor 'A', +due to the pattern match in the line above. However, we need to ensure that we +propagate this long-distance information; failing to do so lead to #21360. -{- +To do this, we use "matchSinglePatVar" to handle the first pattern match + + bar@A{} <- Just foo + +"matchSinglePatVar" then threads through the long-distance information to the +desugaring of the remaining statements by using updPmNablasMatchResult. +This avoids any spurious pattern-match warnings when handling the case +statement on the last line. + +Other places that requires from the same treatment: + + - monad comprehensions, e.g. + + blorble :: Foo -> Maybe Foo + blorble foo = [ case bar of { A _ -> A 9 } | bar@A{} <- Just foo ] + + See GHC.HsToCore.ListComp.dsMcBindStmt. Also tested in T21360. + + - guards, e.g. + + giddy :: Maybe Char -> Char + giddy x + | y@(Just _) <- x + , let z = case y of { Just w -> w } + = z + + We don't want any inexhaustive pattern match warnings for the case statement, + because we already know 'y' is of the form "Just ...". + See test case T21360b. + + ************************************************************************ * * \subsection{Errors and contexts} @@ -825,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 { wrap' <- dsHsWrapper wrap - ; let expr = wrap' (varToCoreExpr var) - ty = exprType expr - ; dflags <- getDynFlags - ; warnAboutIdentities dflags var ty - ; return expr } - - go wrap hs_e - = do { wrap' <- dsHsWrapper wrap - ; 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 @@ -42,7 +42,7 @@ import GHC.Unit.Module -import GHC.Driver.Session +import GHC.Driver.DynFlags import GHC.Driver.Config import GHC.Cmm.Expr @@ -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.Session + +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 @@ -33,7 +34,7 @@ import GHC.Types.ForeignCall import GHC.Types.SrcLoc import GHC.Utils.Outputable -import GHC.Driver.Session +import GHC.Driver.DynFlags import GHC.Platform import GHC.Data.OrdList import GHC.Driver.Hooks @@ -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 @@ -50,7 +50,7 @@ import GHC.JS.Ppr -import GHC.Driver.Session +import GHC.Driver.DynFlags import GHC.Driver.Config import GHC.Builtin.Types @@ -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) <> @@ -177,19 +168,19 @@ text "h$foreignExport" <> parens ( ftext c_nm <> comma <> - strlit (unitIdString (moduleUnitId m)) <> comma <> - strlit (moduleNameString (moduleName m)) <> comma <> - strlit (unpackFS c_nm) <> comma <> - strlit type_string + strlit (unitIdFS (moduleUnitId m)) <> comma <> + strlit (moduleNameFS (moduleName m)) <> comma <> + strlit c_nm <> comma <> + strlit (mkFastString type_string) ) <> semi _ -> empty - strlit xs = docToSDoc (pprStringLit (mkFastString xs)) + strlit xs = pprStringLit xs -- 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 @@ -382,16 +363,16 @@ mkHObj :: Type -> SDoc -mkHObj t = text "h$rts_mk" <> text (showFFIType t) +mkHObj t = text "h$rts_mk" <> showFFIType t unpackHObj :: Type -> SDoc -unpackHObj t = text "h$rts_get" <> text (showFFIType t) +unpackHObj t = text "h$rts_get" <> showFFIType t showStgType :: Type -> SDoc -showStgType t = text "Hs" <> text (showFFIType t) +showStgType t = text "Hs" <> showFFIType t -showFFIType :: Type -> String -showFFIType t = getOccString (getName (typeTyCon t)) +showFFIType :: Type -> SDoc +showFFIType t = ftext (occNameFS (getOccName (typeTyCon t))) typeTyCon :: Type -> TyCon typeTyCon ty @@ -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) @@ -639,7 +608,7 @@ | Just (tc,_) <- maybe_tc_app, tc `hasKey` boolTyConKey = do -- result_id <- newSysLocalDs boolTy ccall_uniq <- newUnique - let forceBool e = mkJsCall ccall_uniq "((x) => { return !(!x); })" [e] boolTy + let forceBool e = mkJsCall ccall_uniq (fsLit "((x) => { return !(!x); })") [e] boolTy return (Just intPrimTy, \e -> forceBool e) @@ -674,10 +643,10 @@ maybe_tc_app = splitTyConApp_maybe result_ty -- low-level primitive JavaScript call: -mkJsCall :: Unique -> String -> [CoreExpr] -> Type -> CoreExpr +mkJsCall :: Unique -> FastString -> [CoreExpr] -> Type -> CoreExpr mkJsCall u tgt args t = mkFCall u ccall args t where ccall = CCall $ CCallSpec - (StaticTarget NoSourceText (mkFastString 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 GhcRn +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 GhcRn -> 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) (PatGuard 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 - -> HsStmtContext GhcRn -- 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,41 +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 guard, hence the `Many` + -- 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 ctx) - pat rhs_ty match_result - pure $ bindNonRec match_var core_rhs <$> match_result' + 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 #-} {- @@ -23,7 +23,7 @@ import GHC.HsToCore.Monad -- the monadery used in the desugarer import GHC.HsToCore.Utils -import GHC.Driver.Session +import GHC.Driver.DynFlags import GHC.Core.Utils import GHC.Types.Id import GHC.Core.Type @@ -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,23 +437,21 @@ 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 - - ; unzip_fn <- newSysLocalDs ManyTy unzip_fn_ty + = 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 - ; [us1, us2] <- sequence [newUniqueSupply, newUniqueSupply] + ; 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)) tupled_concat_expression = mkBigCoreTup concat_expressions - folder_body_inner_case = mkBigTupleCase us1 xss tupled_concat_expression (Var axs) - folder_body_outer_case = mkBigTupleCase us2 xs folder_body_inner_case (Var ax) - folder_body = mkLams [ax, axs] folder_body_outer_case + ; folder_body_inner_case <- mkBigTupleCase xss tupled_concat_expression (Var axs) + ; folder_body_outer_case <- mkBigTupleCase xs folder_body_inner_case (Var ax) + ; let folder_body = mkLams [ax, axs] folder_body_outer_case ; unzip_body <- mkFoldrExpr elt_tuple_ty elt_list_tuple_ty folder_body nil_tuple (Var ys) ; return (Just (unzip_fn, mkLams [ys] unzip_body)) } @@ -544,11 +543,10 @@ -- 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 - ; us <- newUniqueSupply ; let rhs' = mkApps usingExpr' usingArgs' - body' = mkBigTupleCase us to_bndrs body tup_n_expr' + ; body' <- mkBigTupleCase to_bndrs body tup_n_expr' ; dsSyntaxExpr bind_op [rhs', Lam n_tup_var' body'] } @@ -567,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 @@ -584,17 +585,17 @@ = do { exp <- dsInnerMonadComp stmts bndrs return_op ; return (exp, mkBigCoreVarTupTy bndrs) } -dsMcStmt stmt _ = 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 -- (matchTuple [a,b,c] body) -- returns the Core term -- \x. case x of (a,b,c) -> body matchTuple ids body - = do { us <- newUniqueSupply - ; tup_id <- newSysLocalDs ManyTy (mkBigCoreVarTupTy ids) - ; return (Lam tup_id $ mkBigTupleCase us ids body (Var tup_id)) } + = do { tup_id <- newSysLocalMDs (mkBigCoreVarTupTy ids) + ; tup_case <- mkBigTupleCase ids body (Var tup_id) + ; return (Lam tup_id tup_case) } -- general `rhs' >>= \pat -> stmts` desugaring where `rhs'` is already a -- desugared `CoreExpr` @@ -606,11 +607,13 @@ -> [ExprLStmt GhcTc] -> DsM CoreExpr dsMcBindStmt pat rhs' bind_op fail_op res1_ty stmts - = do { body <- dsMcStmts stmts - ; var <- selectSimpleMatchVarL ManyTy pat + = do { var <- selectSimpleMatchVarL ManyTy pat ; match <- matchSinglePatVar var Nothing (StmtCtxt (HsDoStmt (DoExpr Nothing))) pat - res1_ty (cantFailMatchResult body) - ; match_code <- dsHandleMonadicFailure MonadComp pat match fail_op + res1_ty (MR_Infallible $ dsMcStmts stmts) + -- 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 res1_ty match fail_op ; dsSyntaxExpr bind_op [rhs', Lam var match_code] } -- Desugar nested monad comprehensions, for example in `then..` constructs @@ -648,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 @@ -1,4 +1,5 @@ +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE MonadComprehensions #-} {-# LANGUAGE OverloadedLists #-} {-# LANGUAGE PatternSynonyms #-} @@ -24,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 ) +import GHC.Types.Basic + import GHC.Types.SourceText -import GHC.Driver.Session + ( 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 @@ -67,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, when ) -import Data.List.NonEmpty (NonEmpty(..)) -import qualified Data.List.NonEmpty as NEL +import Control.Monad ( zipWithM, unless ) +import Data.List.NonEmpty (NonEmpty(..), nonEmpty) +import qualified Data.List.NonEmpty as NE import qualified Data.Map as Map {- @@ -190,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 @@ -221,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']) @@ -239,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" @@ -266,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 - ; core_wrap <- dsHsWrapper co - ; let bind = NonRec var' (core_wrap (Var var)) - ; return (mkCoLetMatchResult bind match_result) } + ; 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 @@ -299,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 @@ -404,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 @@ -423,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[] } @@ -435,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: @@ -454,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)) } @@ -488,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 @@ -543,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 @@ -572,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 @@ -583,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) @@ -736,7 +761,7 @@ -- p2 q2 -> ... matchWrapper - :: HsMatchContext GhcRn -- ^ 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 @@ -771,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)) @@ -783,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. @@ -798,40 +829,35 @@ ; eqns_info <- zipWithM mk_eqn_info matches matches_nablas - ; result_expr <- discard_warnings_if_generated origin $ + ; result_expr <- discard_warnings_if_skip_pmc origin $ matchEquations ctxt new_vars eqns_info rhs_ty ; return (new_vars, result_expr) } 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_generated orig = - if isGenerated orig - then discardWarningsDs - else id + discard_warnings_if_skip_pmc orig = + if requiresPMC orig + then id + else discardWarningsDs initNablasMatches :: Nablas -> [LMatch GhcTc b] -> [(Nablas, NonEmpty Nablas)] initNablasMatches ldi_nablas ms = 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] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -880,7 +906,7 @@ on the user-written case statement). -} -matchEquations :: HsMatchContext GhcRn +matchEquations :: HsMatchContextRn -> [MatchId] -> [EquationInfo] -> Type -> DsM CoreExpr matchEquations ctxt vars eqns_info rhs_ty @@ -894,7 +920,8 @@ -- situation where we want to match a single expression against a single -- pattern. It returns an expression. matchSimply :: CoreExpr -- ^ Scrutinee - -> HsMatchContext GhcRn -- ^ 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 @@ -908,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 GhcRn -> 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 @@ -925,39 +952,47 @@ -- 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 GhcRn -> 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) $ do { dflags <- getDynFlags ; locn <- getSrcSpanDs - -- Pattern match check warnings - ; when (isMatchContextPmChecked dflags FromSource ctx) $ - addCoreScrutTmCs (maybeToList mb_scrut) [var] $ - pmcPatBind (DsMatchContext ctx locn) var (unLoc pat) + -- Pattern match check warnings. + -- See Note [Long-distance information in matchWrapper] and + -- Note [Long-distance information in do notation] in GHC.HsToCore.Expr. + ; ldi_nablas <- + if isMatchContextPmChecked_SinglePat dflags FromSource ctx pat + then addCoreScrutTmCs (maybeToList mb_scrut) [var] $ + pmcPatBind (DsMatchContext ctx locn) var (unLoc pat) + else getLdiNablas - ; let eqn_info = EqnInfo { eqn_pats = [unLoc (decideBangHood dflags pat)] - , eqn_orig = FromSource - , eqn_rhs = 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. + ; match [var] ty [eqn_info] } +updPmNablasMatchResult :: Nablas -> MatchResult r -> MatchResult r +updPmNablasMatchResult nablas = \case + MR_Infallible body_fn -> MR_Infallible $ + updPmNablas nablas body_fn + MR_Fallible body_fn -> MR_Fallible $ \fail -> + updPmNablas nablas $ body_fn fail {- ************************************************************************ @@ -984,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 @@ -1004,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 @@ -1029,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 @@ -1124,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 @@ -1148,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' @@ -1176,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 @@ -1250,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,8 +5,9 @@ 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.Extension ( GhcTc, GhcRn ) +import GHC.Hs ( LPat, MatchGroup, LHsExpr, Mult ) +import GHC.Hs.Expr ( HsMatchContextRn ) +import GHC.Hs.Extension ( GhcTc ) match :: [Id] -> Type @@ -14,14 +15,15 @@ -> DsM (MatchResult CoreExpr) matchWrapper - :: HsMatchContext GhcRn + :: HsMatchContextRn -> Maybe [LHsExpr GhcTc] -> MatchGroup GhcTc (LHsExpr GhcTc) -> DsM ([Id], CoreExpr) matchSimply :: CoreExpr - -> HsMatchContext GhcRn + -> HsMatchContextRn + -> Mult -> LPat GhcTc -> CoreExpr -> CoreExpr @@ -30,7 +32,7 @@ matchSinglePatVar :: Id -> Maybe CoreExpr - -> HsMatchContext GhcRn + -> 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 ( Origin(..) ) 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 - })) - = do ds_bind <- dsTcEvBinds bind - return ( wrapBinds (tvs `zip` tvs1) - . wrapBinds (ds `zip` dicts1) - . mkCoreLets ds_bind - , eqn { eqn_orig = Generated - , eqn_pats = conArgPats val_arg_tys args ++ pats } - ) - shift (_, (EqnInfo { eqn_pats = ps })) = pprPanic "matchOneCon/shift" (ppr ps) + 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 + , prependPats (conArgPats val_arg_tys args) rest + ) + 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 ) @@ -36,7 +36,7 @@ import GHC.Hs -import GHC.Tc.Utils.Zonk ( shortCutLit ) +import GHC.Tc.Utils.TcMType ( shortCutLit ) import GHC.Tc.Utils.TcType import GHC.Core @@ -58,20 +58,18 @@ import GHC.Types.Id import GHC.Types.SourceText -import GHC.Driver.Session +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 @@ -107,7 +105,13 @@ HsCharPrim _ c -> return (Lit (LitChar c)) HsIntPrim _ i -> return (Lit (mkLitIntWrap platform i)) HsWordPrim _ w -> return (Lit (mkLitWordWrap platform w)) + HsInt8Prim _ i -> return (Lit (mkLitInt8Wrap i)) + HsInt16Prim _ i -> return (Lit (mkLitInt16Wrap i)) + HsInt32Prim _ i -> return (Lit (mkLitInt32Wrap i)) HsInt64Prim _ i -> return (Lit (mkLitInt64Wrap i)) + HsWord8Prim _ w -> return (Lit (mkLitWord8Wrap w)) + HsWord16Prim _ w -> return (Lit (mkLitWord16Wrap w)) + HsWord32Prim _ w -> return (Lit (mkLitWord32Wrap w)) HsWord64Prim _ w -> return (Lit (mkLitWord64Wrap w)) -- This can be slow for very large literals. See Note [FractionalLit representation] @@ -116,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] @@ -269,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 () @@ -432,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 @@ -441,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. @@ -454,16 +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 (HsInt64Prim _ i) = Just (i, int64PrimTy) -getSimpleIntegralLit (HsWord64Prim _ i) = Just (i, word64PrimTy) -getSimpleIntegralLit (HsInteger _ i ty) = Just (i, ty) -getSimpleIntegralLit _ = Nothing +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 (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 @@ -588,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 @@ -606,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) } @@ -639,7 +650,13 @@ -- HsLit does not. hsLitKey platform (HsIntPrim _ i) = mkLitIntWrap platform i hsLitKey platform (HsWordPrim _ w) = mkLitWordWrap platform w +hsLitKey _ (HsInt8Prim _ i) = mkLitInt8Wrap i +hsLitKey _ (HsInt16Prim _ i) = mkLitInt16Wrap i +hsLitKey _ (HsInt32Prim _ i) = mkLitInt32Wrap i hsLitKey _ (HsInt64Prim _ i) = mkLitInt64Wrap i +hsLitKey _ (HsWord8Prim _ w) = mkLitWord8Wrap w +hsLitKey _ (HsWord16Prim _ w) = mkLitWord16Wrap w +hsLitKey _ (HsWord32Prim _ w) = mkLitWord32Wrap w hsLitKey _ (HsWord64Prim _ w) = mkLitWord64Wrap w hsLitKey _ (HsCharPrim _ c) = mkLitChar c -- This following two can be slow. See Note [FractionalLit representation] @@ -657,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 @@ -686,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 @@ -695,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, @@ -36,6 +36,9 @@ -- Getting and setting pattern match oracle states getPmNablas, updPmNablas, + -- Tracking evidence variable coherence + addUnspecables, getUnspecables, zapUnspecables, + -- Get COMPLETE sets of a TyCon dsGetCompleteMatches, @@ -45,7 +48,8 @@ -- Data types DsMatchContext(..), - EquationInfo(..), MatchResult (..), runMatchResult, DsWrapper, idDsWrapper, + EquationInfo(..), EquationInfoNE, prependPats, mkEqnInfo, eqnMatchResult, + MatchResult (..), runMatchResult, DsWrapper, idDsWrapper, -- Trace injection pprRuntimeTrace @@ -54,7 +58,7 @@ import GHC.Prelude import GHC.Driver.Env -import GHC.Driver.Session +import GHC.Driver.DynFlags import GHC.Driver.Ppr import GHC.Driver.Config.Diagnostic @@ -88,9 +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 (EvVar) +import GHC.Types.Var.Set( VarSet, emptyVarSet, extendVarSetList ) import GHC.Types.SrcLoc import GHC.Types.TypeEnv import GHC.Types.Unique.Supply @@ -101,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 @@ -109,6 +118,7 @@ import Data.IORef import GHC.Driver.Env.KnotVars +import GHC.IO.Unsafe (unsafeInterleaveIO) {- ************************************************************************ @@ -119,34 +129,50 @@ -} data DsMatchContext - = DsMatchContext (HsMatchContext GhcRn) 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 @@ -238,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 @@ -274,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 } @@ -302,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 @@ -324,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 @@ -349,9 +406,10 @@ , ds_cc_st = cc_st_var , ds_next_wrapper_num = next_wrapper_num } - lcl_env = DsLclEnv { dsl_meta = emptyNameEnv - , dsl_loc = real_span - , dsl_nablas = initNablas + lcl_env = DsLclEnv { dsl_meta = emptyNameEnv + , dsl_loc = real_span + , dsl_nablas = initNablas + , dsl_unspecables = Just emptyVarSet } in (gbl_env, lcl_env) @@ -383,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 @@ -407,6 +472,19 @@ updPmNablas :: Nablas -> DsM a -> DsM a updPmNablas nablas = updLclEnv (\env -> env { dsl_nablas = nablas }) +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) }) + +zapUnspecables :: DsM a -> DsM a +zapUnspecables = updLclEnv (\env -> env{ dsl_unspecables = Nothing }) + +getUnspecables :: DsM (Maybe VarSet) +getUnspecables = dsl_unspecables <$> getLclEnv + getSrcSpanDs :: DsM SrcSpan getSrcSpanDs = do { env <- getLclEnv ; return (RealSrcSpan (dsl_loc env) Strict.Nothing) } @@ -417,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, @@ -486,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, - isMatchContextPmChecked, + 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,30 +51,29 @@ 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.Driver.Session +import GHC.Types.Basic (Origin(..), isDoExpansionGenerated) +import GHC.Core +import GHC.Driver.DynFlags import GHC.Hs import GHC.Types.Id import GHC.Types.SrcLoc 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 @@ -98,26 +98,42 @@ noCheckDs = updTopFlags (\dflags -> foldl' wopt_unset dflags allPmCheckWarnings) -- | Check a pattern binding (let, where) for exhaustiveness. -pmcPatBind :: DsMatchContext -> Id -> Pat GhcTc -> DsM () --- See Note [pmcPatBind only checks PatBindRhs] -pmcPatBind ctxt@(DsMatchContext PatBindRhs loc) var p = do - !missing <- getLdiNablas - pat_bind <- noCheckDs $ desugarPatBind loc var p - tracePm "pmcPatBind {" (vcat [ppr ctxt, ppr var, ppr p, ppr pat_bind, ppr missing]) - result <- unCA (checkPatBind pat_bind) missing - tracePm "}: " (ppr (cr_uncov result)) - formatReportWarnings ReportPatBind ctxt [var] result -pmcPatBind _ _ _ = pure () +pmcPatBind :: DsMatchContext -> Id -> Pat GhcTc -> DsM Nablas +pmcPatBind ctxt@(DsMatchContext match_ctxt loc) var p + = mb_discard_warnings $ do + !missing <- getLdiNablas + pat_bind <- noCheckDs $ desugarPatBind loc var p + tracePm "pmcPatBind {" (vcat [ppr ctxt, ppr var, ppr p, ppr pat_bind, ppr missing]) + result <- unCA (checkPatBind pat_bind) missing + let ldi = ldiGRHS $ ( \ pb -> case pb of PmPatBind grhs -> grhs) $ cr_ret result + tracePm "pmcPatBind }: " $ + vcat [ text "cr_uncov:" <+> ppr (cr_uncov result) + , text "ldi:" <+> ppr ldi ] + formatReportWarnings ReportPatBind ctxt [var] result + return ldi + where + -- See Note [pmcPatBind doesn't warn on pattern guards] + mb_discard_warnings + = if want_pmc match_ctxt + then id + else discardWarningsDs + want_pmc PatBindRhs = True + want_pmc LazyPatCtx = True + want_pmc (StmtCtxt stmt_ctxt) = + case stmt_ctxt of + PatGuard {} -> False + _ -> True + want_pmc _ = False -- | Exhaustive for guard matches, is used for guards in pattern bindings and -- in @MultiIf@ expressions. Returns the 'Nablas' covered by the RHSs. pmcGRHSs - :: HsMatchContext GhcRn -- ^ 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 @@ -146,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] @@ -172,28 +189,232 @@ 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 [pmcPatBind only checks PatBindRhs] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -@pmcPatBind@'s sole purpose is to check vanilla pattern bindings, like +{- +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 @x :: Int; Just x = e@, which is in a @PatBindRhs@ context. But its caller is also called for individual pattern guards in a @StmtCtxt@. For example, both pattern guards in @f x y | True <- x, False <- y = ...@ will -go through this function. It makes no sense to do coverage checking there: +go through this function. It makes no sense to report pattern match warnings +for these pattern guards: + * Pattern guards may well fail. Fall-through is not an unrecoverable panic, but rather behavior the programmer expects, so inexhaustivity should not be reported. + * Redundancy is already reported for the whole GRHS via one of the other - exported coverage checking functions. Also reporting individual redundant + exported coverage checking functions. Also, reporting individual redundant guards is... redundant. See #17646. -Note that we can't just omit checking of @StmtCtxt@ altogether (by adjusting -'isMatchContextPmChecked'), because that affects the other checking functions, -too. + +However, we should not skip pattern-match checking altogether, as it may reveal +important long-distance information. One example is described in +Note [Long-distance information in do notation] in GHC.HsToCore.Expr. + +Instead, we simply discard warnings when in pattern-guards, by using the function +discardWarningsDs. -} -- @@ -403,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 @@ -412,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: @@ -428,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 @@ -29,36 +29,51 @@ import GHC.HsToCore.Pmc.Types import GHC.HsToCore.Pmc.Utils import GHC.HsToCore.Pmc.Solver -import GHC.Driver.Session +import GHC.Driver.DynFlags 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,15 +20,14 @@ 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.Session +import GHC.Driver.DynFlags import GHC.Hs -import GHC.Tc.Utils.Zonk (shortCutLit) +import GHC.Tc.Utils.TcMType (shortCutLit) import GHC.Types.Id 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) +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 @@ -92,7 +87,7 @@ -- 'GHC.HsToCore.Pmc.Solver.addRefutableAltCon', but it's so much simpler -- here. See Note [Representation of Strings in TmState] in -- GHC.HsToCore.Pmc.Solver - vars <- traverse mkPmId (take (lengthFS s) (repeat charTy)) + vars <- replicateM (lengthFS s) (mkPmId charTy) let mk_char_lit y c = mkPmLitGrds y (PmLit charTy (PmLitChar c)) char_grdss <- zipWithM mk_char_lit vars (unpackFS s) mkListGrds x (zip vars char_grdss) @@ -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 @@ -154,25 +153,21 @@ | WpCast co <- wrapper, isReflexiveCo co -> desugarPat x p | otherwise -> do (y, grds) <- desugarPatV p - wrap_rhs_y <- dsHsWrapper wrapper - pure (PmLet y (wrap_rhs_y (Var x)) : grds) - - -- (n + k) ===> let b = x >= k, True <- b, let n = x-k + dsHsWrapper wrapper $ \wrap_rhs_y -> + 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,33 +36,35 @@ import GHC.HsToCore.Pmc.Types import GHC.HsToCore.Pmc.Utils (tracePm, traceWhenFailPm, mkPmId) +import GHC.HsToCore.Types (DsGblEnv(..)) -import GHC.Driver.Session +import GHC.Driver.DynFlags import GHC.Driver.Config import GHC.Utils.Outputable 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.Basic (Levity(..)) import GHC.Types.CompleteMatch import GHC.Types.Unique.Set import GHC.Types.Unique.DSet 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) @@ -93,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 -- @@ -130,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 @@ -145,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. @@ -153,8 +155,8 @@ tc == tYPETyCon = Just [] | -- Similarly, treat `type data` declarations as empty data types on -- the term level, as `type data` data constructors only exist at - -- the type level (#22964). - -- See Note [Type data declarations] in GHC.Rename.Module. + -- the type level (#22964). See wrinkle (W2a) in + -- Note [Type data declarations] in GHC.Rename.Module. isTypeDataTyCon tc = Just [] | otherwise = tyConDataCons_maybe tc in vanillaCompleteMatch . mkUniqDSet . map RealDataCon <$> mb_dcs @@ -195,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: @@ -362,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. @@ -610,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 @@ -646,8 +647,7 @@ nameTyCt pred_ty = do unique <- getUniqueM let occname = mkVarOccFS (fsLit ("pm_"++show unique)) - idname = mkInternalName unique occname noSrcSpan - return (mkLocalIdOrCoVar idname ManyTy pred_ty) + return (mkUserLocalOrCoVar occname unique ManyTy pred_ty noSrcSpan) ----------------------------- -- ** Adding term constraints @@ -679,8 +679,8 @@ filterUnliftedFields :: PmAltCon -> [Id] -> [Id] filterUnliftedFields con args = - [ arg | (arg, bang) <- zipEqual "addPhiCt" args (pmAltConImplBangs con) - , isBanged bang || typeLevity_maybe (idType arg) == Just Unlifted ] + [ 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@ -- surely diverges. Quite similar to 'addConCt', only that it only cares about @@ -692,7 +692,7 @@ IsNotBot -> mzero -- There was x ≁ ⊥. Contradiction! IsBot -> pure nabla -- There already is x ~ ⊥. Nothing left to do MaybeBot -- We add x ~ ⊥ - | Just Unlifted <- typeLevity_maybe (idType x) + | definitelyUnliftedType (idType x) -- Case (3) in Note [Strict fields and variables of unlifted type] -> mzero -- unlifted vars can never be ⊥ | otherwise @@ -786,7 +786,7 @@ let ty_cts = equateTys (map mkTyVarTy tvs) (map mkTyVarTy other_tvs) nabla' <- MaybeT $ addPhiCts nabla (listToBag ty_cts) let add_var_ct nabla (a, b) = addVarCt nabla a b - foldlM add_var_ct nabla' $ zipEqual "addConCt" args other_args + foldlM add_var_ct nabla' $ zipEqual args other_args Nothing -> do let pos' = PACA alt tvs args : pos let nabla_with bot' = @@ -803,8 +803,8 @@ equateTys :: [Type] -> [Type] -> [PhiCt] equateTys ts us = - [ PhiTyCt (mkPrimEqPred t u) - | (t, u) <- zipEqual "equateTys" ts us + [ PhiTyCt (mkNomEqPred t u) + | (t, u) <- zipEqual ts us -- The following line filters out trivial Refl constraints, so that we don't -- need to initialise the type oracle that often , not (eqType t u) @@ -1413,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 @@ -1426,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 @@ -1470,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, @@ -1964,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 @@ -1984,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 @@ -2007,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 @@ -8,14 +8,15 @@ tracePm, traceWhenFailPm, mkPmId, allPmCheckWarnings, overlapping, exhaustive, redundantBang, exhaustiveWarningFlag, - isMatchContextPmChecked, needToRunPmCheck + isMatchContextPmChecked, isMatchContextPmChecked_SinglePat, + needToRunPmCheck ) where import GHC.Prelude -import GHC.Types.Basic (Origin(..), isGenerated) -import GHC.Driver.Session +import GHC.Types.Basic (Origin(..), requiresPMC) +import GHC.Driver.DynFlags import GHC.Hs import GHC.Core.Type import GHC.Data.FastString @@ -25,7 +26,6 @@ import GHC.Types.Name import GHC.Types.Unique.Supply import GHC.Types.SrcLoc -import GHC.Utils.Misc import GHC.Utils.Outputable import GHC.Utils.Logger import GHC.HsToCore.Monad @@ -51,8 +51,7 @@ mkPmId :: Type -> DsM Id mkPmId ty = getUniqueM >>= \unique -> let occname = mkVarOccFS $ fsLit "pm" - name = mkInternalName unique occname noSrcSpan - in return (mkLocalIdOrCoVar name ManyTy ty) + in return (mkUserLocalOrCoVar occname unique ManyTy ty noSrcSpan) {-# NOINLINE mkPmId #-} -- We'll CPR deeply, that should be enough -- | All warning flags that need to run the pattern match checker. @@ -62,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 @@ -81,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 @@ -100,33 +101,45 @@ 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 dflags origin kind - | isGenerated origin +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 fn -> LPat GhcTc -> Bool +isMatchContextPmChecked_SinglePat dflags origin ctxt pat + | not (needToRunPmCheck dflags origin) = False + | StmtCtxt {} <- ctxt + -- For @StmtCtxt@, we are interested in propagating pattern-match information + -- but not in the actual outcome of pattern-match checking, so we skip + -- if the pattern is "boring" (gives rise to no long-distance information). + -- (This is done purely for runtime performance.) + = not (isBoringHsPat pat) -- See Note [Boring patterns] in GHC.Hs.Pat. | otherwise - = overlapping dflags kind || exhaustive dflags kind + = overlapping dflags ctxt || exhaustive dflags ctxt -- | Return True when any of the pattern match warnings ('allPmCheckWarnings') -- are enabled, in which case we need to run the pattern match checker. needToRunPmCheck :: DynFlags -> Origin -> Bool needToRunPmCheck dflags origin - | isGenerated origin - = False - | otherwise - = notNull (filter (`wopt` dflags) allPmCheckWarnings) + = requiresPMC origin + && any (`wopt` dflags) allPmCheckWarnings {- Note [Inaccessible warnings for record updates] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider (#12957) +Consider (#12957): + data T a where T1 :: { x :: Int } -> T Bool T2 :: { x :: Int } -> T a @@ -135,8 +148,9 @@ f :: T Char -> T a f r = r { x = 3 } -The desugarer will conservatively generate a case for T1 even though -it's impossible: +In GHC.Tc.Gen.Expr.desugarRecordUpd, we will conservatively generate a case +for T1 even though it's impossible: + f r = case r of T1 x -> T1 3 -- Inaccessible branch T2 x -> T2 3 @@ -144,13 +158,14 @@ We don't want to warn about the inaccessible branch because the programmer didn't put it there! So we filter out the warning here. +The test case T12957a checks this. The same can happen for long distance term constraints instead of type constraints (#17783): - data T = A { x :: Int } | B { x :: Int } + data T = A { x :: Int } | B f r@A{} = r { x = 3 } - f _ = B 0 + f _ = B Here, the long distance info from the FunRhs match (@r ~ A x@) will make the clause matching on @B@ of the desugaring to @case@ redundant. It's generated diff --git a/GHC/HsToCore/Quote.hs b/GHC/HsToCore/Quote.hs --- a/GHC/HsToCore/Quote.hs +++ b/GHC/HsToCore/Quote.hs @@ -2,7 +2,9 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE MultiWayIf #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -10,8 +12,6 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} - ----------------------------------------------------------------------------- -- -- (c) The University of Glasgow 2006 @@ -32,7 +32,7 @@ import GHC.Prelude import GHC.Platform -import GHC.Driver.Session +import GHC.Driver.DynFlags import GHC.HsToCore.Errors.Types import {-# SOURCE #-} GHC.HsToCore.Expr ( dsExpr ) @@ -40,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 @@ -59,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 @@ -94,12 +94,11 @@ import Data.ByteString ( unpack ) import Control.Monad import Data.List (sort, sortBy) -import Data.List.NonEmpty ( NonEmpty(..) ) +import Data.List.NonEmpty ( NonEmpty(..), toList ) import Data.Function import Control.Monad.Trans.Reader import Control.Monad.Trans.Class -import Data.Foldable ( toList ) -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` @@ -121,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))) @@ -143,9 +142,9 @@ mkWpTyApps [m_var] tyWrapper t = mkAppTy m_var t debug = (quoteWrapper, monadWrapper, m_var) - q_f <- dsHsWrapper quoteWrapper - m_f <- dsHsWrapper monadWrapper - return (MetaWrappers q_f m_f tyWrapper debug) + dsHsWrapper quoteWrapper $ \q_f -> do { + dsHsWrapper monadWrapper $ \m_f -> do { + return (MetaWrappers q_f m_f tyWrapper debug) } } -- Turn A into m A wrapName :: Name -> MetaM Type @@ -177,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. @@ -285,7 +284,7 @@ , hs_docs = docs }) = do { let { bndrs = hsScopedTvBinders valds ++ hsGroupBinders group - ++ map foExt (hsPatSynSelectors valds) + ++ map (unLoc . foLabel) (hsPatSynSelectors valds) ; instds = tyclds >>= group_instds } ; ss <- mkGenSyms bndrs ; @@ -513,7 +512,7 @@ ------------------------- repDataDefn :: Core TH.Name - -> Either (Core [(M (TH.TyVarBndr ()))]) + -> Either (Core [(M (TH.TyVarBndr TH.BndrVis))]) -- the repTyClD case (Core (Maybe [(M (TH.TyVarBndr ()))]), Core (M TH.Type)) -- the repDataFamInstD case @@ -536,7 +535,7 @@ derivs1 } } -repSynDecl :: Core TH.Name -> Core [(M (TH.TyVarBndr ()))] +repSynDecl :: Core TH.Name -> Core [(M (TH.TyVarBndr TH.BndrVis))] -> LHsType GhcRn -> MetaM (Core (M TH.Dec)) repSynDecl tc bndrs ty @@ -550,11 +549,9 @@ , fdResultSig = L _ resultSig , fdInjectivityAnn = injectivity })) = do { tc1 <- lookupLOcc tc -- See Note [Binders and occurrences] - ; let resTyVar = case resultSig of - TyVarSig _ bndr -> [hsLTyVarName bndr] - _ -> [] + ; let res_tv = resultVariableName resultSig ; dec <- addQTyVarBinds ReuseBoundNames tvs $ \bndrs -> - addSimpleTyVarBinds ReuseBoundNames resTyVar $ + addSimpleTyVarBinds ReuseBoundNames (maybeToList res_tv) $ case info of ClosedTypeFamily Nothing -> notHandled (ThAbstractClosedTypeFamily decl) @@ -693,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 } @@ -724,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)) @@ -781,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] @@ -885,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 @@ -922,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 @@ -995,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) @@ -1007,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 @@ -1017,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}) = @@ -1097,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 @@ -1121,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 @@ -1143,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' @@ -1179,9 +1231,20 @@ rep_flag SpecifiedSpec = rep2_nw specifiedSpecName [] rep_flag InferredSpec = rep2_nw inferredSpecName [] +instance RepTV (HsBndrVis GhcRn) TH.BndrVis where + tyVarBndrName = tyVarBndrVisTyConName + repPlainTV (MkC nm) vis = do { (MkC vis') <- rep_bndr_vis vis + ; rep2 plainBndrTVName [nm, vis'] } + repKindedTV (MkC nm) vis (MkC ki) = do { (MkC vis') <- rep_bndr_vis vis + ; rep2 kindedBndrTVName [nm, vis', ki] } + +rep_bndr_vis :: HsBndrVis GhcRn -> MetaM (Core TH.BndrVis) +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 @@ -1195,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} -> @@ -1204,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'. @@ -1284,7 +1336,7 @@ addQTyVarBinds :: FreshOrReuse -> LHsQTyVars GhcRn -- the binders to be added - -> (Core [(M (TH.TyVarBndr ()))] -> MetaM (Core (M a))) -- action in the ext env + -> (Core [(M (TH.TyVarBndr TH.BndrVis))] -> MetaM (Core (M a))) -- action in the ext env -> MetaM (Core (M a)) addQTyVarBinds fresh_or_reuse qtvs thing_inside = let HsQTvs { hsq_ext = imp_tvs @@ -1309,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)) @@ -1370,20 +1430,22 @@ 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 @@ -1393,16 +1455,17 @@ ty1 <- repLTy ty ki1 <- repLTy ki repTappKind ty1 ki1 -repTy (HsFunTy _ w f a) | isUnrestricted w = do - f1 <- repLTy f - a1 <- repLTy a +repTy (HsFunTy _ w f a) = do + f1 <- repLTy f + a1 <- repLTy a + case multAnnToHsType w of + Nothing -> do tcon <- repArrowTyCon repTapps tcon [f1, a1] -repTy (HsFunTy _ w f a) = do w1 <- repLTy (arrowToHsType w) - f1 <- repLTy f - a1 <- repLTy a - tcon <- repMulArrowTyCon - repTapps tcon [w1, f1, a1] + Just m -> do + w1 <- repLTy m + tcon <- repMulArrowTyCon + repTapps tcon [w1, f1, a1] repTy (HsListTy _ t) = do t1 <- repLTy t tcon <- repListTyCon @@ -1417,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 @@ -1430,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 @@ -1499,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 @@ -1507,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 } @@ -1541,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) })) @@ -1555,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)) @@ -1605,18 +1670,18 @@ ; 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 = Left flds }) +repE (RecordUpd { rupd_expr = e, rupd_flds = RegularRecUpdFields { recUpdFields = flds } }) = do { x <- repLE e; fs <- repUpdFields flds; repRecUpd x fs } -repE (RecordUpd { rupd_flds = Right _ }) +repE e@(RecordUpd { rupd_flds = OverloadedRecUpdFields {} }) = do -- Not possible due to elimination in the renamer. See Note -- [Handling overloaded and rebindable constructs] - panic "The impossible has happened!" + pprPanic "repE: unexpected overloaded record update" $ ppr e repE (ExprWithTySig _ e wc_ty) = addSimpleTyVarBinds FreshNamesOnly (get_scoped_tvs_from_sig sig_ty) $ @@ -1643,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 @@ -1684,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 { @@ -1701,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 { @@ -1715,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) @@ -1745,15 +1849,23 @@ ; e <- repLE (hfbRHS fld) ; repFieldExp fn e } -repUpdFields :: [LHsRecUpdField GhcRn] -> MetaM (Core [M TH.FieldExp]) +repUpdFields :: [LHsRecUpdField GhcRn GhcRn] -> MetaM (Core [M TH.FieldExp]) repUpdFields = repListM fieldExpTyConName rep_fld where - rep_fld :: LHsRecUpdField GhcRn -> MetaM (Core (M TH.FieldExp)) - rep_fld (L l fld) = case unLoc (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 :: LHsRecUpdField GhcRn GhcRn -> MetaM (Core (M TH.FieldExp)) + 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 + } @@ -1806,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) @@ -1879,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 @@ -1898,13 +2010,19 @@ { fun_id = fn, fun_matches = MG { mg_alts = (L _ [L _ (Match - { m_pats = [] - , m_grhss = GRHSs _ guards wheres } - )]) } })) + { m_pats = L _ [] + , m_grhss = GRHSs _ guards wheres + -- For a variable declaration I'm pretty + -- sure we always have a FunRhs + , m_ctxt = FunRhs { mc_strictness = strictessAnn } + } )]) } })) = do { (ss,wherecore) <- repBinds wheres ; guardcore <- addBinds ss (repGuards guards) ; fn' <- lookupNBinder fn - ; p <- repPvar fn' + ; p <- repPvar fn' >>= case strictessAnn of + SrcLazy -> repPtilde + SrcStrict -> repPbang + NoSrcStrict -> pure ; ans <- repVal p guardcore wherecore ; ans' <- wrapGenSyms ss ans ; return (locA loc, ans') } @@ -1925,15 +2043,6 @@ ; ans' <- wrapGenSyms ss ans ; return (locA loc, ans') } -rep_bind (L _ (VarBind { var_id = v, var_rhs = e})) - = do { v' <- lookupBinder v - ; e2 <- repLE e - ; x <- repNormal e2 - ; patcore <- repPvar v' - ; empty_decls <- coreListM decTyConName [] - ; ans <- repVal patcore x empty_decls - ; return (srcLocSpan (getSrcLoc v), ans) } - rep_bind (L loc (PatSynBind _ (PSB { psb_id = syn , psb_args = args , psb_def = pat @@ -1955,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 } @@ -1972,6 +2081,8 @@ wrapGenArgSyms (RecCon _) _ dec = return dec wrapGenArgSyms _ ss dec = wrapGenSyms ss dec +rep_bind (L _ (VarBind { var_ext = x })) = dataConCantHappen x + repPatSynD :: Core TH.Name -> Core (M TH.PatSynArgs) -> Core (M TH.PatSynDir) @@ -1981,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) @@ -1989,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 @@ -2039,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 @@ -2062,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) @@ -2071,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 } @@ -2081,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; @@ -2112,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) @@ -2179,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 @@ -2211,21 +2332,25 @@ globalVarExternal :: Module -> OccName -> DsM (Core TH.Name) globalVarExternal mod name_occ - = do { - - ; MkC mod <- coreStringLit name_mod + = do { MkC mod <- coreStringLit name_mod ; MkC pkg <- coreStringLit name_pkg ; MkC occ <- occNameLit name_occ - ; rep2_nwDsM mk_varg [pkg,mod,occ] } + ; if | isDataOcc name_occ + -> rep2_nwDsM mkNameG_dName [pkg,mod,occ] + | isVarOcc name_occ + -> rep2_nwDsM mkNameG_vName [pkg,mod,occ] + | isTcOcc name_occ + -> rep2_nwDsM mkNameG_tcName [pkg,mod,occ] + | Just con_fs <- fieldOcc_maybe name_occ + -> do { MkC con <- coreStringLit con_fs + ; rep2_nwDsM mkNameG_fldName [pkg,mod,con,occ] } + | otherwise + -> pprPanic "GHC.HsToCore.Quote.globalVar" (ppr name_occ) + } where name_mod = moduleNameFS (moduleName mod) name_pkg = unitFS (moduleUnit mod) - mk_varg | isDataOcc name_occ = mkNameG_dName - | isVarOcc name_occ = mkNameG_vName - | isTcOcc name_occ = mkNameG_tcName - | otherwise = pprPanic "GHC.HsToCore.Quote.globalVar" (ppr name_occ) - lookupType :: Name -- Name of type constructor (e.g. (M TH.Exp)) -> MetaM Type -- The type lookupType tc_name = do { tc <- lift $ dsLookupTyCon tc_name ; @@ -2361,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 @@ -2384,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] @@ -2537,7 +2674,7 @@ repData :: Bool -- ^ @True@ for a @type data@ declaration. -- See Note [Type data declarations] in GHC.Rename.Module -> Core (M TH.Cxt) -> Core TH.Name - -> Either (Core [(M (TH.TyVarBndr ()))]) + -> Either (Core [(M (TH.TyVarBndr TH.BndrVis))]) (Core (Maybe [(M (TH.TyVarBndr ()))]), Core (M TH.Type)) -> Core (Maybe (M TH.Kind)) -> Core [(M TH.Con)] -> Core [M TH.DerivClause] -> MetaM (Core (M TH.Dec)) @@ -2549,7 +2686,7 @@ = rep2 dataInstDName [cxt, mb_bndrs, ty, ksig, cons, derivs] repNewtype :: Core (M TH.Cxt) -> Core TH.Name - -> Either (Core [(M (TH.TyVarBndr ()))]) + -> Either (Core [(M (TH.TyVarBndr TH.BndrVis))]) (Core (Maybe [(M (TH.TyVarBndr ()))]), Core (M TH.Type)) -> Core (Maybe (M TH.Kind)) -> Core (M TH.Con) -> Core [M TH.DerivClause] -> MetaM (Core (M TH.Dec)) @@ -2560,7 +2697,7 @@ (MkC derivs) = rep2 newtypeInstDName [cxt, mb_bndrs, ty, ksig, con, derivs] -repTySyn :: Core TH.Name -> Core [(M (TH.TyVarBndr ()))] +repTySyn :: Core TH.Name -> Core [(M (TH.TyVarBndr TH.BndrVis))] -> Core (M TH.Type) -> MetaM (Core (M TH.Dec)) repTySyn (MkC nm) (MkC tvs) (MkC rhs) = rep2 tySynDName [nm, tvs, rhs] @@ -2613,12 +2750,19 @@ Overlapping _ -> just =<< dataCon overlappingDataConName Overlaps _ -> just =<< dataCon overlapsDataConName Incoherent _ -> just =<< dataCon incoherentDataConName + NonCanonical _ -> just =<< dataCon incoherentDataConName where nothing = coreNothing overlapTyConName just = coreJust overlapTyConName -repClass :: Core (M TH.Cxt) -> Core TH.Name -> Core [(M (TH.TyVarBndr ()))] +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)) repClass (MkC cxt) (MkC cls) (MkC tvs) (MkC fds) (MkC ds) @@ -2638,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] @@ -2663,17 +2818,23 @@ 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] -repDataFamilyD :: Core TH.Name -> Core [(M (TH.TyVarBndr ()))] +repDataFamilyD :: Core TH.Name -> Core [(M (TH.TyVarBndr TH.BndrVis))] -> Core (Maybe (M TH.Kind)) -> MetaM (Core (M TH.Dec)) repDataFamilyD (MkC nm) (MkC tvs) (MkC kind) = rep2 dataFamilyDName [nm, tvs, kind] repOpenFamilyD :: Core TH.Name - -> Core [(M (TH.TyVarBndr ()))] + -> Core [(M (TH.TyVarBndr TH.BndrVis))] -> Core (M TH.FamilyResultSig) -> Core (Maybe TH.InjectivityAnn) -> MetaM (Core (M TH.Dec)) @@ -2681,7 +2842,7 @@ = rep2 openTypeFamilyDName [nm, tvs, result, inj] repClosedFamilyD :: Core TH.Name - -> Core [(M (TH.TyVarBndr ()))] + -> Core [(M (TH.TyVarBndr TH.BndrVis))] -> Core (M TH.FamilyResultSig) -> Core (Maybe TH.InjectivityAnn) -> Core [(M TH.TySynEqn)] @@ -2715,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 @@ -2734,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, @@ -2747,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 ------------------- @@ -2893,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 @@ -2902,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 @@ -2924,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 @@ -2941,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 @@ -3020,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) @@ -550,14 +593,16 @@ = do { rec_binds' <- addTickHsRecordBinds rec_binds ; return (expr { rcon_flds = rec_binds' }) } -addTickHsExpr expr@(RecordUpd { rupd_expr = e, rupd_flds = Left flds }) +addTickHsExpr expr@(RecordUpd { rupd_expr = e + , rupd_flds = upd@(RegularRecUpdFields { recUpdFields = flds }) }) = do { e' <- addTickLHsExpr e ; flds' <- mapM addTickHsRecField flds - ; return (expr { rupd_expr = e', rupd_flds = Left flds' }) } -addTickHsExpr expr@(RecordUpd { rupd_expr = e, rupd_flds = Right flds }) + ; return (expr { rupd_expr = e', rupd_flds = upd { recUpdFields = flds' } }) } +addTickHsExpr expr@(RecordUpd { rupd_expr = e + , rupd_flds = upd@(OverloadedRecUpdFields { olRecUpdFields = flds } ) }) = do { e' <- addTickLHsExpr e ; flds' <- mapM addTickHsRecField flds - ; return (expr { rupd_expr = e', rupd_flds = Right flds' }) } + ; return (expr { rupd_expr = e', rupd_flds = upd { olRecUpdFields = flds' } }) } addTickHsExpr (ExprWithTySig x e ty) = liftM3 ExprWithTySig @@ -583,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 @@ -604,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') } @@ -612,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) $ @@ -663,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) } @@ -676,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 @@ -699,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 @@ -724,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 @@ -735,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) @@ -811,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) {- @@ -823,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')) } @@ -853,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)) = @@ -874,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 @@ -905,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) @@ -937,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)) @@ -974,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 @@ -989,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 @@ -1001,6 +1086,7 @@ , blackList :: Set RealSrcSpan , this_mod :: Module , tickishType :: TickishType + , recSelBinds :: IdEnv Id } -- deriving Show @@ -1058,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 $ @@ -1113,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 @@ -1135,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 @@ -1180,24 +1286,25 @@ , tick_label = boxLabel } - cc_name | topOnly = head decl_path - | otherwise = concat (intersperse "." decl_path) + cc_name | topOnly = mkFastString $ head decl_path + | otherwise = mkFastString $ concat (intersperse "." decl_path) env <- getEnv case tickishType env of HpcTicks -> HpcTick (this_mod env) <$> addMixEntry me ProfNotes -> do - let nm = mkFastString cc_name - flavour <- mkHpcCCFlavour <$> getCCIndexM nm - let cc = mkUserCC nm (this_mod env) pos flavour + flavour <- mkHpcCCFlavour <$> getCCIndexM cc_name + let cc = mkUserCC cc_name (this_mod env) pos flavour count = countEntries && tte_countEntries env return $ ProfNote cc count True{-scopes-} - Breakpoints -> 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' cc_name + return $ SourceNote pos' $ LexicalFastString cc_name _otherwise -> panic "mkTickish: bad source span!" @@ -1247,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 @@ -1,5 +1,10 @@ {-# LANGUAGE TypeFamilies, UndecidableInstances #-} +{-# OPTIONS_GHC -Wno-orphans #-} + -- Don't warn that `type instance DsForeignsHooks = ...` + -- is an orphan; see Note [The Decoupling Abstract Data Hack] + -- in GHC.Driver.Hooks + -- | Various types used during desugaring. module GHC.HsToCore.Types ( DsM, DsLclEnv(..), DsGblEnv(..), @@ -15,19 +20,28 @@ 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 ) + {- ************************************************************************ * * @@ -46,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 @@ -73,6 +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 :: 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 @@ -35,21 +33,23 @@ import GHC.Unit.Module.Deps import GHC.Data.Maybe +import GHC.Data.FastString import Data.IORef import Data.List (sortBy) 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, @@ -73,20 +73,24 @@ { 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 - let usages = mod_usages ++ [ UsageFile { usg_file_path = f + 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 } | (f, hash) <- zip dependent_files hashes ] @@ -102,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? @@ -165,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 fn <$> lookupFileCache fc fn <*> pure mmsg + 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 @@ -199,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 @@ -234,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 @@ -262,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 @@ -275,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 @@ -332,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,24 +65,23 @@ 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 -import GHC.Driver.Session +import GHC.Driver.DynFlags import GHC.Driver.Ppr -import GHC.Data.FastString import qualified GHC.LanguageExtensions as LangExt +import GHC.Rename.Env ( irrefutableConLikeTc ) import GHC.Tc.Types.Evidence import Control.Monad ( zipWithM ) @@ -133,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] -- @@ -142,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 (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] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -195,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 @@ -248,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 @@ -326,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, @@ -454,106 +462,10 @@ is disabled. -} -mkFailExpr :: HsMatchContext GhcRn -> 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 @@ -595,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 @@ -632,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 } @@ -640,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 @@ -724,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 @@ -756,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 $ @@ -780,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 @@ -789,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}) @@ -806,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 @@ -910,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) } @@ -958,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 @@ -995,19 +924,10 @@ mkBinaryTickBox :: Int -> Int -> CoreExpr -> DsM CoreExpr mkBinaryTickBox ixT ixF e = do - uq <- newUnique this_mod <- getModule - let bndr1 = mkSysLocal (fsLit "t1") uq OneTy boolTy - -- It's always sufficient to pattern-match on a boolean with - -- multiplicity 'One'. - let + let trueBox = Tick (HpcTick this_mod ixT) (Var trueDataConId) falseBox = Tick (HpcTick this_mod ixF) (Var falseDataConId) - trueBox = Tick (HpcTick this_mod ixT) (Var trueDataConId) - -- - return $ Case e bndr1 boolTy - [ Alt (DataAlt falseDataCon) [] falseBox - , Alt (DataAlt trueDataCon) [] trueBox - ] + return $ mkIfThenElse e trueBox falseBox @@ -1056,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) @@ -1088,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,13 +658,13 @@ 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 updateNameCache' name_cache $ \cache0 -> do mut_arr <- newArray_ (0, sz-1) :: IO (IOArray Int Name) - cache <- foldGet (fromIntegral sz) bh cache0 $ \i (uid, mod_name, occ) cache -> do + cache <- foldGet' (fromIntegral sz) bh cache0 $ \i (uid, mod_name, occ) cache -> do let mod = mkModule uid mod_name case lookupOrigNameCache cache mod occ of Just name -> do @@ -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 new file mode 100644 --- /dev/null +++ b/GHC/Iface/Decl.hs @@ -0,0 +1,336 @@ + +{-# LANGUAGE NondecreasingIndentation #-} +{-# LANGUAGE LambdaCase #-} + +{- +(c) The University of Glasgow 2006-2008 +(c) The GRASP/AQUA Project, Glasgow University, 1993-1998 +-} + +-- | Module for constructing interface declaration values +-- from the corresponding 'TyThing's. + +module GHC.Iface.Decl + ( coAxiomToIfaceDecl + , tyThingToIfaceDecl -- Converting things to their Iface equivalents + ) +where + +import GHC.Prelude + +import GHC.Tc.Utils.TcType + +import GHC.Iface.Syntax + +import GHC.CoreToIface + +import GHC.Core.Class +import GHC.Core.TyCon +import GHC.Core.Coercion.Axiom +import GHC.Core.ConLike +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 +import GHC.Types.Var +import GHC.Types.Name +import GHC.Types.Basic +import GHC.Types.TyThing + +import GHC.Utils.Panic.Plain +import GHC.Utils.Misc + +import GHC.Data.Maybe +import Data.List ( findIndex, mapAccumL ) + +{- +************************************************************************ +* * + Converting things to their Iface equivalents +* * +************************************************************************ +-} + +tyThingToIfaceDecl :: Bool -> TyThing -> IfaceDecl +tyThingToIfaceDecl _ (AnId id) = idToIfaceDecl id +tyThingToIfaceDecl _ (ATyCon tycon) = snd (tyConToIfaceDecl emptyTidyEnv tycon) +tyThingToIfaceDecl _ (ACoAxiom ax) = coAxiomToIfaceDecl ax +tyThingToIfaceDecl show_linear_types (AConLike cl) = case cl of + RealDataCon dc -> dataConToIfaceDecl show_linear_types dc -- for ppr purposes only + PatSynCon ps -> patSynToIfaceDecl ps + +-------------------------- +idToIfaceDecl :: Id -> IfaceDecl +-- The Id is already tidied, so that locally-bound names +-- (lambdas, for-alls) already have non-clashing OccNames +-- We can't tidy it here, locally, because it may have +-- free variables in its type or IdInfo +idToIfaceDecl id + = IfaceId { ifName = getName id, + ifType = toIfaceType (idType id), + ifIdDetails = toIfaceIdDetails (idDetails id), + ifIdInfo = toIfaceIdInfo (idInfo id) } + +-------------------------- +dataConToIfaceDecl :: Bool -> DataCon -> IfaceDecl +dataConToIfaceDecl show_linear_types dataCon + = IfaceId { ifName = getName dataCon, + ifType = toIfaceType (dataConDisplayType show_linear_types dataCon), + ifIdDetails = IfVanillaId, + ifIdInfo = [] } + +-------------------------- +coAxiomToIfaceDecl :: CoAxiom br -> IfaceDecl +-- We *do* tidy Axioms, because they are not (and cannot +-- conveniently be) built in tidy form +coAxiomToIfaceDecl ax@(CoAxiom { co_ax_tc = tycon, co_ax_branches = branches + , co_ax_role = role }) + = IfaceAxiom { ifName = getName ax + , ifTyCon = toIfaceTyCon tycon + , ifRole = role + , ifAxBranches = map (coAxBranchToIfaceBranch tycon + (map coAxBranchLHS branch_list)) + branch_list } + where + branch_list = fromBranches branches + +-- 2nd parameter is the list of branch LHSs, in case of a closed type family, +-- for conversion from incompatible branches to incompatible indices. +-- For an open type family the list should be empty. +-- See Note [Storing compatibility] in GHC.Core.Coercion.Axiom +coAxBranchToIfaceBranch :: TyCon -> [[Type]] -> CoAxBranch -> IfaceAxBranch +coAxBranchToIfaceBranch tc lhs_s + (CoAxBranch { cab_tvs = tvs, cab_cvs = cvs + , cab_eta_tvs = eta_tvs + , cab_lhs = lhs, cab_roles = roles + , cab_rhs = rhs, cab_incomps = incomps }) + + = IfaceAxBranch { ifaxbTyVars = toIfaceTvBndrs tvs + , ifaxbCoVars = map toIfaceIdBndr cvs + , ifaxbEtaTyVars = toIfaceTvBndrs eta_tvs + , ifaxbLHS = toIfaceTcArgs tc lhs + , ifaxbRoles = roles + , ifaxbRHS = toIfaceType rhs + , ifaxbIncomps = iface_incomps } + where + iface_incomps = map (expectJust + . flip findIndex lhs_s + . eqTypes + . coAxBranchLHS) incomps + +----------------- +tyConToIfaceDecl :: TidyEnv -> TyCon -> (TidyEnv, IfaceDecl) +-- We *do* tidy TyCons, because they are not (and cannot +-- conveniently be) built in tidy form +-- The returned TidyEnv is the one after tidying the tyConTyVars +tyConToIfaceDecl env tycon + | Just clas <- tyConClass_maybe tycon + = classToIfaceDecl env clas + + | Just syn_rhs <- synTyConRhs_maybe tycon + = ( tc_env1 + , IfaceSynonym { ifName = getName tycon, + ifRoles = tyConRoles tycon, + ifSynRhs = if_syn_type syn_rhs, + ifBinders = if_binders, + ifResKind = if_res_kind + }) + + | Just fam_flav <- famTyConFlav_maybe tycon + = ( tc_env1 + , IfaceFamily { ifName = getName tycon, + ifResVar = mkIfLclName <$> if_res_var, + ifFamFlav = to_if_fam_flav fam_flav, + ifBinders = if_binders, + ifResKind = if_res_kind, + ifFamInj = tyConInjectivityInfo tycon + }) + + | isAlgTyCon tycon + = ( tc_env1 + , IfaceData { ifName = getName tycon, + ifBinders = if_binders, + ifResKind = if_res_kind, + ifCType = tyConCType_maybe tycon, + ifRoles = tyConRoles tycon, + ifCtxt = tidyToIfaceContext tc_env1 (tyConStupidTheta tycon), + ifCons = ifaceConDecls (algTyConRhs tycon), + ifGadtSyntax = isGadtSyntaxTyCon tycon, + ifParent = parent }) + + | otherwise -- FunTyCon, PrimTyCon, promoted TyCon/DataCon + -- We only convert these TyCons to IfaceTyCons when we are + -- just about to pretty-print them, not because we are going + -- to put them into interface files + = ( env + , IfaceData { ifName = getName tycon, + ifBinders = if_binders, + ifResKind = if_res_kind, + ifCType = Nothing, + ifRoles = tyConRoles tycon, + ifCtxt = [], + ifCons = IfDataTyCon False [], + ifGadtSyntax = False, + ifParent = IfNoParent }) + where + -- NOTE: Not all TyCons have `tyConTyVars` field. Forcing this when `tycon` + -- is one of these TyCons (FunTyCon, PrimTyCon, PromotedDataCon) will cause + -- an error. + (tc_env1, tc_binders) = tidyTyConBinders env (tyConBinders tycon) + tc_tyvars = binderVars tc_binders + if_binders = toIfaceForAllBndrs tc_binders + -- No tidying of the binders; they are already tidy + if_res_kind = tidyToIfaceType tc_env1 (tyConResKind tycon) + if_syn_type ty = tidyToIfaceType tc_env1 ty + if_res_var = getOccFS `fmap` tyConFamilyResVar_maybe tycon + + parent = case tyConFamInstSig_maybe tycon of + Just (tc, ty, ax) -> IfDataInstance (coAxiomName ax) + (toIfaceTyCon tc) + (tidyToIfaceTcArgs tc_env1 tc ty) + Nothing -> IfNoParent + + to_if_fam_flav OpenSynFamilyTyCon = IfaceOpenSynFamilyTyCon + to_if_fam_flav AbstractClosedSynFamilyTyCon = IfaceAbstractClosedSynFamilyTyCon + to_if_fam_flav (DataFamilyTyCon {}) = IfaceDataFamilyTyCon + to_if_fam_flav (BuiltInSynFamTyCon {}) = IfaceBuiltInSynFamTyCon + to_if_fam_flav (ClosedSynFamilyTyCon Nothing) = IfaceClosedSynFamilyTyCon Nothing + to_if_fam_flav (ClosedSynFamilyTyCon (Just ax)) + = IfaceClosedSynFamilyTyCon (Just (axn, ibr)) + where defs = fromBranches $ coAxiomBranches ax + lhss = map coAxBranchLHS defs + ibr = map (coAxBranchToIfaceBranch tycon lhss) defs + axn = coAxiomName ax + + ifaceConDecls (DataTyCon { data_cons = cons, is_type_data = type_data }) + = IfDataTyCon type_data (map ifaceConDecl cons) + 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, + ifConInfix = dataConIsInfix data_con, + ifConWrapper = isJust (dataConWrapId_maybe data_con), + ifConExTCvs = map toIfaceBndr ex_tvs', + ifConUserTvBinders = toIfaceForAllBndrs user_bndrs', + ifConEqSpec = map (to_eq_spec . eqSpecPair) eq_spec, + ifConCtxt = tidyToIfaceContext con_env2 theta, + ifConArgTys = + map (\(Scaled w t) -> (tidyToIfaceType con_env2 w + , (tidyToIfaceType con_env2 t))) arg_tys, + ifConFields = dataConFieldLabels data_con, + ifConStricts = map (toIfaceBang con_env2) + (dataConImplBangs data_con), + ifConSrcStricts = map toIfaceSrcBang + (dataConSrcBangs data_con)} + where + (univ_tvs, ex_tvs, eq_spec, theta, arg_tys, _) + = dataConFullSig data_con + user_bndrs = dataConUserTyVarBinders data_con + + -- Tidy the univ_tvs of the data constructor to be identical + -- to the tyConTyVars of the type constructor. This means + -- (a) we don't need to redundantly put them into the interface file + -- (b) when pretty-printing an Iface data declaration in H98-style syntax, + -- 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 univ_tvs tc_tyvars)) + -- A bit grimy, perhaps, but it's simple! + + (con_env2, ex_tvs') = tidyVarBndrs con_env1 ex_tvs + user_bndrs' = map (tidyUserForAllTyBinder con_env2) user_bndrs + to_eq_spec (tv,ty) = (tidyTyVar con_env2 tv, tidyToIfaceType con_env2 ty) + + -- By this point, we have tidied every universal and existential + -- tyvar. Because of the dcUserForAllTyBinders invariant + -- (see Note [DataCon user type variable binders]), *every* + -- user-written tyvar must be contained in the substitution that + -- 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 -> TyVarBinder -> TyVarBinder + tidyUserForAllTyBinder env (Bndr tv vis) = + Bndr (tidyTyCoVarOcc env tv) vis + +classToIfaceDecl :: TidyEnv -> Class -> (TidyEnv, IfaceDecl) +classToIfaceDecl env clas + = ( env1 + , IfaceClass { ifName = getName tycon, + ifRoles = tyConRoles (classTyCon clas), + ifBinders = toIfaceForAllBndrs tc_binders, + ifBody = body, + ifFDs = map toIfaceFD clas_fds }) + where + (_, clas_fds, sc_theta, _, clas_ats, op_stuff) + = classExtraBigSig clas + tycon = classTyCon clas + + body | isAbstractTyCon tycon = IfAbstractClass + | otherwise + = IfConcreteClass { + ifClassCtxt = tidyToIfaceContext env1 sc_theta, + ifATs = map toIfaceAT clas_ats, + ifSigs = map toIfaceClassOp op_stuff, + ifMinDef = toIfaceBooleanFormula (classMinimalDef clas), + ifUnary = isUnaryClassTyCon tycon + } + + (env1, tc_binders) = tidyTyConBinders env (tyConBinders tycon) + + toIfaceAT :: ClassATItem -> IfaceAT + toIfaceAT (ATI tc def) + = IfaceAT if_decl (fmap (tidyToIfaceType env2 . fst) def) + where + (env2, if_decl) = tyConToIfaceDecl env1 tc + + toIfaceClassOp (sel_id, def_meth) + = assert (sel_tyvars == binderVars tc_binders) $ + IfaceClassOp (getName sel_id) + (tidyToIfaceType env1 op_ty) + (fmap toDmSpec def_meth) + where + -- Be careful when splitting the type, because of things + -- like class Foo a where + -- op :: (?x :: String) => a -> a + -- and class Baz a where + -- op :: (Ord a) => a -> a + (sel_tyvars, rho_ty) = splitForAllTyCoVars (idType sel_id) + op_ty = funResultTy rho_ty + + toDmSpec :: (Name, DefMethSpec Type) -> DefMethSpec IfaceType + toDmSpec (_, VanillaDM) = VanillaDM + toDmSpec (_, GenericDM dm_ty) = GenericDM (tidyToIfaceType env1 dm_ty) + + toIfaceFD (tvs1, tvs2) = (map (tidyTyVar env1) tvs1 + ,map (tidyTyVar env1) tvs2) + +-------------------------- + +tidyTyConBinder :: TidyEnv -> TyConBinder -> (TidyEnv, TyConBinder) +-- If the type variable "binder" is in scope, don't re-bind it +-- In a class decl, for example, the ATD binders mention +-- (amd must mention) the class tyvars +tidyTyConBinder env@(_, subst) tvb@(Bndr tv vis) + = case lookupVarEnv subst tv of + Just tv' -> (env, Bndr tv' vis) + Nothing -> tidyForAllTyBinder env tvb + +tidyTyConBinders :: TidyEnv -> [TyConBinder] -> (TidyEnv, [TyConBinder]) +tidyTyConBinders = mapAccumL tidyTyConBinder + +tidyTyVar :: TidyEnv -> TyVar -> IfLclName +tidyTyVar (_, subst) tv = toIfaceTyVar (lookupVarEnv subst tv `orElse` tv) 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, @@ -24,7 +24,7 @@ import GHC.Prelude import GHC.Driver.Env -import GHC.Driver.Session +import GHC.Driver.DynFlags import GHC.Tc.Utils.Monad import GHC.Core.Type @@ -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,12 +189,15 @@ ************************************************************************ -} -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 (text "Iface id out of scope: " <+> ppr occ) + Nothing -> failIfM $ + vcat + [ text "Iface id out of scope: " <+> ppr occ + , text "env:" <+> ppr (if_id_env lcl) ] } extendIfaceIdEnv :: [Id] -> IfL a -> IfL a @@ -206,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) } @@ -217,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 @@ -262,14 +264,20 @@ newIfaceNames :: [OccName] -> IfL [Name] newIfaceNames occs - = do { uniqs <- newUniqueSupply + = do { uniqs <- getUniquesM ; return [ mkInternalName uniq occ noSrcSpan - | (occ,uniq) <- occs `zip` uniqsFromSupply uniqs] } + | (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 @@ -3,248 +3,136 @@ module GHC.Iface.Errors ( badIfaceFile - , hiModuleNameMismatchWarn - , homeModError , cannotFindInterface , cantFindInstalledErr , cannotFindModule - , cantFindErr - -- * Utility functions - , mayShowLocations ) where import GHC.Platform.Profile import GHC.Platform.Ways import GHC.Utils.Panic.Plain -import GHC.Driver.Session +import GHC.Driver.DynFlags import GHC.Driver.Env -import GHC.Driver.Errors.Types import GHC.Data.Maybe +import GHC.Data.OsPath import GHC.Prelude import GHC.Unit import GHC.Unit.Env import GHC.Unit.Finder.Types import GHC.Utils.Outputable as Outputable +import GHC.Iface.Errors.Types +-- ----------------------------------------------------------------------------- +-- Error messages badIfaceFile :: String -> SDoc -> SDoc badIfaceFile file err = vcat [text "Bad interface file:" <+> text file, nest 4 err] -hiModuleNameMismatchWarn :: Module -> Module -> SDoc -hiModuleNameMismatchWarn requested_mod read_mod - | moduleUnit requested_mod == moduleUnit read_mod = - sep [text "Interface file contains module" <+> quotes (ppr read_mod) <> comma, - text "but we were expecting module" <+> quotes (ppr requested_mod), - sep [text "Probable cause: the source code which generated interface file", - text "has an incompatible module name" - ] - ] - | otherwise = - -- ToDo: This will fail to have enough qualification when the package IDs - -- are the same - withPprStyle (mkUserStyle alwaysQualify AllTheWay) $ - -- we want the Modules below to be qualified with package names, - -- so reset the NamePprCtx setting. - hsep [ text "Something is amiss; requested module " - , 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") - ] - -homeModError :: InstalledModule -> ModLocation -> SDoc --- See Note [Home module load error] -homeModError mod location - = text "attempting to use module " <> quotes (ppr mod) - <> (case ml_hs_file location of - Just file -> space <> parens (text file) - Nothing -> Outputable.empty) - <+> text "which is not loaded" - - --- ----------------------------------------------------------------------------- --- Error messages - -cannotFindInterface :: UnitState -> Maybe HomeUnit -> Profile -> ([FilePath] -> SDoc) -> ModuleName -> InstalledFindResult -> SDoc -cannotFindInterface = cantFindInstalledErr (text "Failed to load interface for") - (text "Ambiguous interface for") +cannotFindInterface :: UnitState -> Maybe HomeUnit -> Profile + -> ModuleName -> InstalledFindResult -> MissingInterfaceError +cannotFindInterface us mhu p mn ifr = + CantFindErr us FindingInterface $ + cantFindInstalledErr us mhu p mn ifr cantFindInstalledErr - :: SDoc - -> SDoc - -> UnitState + :: UnitState -> Maybe HomeUnit -> Profile - -> ([FilePath] -> SDoc) -> ModuleName -> InstalledFindResult - -> SDoc -cantFindInstalledErr cannot_find _ unit_state mhome_unit profile tried_these mod_name find_result - = cannot_find <+> quotes (ppr mod_name) - $$ more_info + -> CantFindInstalled +cantFindInstalledErr unit_state mhome_unit profile mod_name find_result + = CantFindInstalled mod_name more_info where build_tag = waysBuildTag (profileWays profile) more_info = case find_result of InstalledNoPackage pkg - -> text "no unit id matching" <+> quotes (ppr pkg) <+> - text "was found" $$ looks_like_srcpkgid pkg + -> NoUnitIdMatching pkg (searchPackageId unit_state (PackageId (unitIdFS pkg))) 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 - -> text "It is not a module in the current program, or in any known package." + -> NotAModule | otherwise - -> tried_these files + -> CouldntFindInFiles $ fmap unsafeDecodeUtf files _ -> panic "cantFindInstalledErr" - looks_like_srcpkgid :: UnitId -> SDoc - looks_like_srcpkgid pk - -- Unsafely coerce a unit id (i.e. an installed package component - -- identifier) into a PackageId and see if it means anything. - | (pkg:pkgs) <- searchPackageId unit_state (PackageId (unitIdFS pk)) - = parens (text "This unit ID looks like the source package ID;" $$ - text "the real unit ID is" <+> quotes (ftext (unitIdFS (unitId pkg))) $$ - (if null pkgs then Outputable.empty - else text "and" <+> int (length pkgs) <+> text "other candidates")) - -- Todo: also check if it looks like a package name! - | otherwise = Outputable.empty - not_found_in_package pkg files | build_tag /= "" = let build = if build_tag == "p" then "profiling" else "\"" ++ build_tag ++ "\"" in - text "Perhaps you haven't installed the " <> text build <> - text " libraries for package " <> quotes (ppr pkg) <> char '?' $$ - tried_these files - + MissingPackageWayFiles build pkg files | otherwise - = text "There are files missing in the " <> quotes (ppr pkg) <> - text " package," $$ - text "try running 'ghc-pkg check'." $$ - tried_these files + = MissingPackageFiles pkg files -mayShowLocations :: DynFlags -> [FilePath] -> SDoc -mayShowLocations dflags files - | null files = Outputable.empty - | verbosity dflags < 3 = - text "Use -v (or `:set -v` in ghci) " <> - text "to see a list of the files searched for." - | otherwise = - hang (text "Locations searched:") 2 $ vcat (map text files) -cannotFindModule :: HscEnv -> ModuleName -> FindResult -> SDoc + +cannotFindModule :: HscEnv -> ModuleName -> FindResult -> MissingInterfaceError cannotFindModule hsc_env = cannotFindModule' - (hsc_dflags hsc_env) (hsc_unit_env hsc_env) (targetProfile (hsc_dflags hsc_env)) -cannotFindModule' :: DynFlags -> UnitEnv -> Profile -> ModuleName -> FindResult -> SDoc -cannotFindModule' dflags unit_env profile mod res = pprWithUnitState (ue_units unit_env) $ - cantFindErr (checkBuildingCabalPackage dflags) - cannotFindMsg - (text "Ambiguous module name") - unit_env +cannotFindModule' :: UnitEnv -> Profile -> ModuleName -> FindResult + -> MissingInterfaceError +cannotFindModule' unit_env profile mod res = + CantFindErr (ue_homeUnitState unit_env) FindingModule $ + cantFindErr unit_env profile - (mayShowLocations dflags) mod res - where - cannotFindMsg = - case res of - NotFound { fr_mods_hidden = hidden_mods - , fr_pkgs_hidden = hidden_pkgs - , fr_unusables = unusables } - | not (null hidden_mods && null hidden_pkgs && null unusables) - -> text "Could not load module" - _ -> text "Could not find module" cantFindErr - :: BuildingCabalPackage -- ^ Using Cabal? - -> SDoc - -> SDoc - -> UnitEnv + :: UnitEnv -> Profile - -> ([FilePath] -> SDoc) -> ModuleName -> FindResult - -> SDoc -cantFindErr _ _ multiple_found _ _ _ mod_name (FoundMultiple mods) - | Just pkgs <- unambiguousPackages - = hang (multiple_found <+> quotes (ppr mod_name) <> colon) 2 ( - sep [text "it was found in multiple packages:", - hsep (map ppr pkgs) ] - ) - | otherwise - = hang (multiple_found <+> quotes (ppr mod_name) <> colon) 2 ( - vcat (map pprMod mods) - ) - where - unambiguousPackages = foldl' unambiguousPackage (Just []) mods - unambiguousPackage (Just xs) (m, ModOrigin (Just _) _ _ _) - = Just (moduleUnit m : xs) - unambiguousPackage _ _ = Nothing - - pprMod (m, o) = text "it is bound as" <+> ppr m <+> - text "by" <+> pprOrigin m o - pprOrigin _ ModHidden = panic "cantFindErr: bound by mod hidden" - pprOrigin _ (ModUnusable _) = panic "cantFindErr: bound by mod unusable" - pprOrigin m (ModOrigin e res _ f) = sep $ punctuate comma ( - if e == Just True - then [text "package" <+> ppr (moduleUnit m)] - else [] ++ - map ((text "a reexport in package" <+>) - .ppr.mkUnit) res ++ - if f then [text "a package flag"] else [] - ) + -> CantFindInstalled +cantFindErr _ _ mod_name (FoundMultiple mods) + = CantFindInstalled mod_name (MultiplePackages mods) -cantFindErr using_cabal cannot_find _ unit_env profile tried_these mod_name find_result - = cannot_find <+> quotes (ppr mod_name) - $$ more_info +cantFindErr unit_env profile mod_name find_result + = CantFindInstalled mod_name more_info where mhome_unit = ue_homeUnit unit_env more_info = case find_result of NoPackage pkg - -> text "no unit id matching" <+> quotes (ppr pkg) <+> - text "was found" - + -> NoUnitIdMatching (toUnitId pkg) [] NotFound { fr_paths = files, fr_pkg = mb_pkg , fr_mods_hidden = mod_hiddens, fr_pkgs_hidden = pkg_hiddens , fr_unusables = unusables, fr_suggestions = suggest } | Just pkg <- mb_pkg , Nothing <- mhome_unit -- no home-unit - -> not_found_in_package pkg files + -> not_found_in_package (toUnitId pkg) files | Just pkg <- mb_pkg , Just home_unit <- mhome_unit -- there is a home-unit but the , not (isHomeUnit home_unit pkg) -- module isn't from it - -> not_found_in_package pkg files + -> not_found_in_package (toUnitId pkg) files | not (null suggest) - -> pp_suggestions suggest $$ tried_these files + -> ModuleSuggestion suggest files | null files && null mod_hiddens && null pkg_hiddens && null unusables - -> text "It is not a module in the current program, or in any known package." + -> NotAModule | otherwise - -> vcat (map pkg_hidden pkg_hiddens) $$ - vcat (map mod_hidden mod_hiddens) $$ - vcat (map unusable unusables) $$ - tried_these files - + -> GenericMissing + (map ((\uid -> (uid, lookupUnit (ue_homeUnitState unit_env) uid))) pkg_hiddens) + mod_hiddens unusables files _ -> panic "cantFindErr" build_tag = waysBuildTag (profileWays profile) @@ -255,82 +143,7 @@ build = if build_tag == "p" then "profiling" else "\"" ++ build_tag ++ "\"" in - text "Perhaps you haven't installed the " <> text build <> - text " libraries for package " <> quotes (ppr pkg) <> char '?' $$ - tried_these files + MissingPackageWayFiles build pkg files | otherwise - = text "There are files missing in the " <> quotes (ppr pkg) <> - text " package," $$ - text "try running 'ghc-pkg check'." $$ - tried_these files - - pkg_hidden :: Unit -> SDoc - pkg_hidden uid = - text "It is a member of the hidden package" - <+> quotes (ppr uid) - --FIXME: we don't really want to show the unit id here we should - -- show the source package id or installed package id if it's ambiguous - <> dot $$ pkg_hidden_hint uid - - pkg_hidden_hint uid - | using_cabal == YesBuildingCabalPackage - = let pkg = expectJust "pkg_hidden" (lookupUnit (ue_units unit_env) uid) - in text "Perhaps you need to add" <+> - quotes (ppr (unitPackageName pkg)) <+> - text "to the build-depends in your .cabal file." - | Just pkg <- lookupUnit (ue_units unit_env) uid - = text "You can run" <+> - quotes (text ":set -package " <> ppr (unitPackageName pkg)) <+> - text "to expose it." $$ - text "(Note: this unloads all the modules in the current scope.)" - | otherwise = Outputable.empty - - mod_hidden pkg = - text "it is a hidden module in the package" <+> quotes (ppr pkg) - - unusable (UnusableUnit unit reason reexport) - = text "It is " <> (if reexport then text "reexported from the package" - else text "a member of the package") - <+> quotes (ppr unit) - $$ pprReason (text "which is") reason - - pp_suggestions :: [ModuleSuggestion] -> SDoc - pp_suggestions sugs - | null sugs = Outputable.empty - | otherwise = hang (text "Perhaps you meant") - 2 (vcat (map pp_sugg sugs)) - - -- NB: Prefer the *original* location, and then reexports, and then - -- package flags when making suggestions. ToDo: if the original package - -- also has a reexport, prefer that one - pp_sugg (SuggestVisible m mod o) = ppr m <+> provenance o - where provenance ModHidden = Outputable.empty - provenance (ModUnusable _) = Outputable.empty - provenance (ModOrigin{ fromOrigUnit = e, - fromExposedReexport = res, - fromPackageFlag = f }) - | Just True <- e - = parens (text "from" <+> ppr (moduleUnit mod)) - | f && moduleName mod == m - = parens (text "from" <+> ppr (moduleUnit mod)) - | (pkg:_) <- res - = parens (text "from" <+> ppr (mkUnit pkg) - <> comma <+> text "reexporting" <+> ppr mod) - | f - = parens (text "defined via package flags to be" - <+> ppr mod) - | otherwise = Outputable.empty - pp_sugg (SuggestHidden m mod o) = ppr m <+> provenance o - where provenance ModHidden = Outputable.empty - provenance (ModUnusable _) = Outputable.empty - provenance (ModOrigin{ fromOrigUnit = e, - fromHiddenReexport = rhs }) - | Just False <- e - = parens (text "needs flag -package-id" - <+> ppr (moduleUnit mod)) - | (pkg:_) <- rhs - = parens (text "needs flag -package-id" - <+> ppr (mkUnit pkg)) - | otherwise = Outputable.empty - + = MissingPackageFiles pkg files diff --git a/GHC/Iface/Errors/Ppr.hs b/GHC/Iface/Errors/Ppr.hs new file mode 100644 --- /dev/null +++ b/GHC/Iface/Errors/Ppr.hs @@ -0,0 +1,384 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} + +{-# OPTIONS_GHC -fno-warn-orphans #-} -- instance Diagnostic IfaceMessage +{-# LANGUAGE InstanceSigs #-} + +module GHC.Iface.Errors.Ppr + ( IfaceMessageOpts(..) + , interfaceErrorHints + , interfaceErrorReason + , interfaceErrorDiagnostic + , missingInterfaceErrorHints + , missingInterfaceErrorReason + , missingInterfaceErrorDiagnostic + , readInterfaceErrorDiagnostic + + , lookingForHerald + , cantFindErrorX + , mayShowLocations + , pkgHiddenHint + ) + where + +import GHC.Prelude + +import GHC.Types.Error +import GHC.Types.Hint.Ppr () -- Outputable GhcHint +import GHC.Types.Error.Codes +import GHC.Types.Name +import GHC.Types.TyThing + +import GHC.Unit.State +import GHC.Unit.Module + +import GHC.Utils.Outputable +import GHC.Utils.Panic + +import GHC.Iface.Errors.Types + +defaultIfaceMessageOpts :: IfaceMessageOpts +defaultIfaceMessageOpts = IfaceMessageOpts { ifaceShowTriedFiles = False + , ifaceBuildingCabalPackage = NoBuildingCabalPackage } + +instance HasDefaultDiagnosticOpts IfaceMessageOpts where + defaultOpts = defaultIfaceMessageOpts + +instance Diagnostic IfaceMessage where + type DiagnosticOpts IfaceMessage = IfaceMessageOpts + diagnosticMessage opts reason = mkSimpleDecorated $ + interfaceErrorDiagnostic opts reason + + diagnosticReason = interfaceErrorReason + + diagnosticHints = interfaceErrorHints + + diagnosticCode = constructorCode @GHC + +interfaceErrorHints :: IfaceMessage -> [GhcHint] +interfaceErrorHints = \ case + Can'tFindInterface err _looking_for -> + missingInterfaceErrorHints err + Can'tFindNameInInterface {} -> + noHints + CircularImport {} -> + noHints + +missingInterfaceErrorHints :: MissingInterfaceError -> [GhcHint] +missingInterfaceErrorHints = \case + BadSourceImport {} -> + noHints + HomeModError {} -> + noHints + DynamicHashMismatchError {} -> + noHints + CantFindErr {} -> + noHints + BadIfaceFile {} -> + noHints + FailedToLoadDynamicInterface {} -> + noHints + +interfaceErrorReason :: IfaceMessage -> DiagnosticReason +interfaceErrorReason (Can'tFindInterface err _) + = missingInterfaceErrorReason err +interfaceErrorReason (Can'tFindNameInInterface {}) + = ErrorWithoutFlag +interfaceErrorReason (CircularImport {}) + = ErrorWithoutFlag + +missingInterfaceErrorReason :: MissingInterfaceError -> DiagnosticReason +missingInterfaceErrorReason = \ case + BadSourceImport {} -> + ErrorWithoutFlag + HomeModError {} -> + ErrorWithoutFlag + DynamicHashMismatchError {} -> + ErrorWithoutFlag + CantFindErr {} -> + ErrorWithoutFlag + BadIfaceFile {} -> + ErrorWithoutFlag + FailedToLoadDynamicInterface {} -> + ErrorWithoutFlag + + +prettyCantFindWhat :: FindOrLoad -> FindingModuleOrInterface -> AmbiguousOrMissing -> SDoc +prettyCantFindWhat Find FindingModule AoM_Missing = text "Could not find module" +prettyCantFindWhat Load FindingModule AoM_Missing = text "Could not load module" +prettyCantFindWhat _ FindingInterface AoM_Missing = text "Failed to load interface for" +prettyCantFindWhat _ FindingModule AoM_Ambiguous = text "Ambiguous module name" +prettyCantFindWhat _ FindingInterface AoM_Ambiguous = text "Ambiguous interface for" + +isAmbiguousInstalledReason :: CantFindInstalledReason -> AmbiguousOrMissing +isAmbiguousInstalledReason (MultiplePackages {}) = AoM_Ambiguous +isAmbiguousInstalledReason _ = AoM_Missing + +isLoadOrFindReason :: CantFindInstalledReason -> FindOrLoad +isLoadOrFindReason NotAModule {} = Find +isLoadOrFindReason (GenericMissing a b c _) | null a && null b && null c = Find +isLoadOrFindReason (ModuleSuggestion {}) = Find +isLoadOrFindReason _ = Load + +data FindOrLoad = Find | Load + +data AmbiguousOrMissing = AoM_Ambiguous | AoM_Missing + +cantFindError :: IfaceMessageOpts + -> FindingModuleOrInterface + -> CantFindInstalled + -> SDoc +cantFindError opts = + cantFindErrorX + (pkgHiddenHint (const empty) (ifaceBuildingCabalPackage opts)) + (mayShowLocations "-v" (ifaceShowTriedFiles opts)) + + +pkgHiddenHint :: (UnitInfo -> SDoc) -> BuildingCabalPackage + -> UnitInfo -> SDoc +pkgHiddenHint _hint YesBuildingCabalPackage pkg + = text "Perhaps you need to add" <+> + quotes (ppr (unitPackageName pkg)) <+> + text "to the build-depends in your .cabal file." +pkgHiddenHint hint _not_cabal pkg + = hint pkg + +mayShowLocations :: String -> Bool -> [FilePath] -> SDoc +mayShowLocations option verbose files + | null files = empty + | not verbose = + text "Use" <+> text option <+> + text "to see a list of the files searched for." + | otherwise = + hang (text "Locations searched:") 2 $ vcat (map text files) + +-- | General version of cantFindError which has some holes which allow GHC/GHCi to display slightly different +-- error messages. +cantFindErrorX :: (UnitInfo -> SDoc) -> ([FilePath] -> SDoc) -> FindingModuleOrInterface -> CantFindInstalled -> SDoc +cantFindErrorX pkg_hidden_hint may_show_locations mod_or_interface (CantFindInstalled mod_name cfir) = + let ambig = isAmbiguousInstalledReason cfir + find_or_load = isLoadOrFindReason cfir + ppr_what = prettyCantFindWhat find_or_load mod_or_interface ambig + in + (ppr_what <+> quotes (ppr mod_name) <> dot) $$ + case cfir of + NoUnitIdMatching pkg cands -> + + let looks_like_srcpkgid :: SDoc + looks_like_srcpkgid = + -- Unsafely coerce a unit id (i.e. an installed package component + -- identifier) into a PackageId and see if it means anything. + case cands of + (pkg:pkgs) -> + parens (text "This unit ID looks like the source package ID;" $$ + text "the real unit ID is" <+> quotes (ftext (unitIdFS (unitId pkg))) $$ + (if null pkgs then empty + else text "and" <+> int (length pkgs) <+> text "other candidate" <> plural pkgs)) + -- Todo: also check if it looks like a package name! + [] -> empty + + in hsep [ text "no unit id matching" <+> quotes (ppr pkg) + , text "was found"] $$ looks_like_srcpkgid + MissingPackageFiles pkg files -> + text "There are files missing in the " <> quotes (ppr pkg) <+> + text "package," $$ + text "try running 'ghc-pkg check'." $$ + may_show_locations files + MissingPackageWayFiles build pkg files -> + text "Perhaps you haven't installed the " <> text build <+> + text "libraries for package " <> quotes (ppr pkg) <> char '?' $$ + may_show_locations files + ModuleSuggestion ms fps -> + + let pp_suggestions :: [ModuleSuggestion] -> SDoc + pp_suggestions sugs + | null sugs = empty + | otherwise = hang (text "Perhaps you meant") + 2 (vcat (map pp_sugg sugs)) + + -- NB: Prefer the *original* location, and then reexports, and then + -- package flags when making suggestions. ToDo: if the original package + -- also has a reexport, prefer that one + pp_sugg (SuggestVisible m mod o) = ppr m <+> provenance o + where provenance ModHidden = empty + provenance (ModUnusable _) = empty + provenance (ModOrigin{ fromOrigUnit = e, + fromExposedReexport = res, + fromPackageFlag = f }) + | Just True <- e + = parens (text "from" <+> ppr (moduleUnit mod)) + | f && moduleName mod == m + = parens (text "from" <+> ppr (moduleUnit mod)) + | (pkg:_) <- res + = parens (text "from" <+> ppr (mkUnit pkg) + <> comma <+> text "reexporting" <+> ppr mod) + | f + = parens (text "defined via package flags to be" + <+> ppr mod) + | otherwise = empty + pp_sugg (SuggestHidden m mod o) = ppr m <+> provenance o + where provenance ModHidden = empty + provenance (ModUnusable _) = empty + provenance (ModOrigin{ fromOrigUnit = e, + fromHiddenReexport = rhs }) + | Just False <- e + = parens (text "needs flag -package-id" + <+> ppr (moduleUnit mod)) + | (pkg:_) <- rhs + = parens (text "needs flag -package-id" + <+> ppr (mkUnit pkg)) + | otherwise = empty + + in pp_suggestions ms $$ may_show_locations fps + NotAModule -> text "It is not a module in the current program, or in any known package." + CouldntFindInFiles fps -> vcat (map text fps) + MultiplePackages mods + | Just pkgs <- unambiguousPackages + -> sep [text "it was found in multiple packages:", + hsep (map ppr pkgs)] + | otherwise + -> vcat (map pprMod mods) + where + unambiguousPackages = foldl' unambiguousPackage (Just []) mods + unambiguousPackage (Just xs) (m, ModOrigin (Just _) _ _ _) + = Just (moduleUnit m : xs) + unambiguousPackage _ _ = Nothing + GenericMissing pkg_hiddens mod_hiddens unusables files -> + vcat (map pkg_hidden pkg_hiddens) $$ + vcat (map mod_hidden mod_hiddens) $$ + vcat (map unusable unusables) $$ + may_show_locations files + where + pprMod (m, o) = text "it is bound as" <+> ppr m <+> + text "by" <+> pprOrigin m o + pprOrigin _ ModHidden = panic "cantFindErr: bound by mod hidden" + pprOrigin _ (ModUnusable _) = panic "cantFindErr: bound by mod unusable" + pprOrigin m (ModOrigin e res _ f) = sep $ punctuate comma ( + if e == Just True + then [text "package" <+> ppr (moduleUnit m)] + else [] ++ + map ((text "a reexport in package" <+>) + .ppr.mkUnit) res ++ + if f then [text "a package flag"] else [] + ) + pkg_hidden :: (Unit, Maybe UnitInfo) -> SDoc + pkg_hidden (uid, uif) = + text "It is a member of the hidden package" + <+> quotes (ppr uid) + --FIXME: we don't really want to show the unit id here we should + -- show the source package id or installed package id if it's ambiguous + <> dot $$ maybe empty pkg_hidden_hint uif + + + mod_hidden pkg = + text "it is a hidden module in the package" <+> quotes (ppr pkg) + + unusable (UnusableUnit unit reason reexport) + = text "It is " <> (if reexport then text "reexported from the package" + else text "a member of the package") + <+> quotes (ppr unit) + $$ pprReason (text "which is") reason + + +interfaceErrorDiagnostic :: IfaceMessageOpts -> IfaceMessage -> SDoc +interfaceErrorDiagnostic opts = \ case + Can'tFindNameInInterface name relevant_tyThings -> + missingDeclInInterface name relevant_tyThings + Can'tFindInterface err looking_for -> + hangNotEmpty (lookingForHerald looking_for) 2 (missingInterfaceErrorDiagnostic opts err) + CircularImport mod -> + text "Circular imports: module" <+> quotes (ppr mod) + <+> text "depends on itself" + +lookingForHerald :: InterfaceLookingFor -> SDoc +lookingForHerald looking_for = + case looking_for of + LookingForName {} -> empty + LookingForModule {} -> empty + LookingForHiBoot mod -> + text "Could not find hi-boot interface for" <+> quotes (ppr mod) <> colon + LookingForSig sig -> + text "Could not find interface file for signature" <+> quotes (ppr sig) <> colon + +readInterfaceErrorDiagnostic :: ReadInterfaceError -> SDoc +readInterfaceErrorDiagnostic = \ case + ExceptionOccurred fp ex -> + hang (text "Exception when reading interface file " <+> text fp) + 2 (text (showException ex)) + HiModuleNameMismatchWarn _ m1 m2 -> + hiModuleNameMismatchWarn m1 m2 + +missingInterfaceErrorDiagnostic :: IfaceMessageOpts -> MissingInterfaceError -> SDoc +missingInterfaceErrorDiagnostic opts reason = + case reason of + BadSourceImport m -> badSourceImport m + HomeModError im ml -> homeModError im ml + DynamicHashMismatchError m ml -> dynamicHashMismatchError m ml + CantFindErr us module_or_interface cfi -> pprWithUnitState us $ cantFindError opts module_or_interface cfi + BadIfaceFile rie -> readInterfaceErrorDiagnostic rie + FailedToLoadDynamicInterface wanted_mod err -> + hang (text "Failed to load dynamic interface file for" <+> ppr wanted_mod <> colon) + 2 (readInterfaceErrorDiagnostic err) + +hiModuleNameMismatchWarn :: Module -> Module -> SDoc +hiModuleNameMismatchWarn requested_mod read_mod + | moduleUnit requested_mod == moduleUnit read_mod = + sep [text "Interface file contains module" <+> quotes (ppr read_mod) <> comma, + text "but we were expecting module" <+> quotes (ppr requested_mod), + sep [text "Probable cause: the source code which generated interface file", + text "has an incompatible module name" + ] + ] + | otherwise = + -- 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. + hsep [ text "Something is amiss; requested module " + , ppr requested_mod + , text "differs from name found in the interface file" + , ppr read_mod + ] + +dynamicHashMismatchError :: Module -> ModLocation -> SDoc +dynamicHashMismatchError wanted_mod loc = + vcat [ text "Dynamic hash doesn't match for" <+> quotes (ppr wanted_mod) + , text "Normal interface file from" <+> text (ml_hi_file loc) + , text "Dynamic interface file from" <+> text (ml_dyn_hi_file loc) + , text "You probably need to recompile" <+> quotes (ppr wanted_mod) ] + +homeModError :: InstalledModule -> ModLocation -> SDoc +-- See Note [Home module load error] +homeModError mod location + = text "attempting to use module " <> quotes (ppr mod) + <> (case ml_hs_file location of + Just file -> space <> parens (text file) + Nothing -> empty) + <+> text "which is not loaded" + + +missingDeclInInterface :: Name -> [TyThing] -> SDoc +missingDeclInInterface name things = + whenPprDebug (found_things $$ empty) $$ + hang (text "Can't find interface-file declaration for" <+> + pprNameSpace (nameNameSpace name) <+> ppr name) + 2 (vcat [text "Probable cause: bug in .hi-boot file, or inconsistent .hi file", + text "Use -ddump-if-trace to get an idea of which file caused the error"]) + where + found_things = + hang (text "Found the following declarations in" <+> ppr (nameModule name) <> colon) + 2 (vcat (map ppr things)) + +badSourceImport :: Module -> SDoc +badSourceImport mod + = hang (text "You cannot {-# SOURCE #-} import a module from another package") + 2 (text "but" <+> quotes (ppr mod) <+> text "is from package" + <+> quotes (ppr (moduleUnit mod))) diff --git a/GHC/Iface/Errors/Types.hs b/GHC/Iface/Errors/Types.hs new file mode 100644 --- /dev/null +++ b/GHC/Iface/Errors/Types.hs @@ -0,0 +1,98 @@ + +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} + +module GHC.Iface.Errors.Types ( + + MissingInterfaceError(..) + , InterfaceLookingFor(..) + , IfaceMessage(..) + , ReadInterfaceError(..) + , CantFindInstalled(..) + , CantFindInstalledReason(..) + , FindingModuleOrInterface(..) + + , BuildingCabalPackage(..) + + , IfaceMessageOpts(..) + + ) where + +import GHC.Prelude + +import GHC.Types.Name (Name) +import GHC.Types.TyThing (TyThing) +import GHC.Unit.Types (Module, InstalledModule, UnitId, Unit) +import GHC.Unit.State (UnitState, ModuleSuggestion, ModuleOrigin, UnusableUnit, UnitInfo) +import GHC.Exception.Type (SomeException) +import GHC.Unit.Types ( IsBootInterface ) +import Language.Haskell.Syntax.Module.Name ( ModuleName ) + + + +import GHC.Generics ( Generic ) +import GHC.Unit.Module.Location + +data IfaceMessageOpts = IfaceMessageOpts { ifaceShowTriedFiles :: !Bool -- ^ Whether to show files we tried to look for or not when printing loader errors + , ifaceBuildingCabalPackage :: !BuildingCabalPackage + } + +data InterfaceLookingFor + = LookingForName !Name + | LookingForHiBoot !Module + | LookingForModule !ModuleName !IsBootInterface + | LookingForSig !InstalledModule + +data IfaceMessage + = Can'tFindInterface + MissingInterfaceError + InterfaceLookingFor + | Can'tFindNameInInterface + Name + [TyThing] -- possibly relevant TyThings + | CircularImport !Module + deriving Generic + +data MissingInterfaceError + = BadSourceImport !Module + | HomeModError !InstalledModule !ModLocation + | DynamicHashMismatchError !Module !ModLocation + + | CantFindErr !UnitState FindingModuleOrInterface CantFindInstalled + + | BadIfaceFile ReadInterfaceError + | FailedToLoadDynamicInterface Module ReadInterfaceError + deriving Generic + +data ReadInterfaceError + = ExceptionOccurred FilePath SomeException + | HiModuleNameMismatchWarn FilePath Module Module + deriving Generic + +data CantFindInstalledReason + = NoUnitIdMatching UnitId [UnitInfo] + | MissingPackageFiles UnitId [FilePath] + | MissingPackageWayFiles String UnitId [FilePath] + | ModuleSuggestion [ModuleSuggestion] [FilePath] + | NotAModule + | CouldntFindInFiles [FilePath] + | GenericMissing + [(Unit, Maybe UnitInfo)] [Unit] + [UnusableUnit] [FilePath] + | MultiplePackages [(Module, ModuleOrigin)] + deriving Generic + +data CantFindInstalled = + CantFindInstalled ModuleName CantFindInstalledReason + deriving Generic +data FindingModuleOrInterface = FindingModule + | FindingInterface + +-- | Pass to a 'DriverMessage' the information whether or not the +-- '-fbuilding-cabal-package' flag is set. +data BuildingCabalPackage + = YesBuildingCabalPackage + | NoBuildingCabalPackage + deriving Eq 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,20 +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(..), 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 ) @@ -52,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 @@ -79,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] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -208,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 @@ -226,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 () @@ -257,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 @@ -284,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 @@ -299,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 @@ -309,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 @@ -342,7 +367,8 @@ (realSrcSpanEnd $ nodeSpan (NE.last children)) flat_asts = concat - [ tasts + [ modName + , tasts , rasts , imps , exps @@ -397,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) @@ -465,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] ~~~~~~~~~~~~~~~~~~~ @@ -481,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 @@ -540,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 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 @@ -609,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 [] @@ -636,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 [] $ @@ -660,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 [] $ @@ -670,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 ] @@ -697,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 @@ -751,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) @@ -810,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 @@ -836,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)) @@ -865,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 @@ -877,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 ] @@ -905,7 +904,7 @@ setOrigin :: Origin -> NodeOrigin -> NodeOrigin setOrigin FromSource _ = SourceInfo -setOrigin Generated _ = GeneratedInfo +setOrigin (Generated {}) _ = GeneratedInfo instance HiePass p => ToHie (Located (PatSynBind (GhcPass p) (GhcPass p))) where toHie (L sp psb) = concatM $ case psb of @@ -917,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 @@ -943,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 -> @@ -978,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 -> @@ -1008,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) @@ -1016,7 +1026,7 @@ ] ] HieRn -> - [ toHie $ C Use con + [ toHie $ C Use (fmap getName con) , toHie $ contextify dets ] ViewPat _ expr pat -> @@ -1028,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 @@ -1053,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 @@ -1070,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 @@ -1093,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 ] @@ -1133,7 +1213,7 @@ NegApp _ a _ -> [ toHie a ] - HsPar _ _ a _ -> + HsPar _ a -> [ toHie a ] SectionL _ a b -> @@ -1162,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) -> @@ -1180,32 +1260,56 @@ 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 = Left upds}-> + 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 = Right _}-> + RecordUpd { rupd_expr = expr + , rupd_flds = OverloadedRecUpdFields {} }-> [ toHie expr ] 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 @@ -1224,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 @@ -1265,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 @@ -1291,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 @@ -1320,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 @@ -1353,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 @@ -1367,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 @@ -1399,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 @@ -1420,7 +1537,7 @@ [ toHie a , toHie b ] - HsCmdArrForm _ a _ _ cmdtops -> + HsCmdArrForm _ a _ cmdtops -> [ toHie a , toHie cmdtops ] @@ -1428,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 -> @@ -1446,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) -> @@ -1484,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 @@ -1509,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 @@ -1533,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 @@ -1564,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 @@ -1597,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 ] @@ -1616,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 @@ -1638,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} -> @@ -1655,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] @@ -1722,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 ] @@ -1732,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 ] @@ -1751,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 -> @@ -1778,7 +1909,7 @@ , toHie ki ] HsFunTy _ w a b -> - [ toHie (arrowToHsType w) + [ toHie (multAnnToHsType w) , toHie a , toHie b ] @@ -1814,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 _ _ -> [] @@ -1831,20 +1956,21 @@ HsStarTy _ _ -> [] XHsType _ -> [] -instance (ToHie tm, ToHie ty) => ToHie (HsArg 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 $ @@ -1852,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 @@ -1861,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 @@ -1899,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 ] @@ -1923,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 @@ -1931,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 -> @@ -1953,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 @@ -1964,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 $ @@ -1984,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 ] @@ -1996,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 @@ -2015,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 @@ -2057,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 -> @@ -2102,19 +2270,18 @@ 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 flds n _ ns -> + IEThingWith _ n _ ns _ -> [ toHie $ IEC c n , toHie $ map (IEC c) ns - , toHie $ map (IEC c) flds ] IEModuleContents _ n -> [ toHie $ IEC c n @@ -2125,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,11 +2304,14 @@ IEType _ (L l n) -> [ toHie $ C (IEThing c) (L l n) ] + IEData _ (L l n) -> + [ toHie $ C (IEThing c) (L l n) + ] -instance ToHie (IEContext (Located FieldLabel)) where - toHie (IEC c (L span lbl)) = concatM - [ makeNode lbl span - , toHie $ C (IEThing c) $ L span (flSelector lbl) +instance ToHie (IEContext (Located RecFieldInfo)) where + toHie (IEC c (L span info)) = concatM + [ makeNode info span + , toHie $ C (IEThing c) $ L span (flSelector $ recFieldLabel info) ] instance ToHie (LocatedA (DocDecl GhcRn)) where @@ -2149,4 +2322,5 @@ DocGroup _ d -> [ toHie d ] instance ToHie (LHsDoc GhcRn) where - toHie (L span d@(WithHsDocIdentifiers _ ids)) = concatM $ makeNode d span : [toHie $ map (C Use) ids] + toHie (L span d@(WithHsDocIdentifiers _ ids)) = + concatM $ makeNode d span : [toHie $ map (C Use) ids] 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 @@ -9,7 +9,7 @@ import GHC.Prelude import GHC.Core.Map.Type -import GHC.Driver.Session ( DynFlags ) +import GHC.Driver.DynFlags ( DynFlags ) import GHC.Driver.Ppr import GHC.Data.FastString ( FastString, mkFastString ) import GHC.Iface.Type @@ -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,12 +26,17 @@ loadInterface, loadSysInterface, loadUserInterface, loadPluginInterface, findAndReadIface, readIface, writeIface, + flagsToIfCompression, moduleFreeHolesPrecise, needWiredInHomeIface, loadWiredInHomeIface, + WhereFrom(..), + pprModIfaceSimple, ifaceStats, pprModIface, showIface, + getGhcPrimIface, + module Iface_Errors -- avoids boot files in Ppr modules ) where @@ -42,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.Session +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 @@ -65,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 @@ -73,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 @@ -89,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 @@ -105,7 +105,7 @@ import GHC.Unit.Module.Deps import GHC.Unit.State import GHC.Unit.Home -import GHC.Unit.Home.ModInfo +import GHC.Unit.Home.PackageTable import GHC.Unit.Finder import GHC.Unit.Env @@ -116,6 +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 {- ************************************************************************ @@ -143,7 +148,7 @@ also turn out to be needed by the code that e2 expands to. -} -tcLookupImported_maybe :: Name -> TcM (MaybeErr SDoc TyThing) +tcLookupImported_maybe :: Name -> TcM (MaybeErr IfaceMessage TyThing) -- Returns (Failed err) if we can't find the interface file for the thing tcLookupImported_maybe name = do { hsc_env <- getTopEnv @@ -152,7 +157,7 @@ Just thing -> return (Succeeded thing) Nothing -> tcImportDecl_maybe name } -tcImportDecl_maybe :: Name -> TcM (MaybeErr SDoc TyThing) +tcImportDecl_maybe :: Name -> TcM (MaybeErr IfaceMessage TyThing) -- Entry point for *source-code* uses of importDecl tcImportDecl_maybe name | Just thing <- wiredInNameTyThing_maybe name @@ -163,7 +168,7 @@ | otherwise = initIfaceTcRn (importDecl name) -importDecl :: Name -> IfM lcl (MaybeErr SDoc TyThing) +importDecl :: Name -> IfM lcl (MaybeErr IfaceMessage TyThing) -- Get the TyThing for this Name from an interface file -- It's not a wired-in thing -- the caller caught that importDecl name @@ -174,29 +179,22 @@ -- Load the interface, which should populate the PTE ; mb_iface <- assertPpr (isExternalName name) (ppr name) $ loadInterface nd_doc (nameModule name) ImportBySystem - ; case mb_iface of { - Failed err_msg -> return (Failed err_msg) ; - Succeeded _ -> do + ; case mb_iface of + { Failed err_msg -> return $ Failed $ + Can'tFindInterface err_msg (LookingForName name) + ; Succeeded _ -> do -- Now look it up again; this time we should find it { eps <- getEps ; case lookupTypeEnv (eps_PTE eps) name of Just thing -> return $ Succeeded thing - Nothing -> let doc = whenPprDebug (found_things_msg eps $$ empty) - $$ not_found_msg - in return $ Failed doc + Nothing -> return $ Failed $ + Can'tFindNameInInterface name + (filter is_interesting $ nonDetNameEnvElts $ eps_PTE eps) }}} where nd_doc = text "Need decl for" <+> ppr name - not_found_msg = hang (text "Can't find interface-file declaration for" <+> - pprNameSpace (nameNameSpace name) <+> ppr name) - 2 (vcat [text "Probable cause: bug in .hi-boot file, or inconsistent .hi file", - text "Use -ddump-if-trace to get an idea of which file caused the error"]) - found_things_msg eps = - hang (text "Found the following declarations in" <+> ppr (nameModule name) <> colon) - 2 (vcat (map ppr $ filter is_interesting $ nonDetNameEnvElts $ eps_PTE eps)) - where - is_interesting thing = nameModule name == nameModule (getName thing) + is_interesting thing = nameModule name == nameModule (getName thing) {- @@ -299,15 +297,21 @@ loadSrcInterface doc mod want_boot maybe_pkg = do { res <- loadSrcInterface_maybe doc mod want_boot maybe_pkg ; case res of - Failed err -> failWithTc (mkTcRnUnknownMessage $ mkPlainError noHints err) - Succeeded iface -> return iface } + Failed err -> + failWithTc $ + TcRnInterfaceError $ + Can'tFindInterface err $ + LookingForModule mod want_boot + Succeeded iface -> + return iface + } -- | Like 'loadSrcInterface', but returns a 'MaybeErr'. loadSrcInterface_maybe :: SDoc -> ModuleName -> IsBootInterface -- {-# SOURCE #-} ? -> PkgQual -- "package", if any - -> RnM (MaybeErr SDoc ModIface) + -> RnM (MaybeErr MissingInterfaceError ModIface) loadSrcInterface_maybe doc mod want_boot maybe_pkg -- We must first find which Module this import refers to. This involves @@ -403,11 +407,11 @@ = do dflags <- getDynFlags let ctx = initSDocContext dflags defaultUserStyle - withException ctx (loadInterface doc mod_name where_from) + withIfaceErr ctx (loadInterface doc mod_name where_from) ------------------ loadInterface :: SDoc -> Module -> WhereFrom - -> IfM lcl (MaybeErr SDoc ModIface) + -> IfM lcl (MaybeErr MissingInterfaceError ModIface) -- loadInterface looks in both the HPT and PIT for the required interface -- If not found, it loads it, and puts it in the PIT (always). @@ -441,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 @@ -477,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) $ @@ -506,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 @@ -541,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 @@ -563,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. @@ -574,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. @@ -637,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 @@ -703,7 +738,7 @@ -> SDoc -> IsBootInterface -> Module - -> IO (MaybeErr SDoc (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 @@ -732,7 +767,7 @@ -- @p[A=\,B=\]:B@ never includes B. moduleFreeHolesPrecise :: SDoc -> Module - -> TcRnIf gbl lcl (MaybeErr SDoc (UniqDSet ModuleName)) + -> TcRnIf gbl lcl (MaybeErr MissingInterfaceError (UniqDSet ModuleName)) moduleFreeHolesPrecise doc_str mod | moduleIsDefinite mod = return (Succeeded emptyUniqDSet) | otherwise = @@ -743,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) @@ -769,13 +805,13 @@ Failed err -> return (Failed err) wantHiBootFile :: Maybe HomeUnit -> ExternalPackageState -> Module -> WhereFrom - -> MaybeErr SDoc IsBootInterface + -> MaybeErr MissingInterfaceError IsBootInterface -- Figure out whether we want Foo.hi or Foo.hi-boot wantHiBootFile mhome_unit eps mod from = case from of ImportByUser usr_boot | usr_boot == IsBoot && notHomeModuleMaybe mhome_unit mod - -> Failed (badSourceImport mod) + -> Failed (BadSourceImport mod) | otherwise -> Succeeded usr_boot ImportByPlugin @@ -798,11 +834,6 @@ -- The boot-ness of the requested interface, -- based on the dependencies in directly-imported modules -badSourceImport :: Module -> SDoc -badSourceImport mod - = hang (text "You cannot {-# SOURCE #-} import a module from another package") - 2 (text "but" <+> quotes (ppr mod) <+> text "is from package" - <+> quotes (ppr (moduleUnit mod))) ----------------------------------------------------- -- Loading type/class/value decls @@ -855,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 SDoc (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", @@ -877,82 +906,69 @@ 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 _ - -> return r - 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 r - err -> do - trace_if logger (text "...not found") - return $ Failed $ cannotFindInterface - unit_state - mhome_unit - profile - (Iface_Errors.mayShowLocations dflags) - (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 -> Module -> ModIface -> ModLocation -> IO (MaybeErr SDoc ()) -load_dynamic_too_maybe logger name_cache unit_state dflags wanted_mod iface loc +load_dynamic_too_maybe :: Hooks -> Logger -> NameCache -> UnitState -> DynFlags + -> Module -> ModIface -> ModLocation + -> IO (MaybeErr MissingInterfaceError ()) +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 -> Module -> ModIface -> ModLocation -> IO (MaybeErr SDoc ()) -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 -> NameCache -> UnitState -> DynFlags + -> Module -> ModIface -> ModLocation + -> IO (MaybeErr MissingInterfaceError ()) +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) + do return $ (Failed $ DynamicHashMismatchError wanted_mod loc) Failed err -> - do return $ (Failed $ ((text "Failed to load dynamic interface file for" <+> ppr wanted_mod <> colon) $$ err)) + do return $ (Failed $ FailedToLoadDynamicInterface wanted_mod err) + --((text "Failed to load dynamic interface file for" <+> ppr wanted_mod <> colon) $$ err)) -dynamicHashMismatchError :: Module -> ModLocation -> SDoc -dynamicHashMismatchError wanted_mod loc = - vcat [ text "Dynamic hash doesn't match for" <+> quotes (ppr wanted_mod) - , text "Normal interface file from" <+> text (ml_hi_file loc) - , text "Dynamic interface file from" <+> text (ml_dyn_hi_file loc) - , text "You probably need to recompile" <+> quotes (ppr wanted_mod) ] -read_file :: Logger -> NameCache -> UnitState -> DynFlags -> Module -> FilePath -> IO (MaybeErr SDoc (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 -> NameCache -> UnitState -> DynFlags + -> Module -> FilePath + -> IO (MaybeErr ReadInterfaceError (ModIface, FilePath)) +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 -- if it's indefinite, the inside will be uninstantiated! @@ -962,31 +978,42 @@ (_, 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 (badIfaceFile file_path err)) + Failed err -> return (Failed err) Succeeded iface -> return (Succeeded (iface, file_path)) -- Don't forget to fill in the package name... -- | 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 SDoc ModIface) -readIface dflags name_cache wanted_mod file_path = do + -> IO (MaybeErr ReadInterfaceError ModIface) +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 @@ -995,13 +1022,18 @@ -- 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 wanted_mod actual_mod + err = HiModuleNameMismatchWarn file_path wanted_mod actual_mod - Left exn -> return (Failed (text (showException exn))) + Left exn -> return (Failed (ExceptionOccurred file_path exn)) {- ********************************************************* @@ -1014,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 - {- ********************************************************* * * @@ -1067,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 @@ -1081,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 @@ -1104,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)) @@ -1145,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 + pp_hsc_src HsigFile = text "[hsig]" + pp_hsc_src HsSrcFile = Outputable.empty + {- When printing export lists, we print like this: Avail f f @@ -1160,7 +1193,7 @@ pprExport (Avail n) = ppr n pprExport (AvailTC _ []) = Outputable.empty pprExport avail@(AvailTC n _) = - ppr n <> mark <> pp_export (availSubordinateGreNames avail) + ppr n <> mark <> pp_export (availSubordinateNames avail) where mark | availExportsDecl avail = Outputable.empty | otherwise = vbar @@ -1168,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 (text (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 @@ -1208,16 +1214,6 @@ pprTrustPkg :: Bool -> SDoc pprTrustPkg tpkg = text "require own pkg trusted:" <+> ppr tpkg -instance Outputable (Warnings pass) where - ppr = pprWarns - -pprWarns :: Warnings pass -> SDoc -pprWarns NoWarnings = Outputable.empty -pprWarns (WarnAll txt) = text "Warn all" <+> ppr txt -pprWarns (WarnSome prs) = text "Warnings:" - <+> vcat (map pprWarning prs) - where pprWarning (name, txt) = ppr name <+> ppr txt - pprIfaceAnnotation :: IfaceAnnotation -> SDoc pprIfaceAnnotation (IfaceAnnotation { ifAnnotatedTarget = target, ifAnnotatedValue = serialized }) = ppr target <+> text "annotated by" <+> ppr serialized @@ -1226,3 +1222,30 @@ pprExtensibleFields (ExtensibleFields fs) = vcat . map pprField $ toList fs where pprField (name, (BinData size _data)) = text name <+> text "-" <+> ppr size <+> text "bytes" + + +-- | Reason for loading an interface file +-- +-- Used to figure out whether we want to consider loading hi-boot files or not. +data WhereFrom + = ImportByUser IsBootInterface -- Ordinary user import (perhaps {-# SOURCE #-}) + | ImportBySystem -- Non user import. + | ImportByPlugin -- Importing a plugin. + +instance Outputable WhereFrom where + ppr (ImportByUser IsBoot) = text "{- SOURCE -}" + ppr (ImportByUser NotBoot) = empty + ppr ImportBySystem = text "{- SYSTEM -}" + ppr ImportByPlugin = text "{- PLUGIN -}" + + +-- | Get gHC_PRIM interface file +-- +-- This is a helper function that takes into account the hook allowing ghc-prim +-- interface to be extended via the ghc-api. Afaik it was introduced for GHCJS +-- so that it can add its own primitive types. +getGhcPrimIface :: Hooks -> ModIface +getGhcPrimIface hooks = + case ghcPrimIfaceHook hooks of + Nothing -> ghcPrimIface + Just h -> h diff --git a/GHC/Iface/Make.hs b/GHC/Iface/Make.hs --- a/GHC/Iface/Make.hs +++ b/GHC/Iface/Make.hs @@ -13,9 +13,8 @@ ( mkPartialIface , mkFullIface , mkIfaceTc + , mkRecompUsageInfo , mkIfaceExports - , coAxiomToIfaceDecl - , tyThingToIfaceDecl -- Converting things to their Iface equivalents ) where @@ -23,11 +22,14 @@ import GHC.Hs +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 import GHC.Iface.Load @@ -38,48 +40,40 @@ import qualified GHC.LanguageExtensions as LangExt import GHC.Core import GHC.Core.Class -import GHC.Core.TyCon import GHC.Core.Coercion.Axiom -import GHC.Core.ConLike -import GHC.Core.DataCon -import GHC.Core.FVs ( orphNamesOfAxiomLHS ) -import GHC.Core.Type -import GHC.Core.Multiplicity 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.Session +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.Var.Env -import GHC.Types.Var import GHC.Types.Name import GHC.Types.Avail 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.Basic hiding ( SuccessFlag(..) ) import GHC.Types.TypeEnv import GHC.Types.SourceFile import GHC.Types.TyThing -import GHC.Types.HpcInfo import GHC.Types.CompleteMatch +import GHC.Types.Name.Cache import GHC.Utils.Outputable import GHC.Utils.Panic -import GHC.Utils.Panic.Plain -import GHC.Utils.Misc import GHC.Utils.Logger +import GHC.Utils.Binary +import GHC.Iface.Binary import GHC.Data.FastString import GHC.Data.Maybe @@ -94,13 +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 ( findIndex, mapAccumL, sortBy ) +import Data.List ( sortBy ) import Data.Ord import Data.IORef -import GHC.Stg.Pipeline (StgCgInfos) - +import Data.Traversable {- ************************************************************************ @@ -114,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. @@ -139,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 @@ -202,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, @@ -280,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, @@ -301,48 +347,48 @@ -- The order of fixities returned from nonDetNameEnvElts is not -- deterministic, so we sort by OccName to canonicalize it. -- See Note [Deterministic UniqFM] in GHC.Types.Unique.DFM for more details. - warns = src_warns + warns = toIfaceWarnings src_warns iface_rules = map coreRuleToIfaceRule rules iface_insts = map instanceToIfaceInst $ fixSafeInstances safe_mode (instEnvElts insts) iface_fam_insts = map famInstToIfaceFamInst fam_insts trust_info = setSafeMode safe_mode annotations = map mkIfaceAnnotation anns icomplete_matches = map mkIfaceCompleteMatch complete_matches + !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 = maybeGlobalRdrEnv rdr_env, - 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, @@ -352,401 +398,58 @@ 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 GlobalRdrEnv - maybeGlobalRdrEnv rdr_env - | backendWantsGlobalBindings (backend dflags) = Just rdr_env - | 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 - -{- -************************************************************************ -* * - COMPLETE Pragmas -* * -************************************************************************ --} - -mkIfaceCompleteMatch :: CompleteMatch -> IfaceCompleteMatch -mkIfaceCompleteMatch (CompleteMatch cls mtc) = - IfaceCompleteMatch (map conLikeName (uniqDSetToList cls)) (toIfaceTyCon <$> mtc) - - -{- -************************************************************************ -* * - Keeping track of what we've slurped, and fingerprints -* * -************************************************************************ --} - - -mkIfaceAnnotation :: Annotation -> IfaceAnnotation -mkIfaceAnnotation (Annotation { ann_target = target, ann_value = payload }) - = IfaceAnnotation { - ifAnnotatedTarget = fmap nameOccName target, - ifAnnotatedValue = payload - } - -mkIfaceExports :: [AvailInfo] -> [IfaceExport] -- Sort to make canonical -mkIfaceExports exports - = sortBy stableAvailCmp (map sort_subs exports) - where - sort_subs :: AvailInfo -> AvailInfo - sort_subs (Avail n) = Avail n - sort_subs (AvailTC n []) = AvailTC n [] - sort_subs (AvailTC n (m:ms)) - | NormalGreName n==m = AvailTC n (m:sortBy stableGreNameCmp ms) - | otherwise = AvailTC n (sortBy stableGreNameCmp (m:ms)) - -- Maintain the AvailTC Invariant - -{- -Note [Original module] -~~~~~~~~~~~~~~~~~~~~~ -Consider this: - module X where { data family T } - module Y( T(..) ) where { import X; data instance T Int = MkT Int } -The exported Avail from Y will look like - X.T{X.T, Y.MkT} -That is, in Y, - - only MkT is brought into scope by the data instance; - - but the parent (used for grouping and naming in T(..) exports) is X.T - - and in this case we export X.T too - -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. --} - - -{- -************************************************************************ -* * - Converting things to their Iface equivalents -* * -************************************************************************ --} - -tyThingToIfaceDecl :: Bool -> TyThing -> IfaceDecl -tyThingToIfaceDecl _ (AnId id) = idToIfaceDecl id -tyThingToIfaceDecl _ (ATyCon tycon) = snd (tyConToIfaceDecl emptyTidyEnv tycon) -tyThingToIfaceDecl _ (ACoAxiom ax) = coAxiomToIfaceDecl ax -tyThingToIfaceDecl show_linear_types (AConLike cl) = case cl of - RealDataCon dc -> dataConToIfaceDecl show_linear_types dc -- for ppr purposes only - PatSynCon ps -> patSynToIfaceDecl ps - -------------------------- -idToIfaceDecl :: Id -> IfaceDecl --- The Id is already tidied, so that locally-bound names --- (lambdas, for-alls) already have non-clashing OccNames --- We can't tidy it here, locally, because it may have --- free variables in its type or IdInfo -idToIfaceDecl id - = IfaceId { ifName = getName id, - ifType = toIfaceType (idType id), - ifIdDetails = toIfaceIdDetails (idDetails id), - ifIdInfo = toIfaceIdInfo (idInfo id) } - --------------------------- -dataConToIfaceDecl :: Bool -> DataCon -> IfaceDecl -dataConToIfaceDecl show_linear_types dataCon - = IfaceId { ifName = getName dataCon, - ifType = toIfaceType (dataConDisplayType show_linear_types dataCon), - ifIdDetails = IfVanillaId, - ifIdInfo = [] } - --------------------------- -coAxiomToIfaceDecl :: CoAxiom br -> IfaceDecl --- We *do* tidy Axioms, because they are not (and cannot --- conveniently be) built in tidy form -coAxiomToIfaceDecl ax@(CoAxiom { co_ax_tc = tycon, co_ax_branches = branches - , co_ax_role = role }) - = IfaceAxiom { ifName = getName ax - , ifTyCon = toIfaceTyCon tycon - , ifRole = role - , ifAxBranches = map (coAxBranchToIfaceBranch tycon - (map coAxBranchLHS branch_list)) - branch_list } - where - branch_list = fromBranches branches - --- 2nd parameter is the list of branch LHSs, in case of a closed type family, --- for conversion from incompatible branches to incompatible indices. --- For an open type family the list should be empty. --- See Note [Storing compatibility] in GHC.Core.Coercion.Axiom -coAxBranchToIfaceBranch :: TyCon -> [[Type]] -> CoAxBranch -> IfaceAxBranch -coAxBranchToIfaceBranch tc lhs_s - (CoAxBranch { cab_tvs = tvs, cab_cvs = cvs - , cab_eta_tvs = eta_tvs - , cab_lhs = lhs, cab_roles = roles - , cab_rhs = rhs, cab_incomps = incomps }) - - = IfaceAxBranch { ifaxbTyVars = toIfaceTvBndrs tvs - , ifaxbCoVars = map toIfaceIdBndr cvs - , ifaxbEtaTyVars = toIfaceTvBndrs eta_tvs - , ifaxbLHS = toIfaceTcArgs tc lhs - , ifaxbRoles = roles - , ifaxbRHS = toIfaceType rhs - , ifaxbIncomps = iface_incomps } - where - iface_incomps = map (expectJust "iface_incomps" - . flip findIndex lhs_s - . eqTypes - . coAxBranchLHS) incomps - ------------------ -tyConToIfaceDecl :: TidyEnv -> TyCon -> (TidyEnv, IfaceDecl) --- We *do* tidy TyCons, because they are not (and cannot --- conveniently be) built in tidy form --- The returned TidyEnv is the one after tidying the tyConTyVars -tyConToIfaceDecl env tycon - | Just clas <- tyConClass_maybe tycon - = classToIfaceDecl env clas - - | Just syn_rhs <- synTyConRhs_maybe tycon - = ( tc_env1 - , IfaceSynonym { ifName = getName tycon, - ifRoles = tyConRoles tycon, - ifSynRhs = if_syn_type syn_rhs, - ifBinders = if_binders, - ifResKind = if_res_kind - }) - - | Just fam_flav <- famTyConFlav_maybe tycon - = ( tc_env1 - , IfaceFamily { ifName = getName tycon, - ifResVar = if_res_var, - ifFamFlav = to_if_fam_flav fam_flav, - ifBinders = if_binders, - ifResKind = if_res_kind, - ifFamInj = tyConInjectivityInfo tycon - }) - - | isAlgTyCon tycon - = ( tc_env1 - , IfaceData { ifName = getName tycon, - ifBinders = if_binders, - ifResKind = if_res_kind, - ifCType = tyConCType_maybe tycon, - ifRoles = tyConRoles tycon, - ifCtxt = tidyToIfaceContext tc_env1 (tyConStupidTheta tycon), - ifCons = ifaceConDecls (algTyConRhs tycon), - ifGadtSyntax = isGadtSyntaxTyCon tycon, - ifParent = parent }) - - | otherwise -- FunTyCon, PrimTyCon, promoted TyCon/DataCon - -- We only convert these TyCons to IfaceTyCons when we are - -- just about to pretty-print them, not because we are going - -- to put them into interface files - = ( env - , IfaceData { ifName = getName tycon, - ifBinders = if_binders, - ifResKind = if_res_kind, - ifCType = Nothing, - ifRoles = tyConRoles tycon, - ifCtxt = [], - ifCons = IfDataTyCon False [], - ifGadtSyntax = False, - ifParent = IfNoParent }) - where - -- NOTE: Not all TyCons have `tyConTyVars` field. Forcing this when `tycon` - -- is one of these TyCons (FunTyCon, PrimTyCon, PromotedDataCon) will cause - -- an error. - (tc_env1, tc_binders) = tidyTyConBinders env (tyConBinders tycon) - tc_tyvars = binderVars tc_binders - if_binders = toIfaceForAllBndrs tc_binders - -- No tidying of the binders; they are already tidy - if_res_kind = tidyToIfaceType tc_env1 (tyConResKind tycon) - if_syn_type ty = tidyToIfaceType tc_env1 ty - if_res_var = getOccFS `fmap` tyConFamilyResVar_maybe tycon - - parent = case tyConFamInstSig_maybe tycon of - Just (tc, ty, ax) -> IfDataInstance (coAxiomName ax) - (toIfaceTyCon tc) - (tidyToIfaceTcArgs tc_env1 tc ty) - Nothing -> IfNoParent - - to_if_fam_flav OpenSynFamilyTyCon = IfaceOpenSynFamilyTyCon - to_if_fam_flav AbstractClosedSynFamilyTyCon = IfaceAbstractClosedSynFamilyTyCon - to_if_fam_flav (DataFamilyTyCon {}) = IfaceDataFamilyTyCon - to_if_fam_flav (BuiltInSynFamTyCon {}) = IfaceBuiltInSynFamTyCon - to_if_fam_flav (ClosedSynFamilyTyCon Nothing) = IfaceClosedSynFamilyTyCon Nothing - to_if_fam_flav (ClosedSynFamilyTyCon (Just ax)) - = IfaceClosedSynFamilyTyCon (Just (axn, ibr)) - where defs = fromBranches $ coAxiomBranches ax - lhss = map coAxBranchLHS defs - 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.) - - ifaceConDecl data_con - = IfCon { ifConName = dataConName data_con, - ifConInfix = dataConIsInfix data_con, - ifConWrapper = isJust (dataConWrapId_maybe data_con), - ifConExTCvs = map toIfaceBndr ex_tvs', - ifConUserTvBinders = toIfaceForAllBndrs user_bndrs', - ifConEqSpec = map (to_eq_spec . eqSpecPair) eq_spec, - ifConCtxt = tidyToIfaceContext con_env2 theta, - ifConArgTys = - map (\(Scaled w t) -> (tidyToIfaceType con_env2 w - , (tidyToIfaceType con_env2 t))) arg_tys, - ifConFields = dataConFieldLabels data_con, - ifConStricts = map (toIfaceBang con_env2) - (dataConImplBangs data_con), - ifConSrcStricts = map toIfaceSrcBang - (dataConSrcBangs data_con)} - where - (univ_tvs, ex_tvs, eq_spec, theta, arg_tys, _) - = dataConFullSig data_con - user_bndrs = dataConUserTyVarBinders data_con - - -- Tidy the univ_tvs of the data constructor to be identical - -- to the tyConTyVars of the type constructor. This means - -- (a) we don't need to redundantly put them into the interface file - -- (b) when pretty-printing an Iface data declaration in H98-style syntax, - -- 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)) - -- A bit grimy, perhaps, but it's simple! - - (con_env2, ex_tvs') = tidyVarBndrs con_env1 ex_tvs - user_bndrs' = map (tidyUserForAllTyBinder con_env2) user_bndrs - to_eq_spec (tv,ty) = (tidyTyVar con_env2 tv, tidyToIfaceType con_env2 ty) - - -- By this point, we have tidied every universal and existential - -- tyvar. Because of the dcUserForAllTyBinders invariant - -- (see Note [DataCon user type variable binders]), *every* - -- user-written tyvar must be contained in the substitution that - -- 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 env (Bndr tv vis) = - Bndr (tidyTyCoVarOcc env tv) vis - -classToIfaceDecl :: TidyEnv -> Class -> (TidyEnv, IfaceDecl) -classToIfaceDecl env clas - = ( env1 - , IfaceClass { ifName = getName tycon, - ifRoles = tyConRoles (classTyCon clas), - ifBinders = toIfaceForAllBndrs tc_binders, - ifBody = body, - ifFDs = map toIfaceFD clas_fds }) +defaultsToIfaceDefaults :: DefaultEnv -> [IfaceDefault] +defaultsToIfaceDefaults = map toIface . defaultList where - (_, clas_fds, sc_theta, _, clas_ats, op_stuff) - = classExtraBigSig clas - tycon = classTyCon clas - - body | isAbstractTyCon tycon = IfAbstractClass - | otherwise - = IfConcreteClass { - ifClassCtxt = tidyToIfaceContext env1 sc_theta, - ifATs = map toIfaceAT clas_ats, - ifSigs = map toIfaceClassOp op_stuff, - ifMinDef = fmap getOccFS (classMinimalDef clas) - } - - (env1, tc_binders) = tidyTyConBinders env (tyConBinders tycon) - - toIfaceAT :: ClassATItem -> IfaceAT - toIfaceAT (ATI tc def) - = IfaceAT if_decl (fmap (tidyToIfaceType env2 . fst) def) - where - (env2, if_decl) = tyConToIfaceDecl env1 tc - - toIfaceClassOp (sel_id, def_meth) - = assert (sel_tyvars == binderVars tc_binders) $ - IfaceClassOp (getName sel_id) - (tidyToIfaceType env1 op_ty) - (fmap toDmSpec def_meth) - where - -- Be careful when splitting the type, because of things - -- like class Foo a where - -- op :: (?x :: String) => a -> a - -- and class Baz a where - -- op :: (Ord a) => a -> a - (sel_tyvars, rho_ty) = splitForAllTyCoVars (idType sel_id) - op_ty = funResultTy rho_ty - - toDmSpec :: (Name, DefMethSpec Type) -> DefMethSpec IfaceType - toDmSpec (_, VanillaDM) = VanillaDM - toDmSpec (_, GenericDM dm_ty) = GenericDM (tidyToIfaceType env1 dm_ty) - - toIfaceFD (tvs1, tvs2) = (map (tidyTyVar env1) tvs1 - ,map (tidyTyVar env1) tvs2) - --------------------------- - -tidyTyConBinder :: TidyEnv -> TyConBinder -> (TidyEnv, TyConBinder) --- If the type variable "binder" is in scope, don't re-bind it --- In a class decl, for example, the ATD binders mention --- (amd must mention) the class tyvars -tidyTyConBinder env@(_, subst) tvb@(Bndr tv vis) - = case lookupVarEnv subst tv of - Just tv' -> (env, Bndr tv' vis) - Nothing -> tidyForAllTyBinder env tvb - -tidyTyConBinders :: TidyEnv -> [TyConBinder] -> (TidyEnv, [TyConBinder]) -tidyTyConBinders = mapAccumL tidyTyConBinder - -tidyTyVar :: TidyEnv -> TyVar -> FastString -tidyTyVar (_, subst) tv = toIfaceTyVar (lookupVarEnv subst tv `orElse` tv) + 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 , ifInstCls = cls_name , ifInstTys = ifaceRoughMatchTcs $ tail rough_tcs -- N.B. Drop the class name from the rough match template - -- It is put back by GHC.Core.InstEnv.mkImportedInstance - , ifInstOrph = orph } + -- It is put back by GHC.Core.InstEnv.mkImportedClsInst + , ifInstOrph = orph + , ifInstWarn = fmap toIfaceWarningTxt warn } -------------------------- famInstToIfaceFamInst :: FamInst -> IfaceFamInst -famInstToIfaceFamInst (FamInst { fi_axiom = axiom, - fi_fam = fam, - fi_tcs = rough_tcs }) +famInstToIfaceFamInst (FamInst { fi_axiom = axiom + , fi_fam = fam + , fi_tcs = rough_tcs + , fi_orphan = orphan }) = IfaceFamInst { ifFamInstAxiom = coAxiomName axiom , ifFamInstFam = fam , ifFamInstTys = ifaceRoughMatchTcs rough_tcs - , ifFamInstOrph = orph } - where - fam_decl = tyConName $ coAxiomTyCon axiom - mod = assert (isExternalName (coAxiomName axiom)) $ - nameModule (coAxiomName axiom) - is_local name = nameIsLocalOrFrom mod name - - lhs_names = filterNameSet is_local (orphNamesOfAxiomLHS axiom) - - orph | is_local fam_decl - = NotOrphan (nameOccName fam_decl) - | otherwise - = chooseOrphanAnchor lhs_names + , ifFamInstOrph = orphan } ifaceRoughMatchTcs :: [RoughMatchTc] -> [Maybe IfaceTyCon] ifaceRoughMatchTcs tcs = map do_rough tcs @@ -782,3 +485,84 @@ do_arg (Type ty) = IfaceType (toIfaceType (deNoteType ty)) do_arg (Coercion co) = IfaceCo (toIfaceCoercion co) do_arg arg = toIfaceExpr arg + + +{- +************************************************************************ +* * + COMPLETE Pragmas +* * +************************************************************************ +-} + +mkIfaceCompleteMatch :: CompleteMatch -> IfaceCompleteMatch +mkIfaceCompleteMatch (CompleteMatch cls mtc) = + -- NB: Sorting here means that COMPLETE {P, Q} and COMPLETE {Q, P} are + -- considered identical, in particular for recompilation checking. + IfaceCompleteMatch (sortBy stableNameCmp $ uniqDSetToList cls) mtc + + +{- +************************************************************************ +* * + Keeping track of what we've slurped, and fingerprints +* * +************************************************************************ +-} + + +mkIfaceAnnotation :: Annotation -> IfaceAnnotation +mkIfaceAnnotation (Annotation { ann_target = target, ann_value = payload }) + = IfaceAnnotation { + ifAnnotatedTarget = fmap nameOccName target, + ifAnnotatedValue = payload + } + +mkIfaceImports :: [ImportUserSpec] -> [IfaceImport] +mkIfaceImports = map go + where + 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] +~~~~~~~~~~~~~~~~~~~~~ +Consider this: + module X where { data family T } + module Y( T(..) ) where { import X; data instance T Int = MkT Int } +The exported Avail from Y will look like + X.T{X.T, Y.MkT} +That is, in Y, + - only MkT is brought into scope by the data instance; + - but the parent (used for grouping and naming in T(..) exports) is X.T + - and in this case we export X.T too + +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,1633 +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.Session -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 -import GHC.Types.Unique.Set -import GHC.Types.Fixity.Env -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 - -{- - ----------------------------------------------- - 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 - 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" - -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 - trace_if logger (text "FYI: cannot read old interface file:" $$ nest 4 err) - trace_hi_diffs logger (text "Old interface file was invalid:" $$ nest 4 err) - 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 Map.lookup (ms_mod_name mod_summary) - (requirementContext unit_state) 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 file - if (old_hash /= new_hash) - then return recomp - else return UpToDate - where - reason = FileChanged 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 - warn_fn = mkIfaceWarnCache (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 Unique IfaceDeclABI ] - edges = [ DigraphNode abi (getUnique (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 (getUnique . 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 = stronglyConnCompFromEdgedVerticesUniq 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 _ _ _) = 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_warn_fn = 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 . withException 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 . withException 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. @@ -231,14 +235,14 @@ return (renameHoleModule unit_state hmap mod) rnAvailInfo :: Rename AvailInfo -rnAvailInfo (Avail c) = Avail <$> rnGreName c +rnAvailInfo (Avail c) = Avail <$> rnIfaceGlobal c rnAvailInfo (AvailTC n ns) = do -- Why don't we rnIfaceGlobal the availName itself? It may not -- actually be exported by the module it putatively is from, in -- which case we won't be able to tell what the name actually -- is. But for the availNames they MUST be exported, so they -- will rename fine. - ns' <- mapM rnGreName ns + ns' <- mapM rnIfaceGlobal ns case ns' of [] -> panic "rnAvailInfoEmpty AvailInfo" (rep:rest) -> assertPpr (all ((== childModule rep) . childModule) rest) @@ -246,11 +250,7 @@ n' <- setNameModule (Just (childModule rep)) n return (AvailTC n' ns') where - childModule = nameModule . greNameMangledName - -rnGreName :: Rename GreName -rnGreName (NormalGreName n) = NormalGreName <$> rnIfaceGlobal n -rnGreName (FieldGreName fl) = FieldGreName <$> rnFieldLabel fl + childModule = nameModule rnFieldLabel :: Rename FieldLabel rnFieldLabel fl = do @@ -258,8 +258,6 @@ return (fl { flSelector = sel' }) - - -- | The key function. This gets called on every Name embedded -- inside a ModIface. Our job is to take a Name from some -- generalized unit ID p[A=\, B=\], and change @@ -409,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 @@ -665,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) @@ -704,9 +701,12 @@ rnIfaceExprs = mapM rnIfaceExpr rnIfaceIdDetails :: Rename IfaceIdDetails -rnIfaceIdDetails (IfRecSelId (Left tc) b) = IfRecSelId <$> fmap Left (rnIfaceTyCon tc) <*> pure b -rnIfaceIdDetails (IfRecSelId (Right decl) b) = IfRecSelId <$> fmap Right (rnIfaceDecl decl) <*> pure b -rnIfaceIdDetails details = pure details +rnIfaceIdDetails (IfRecSelId (Left tc) con naughty fl) + = IfRecSelId <$> fmap Left (rnIfaceTyCon tc) <*> rnIfaceGlobal con <*> pure naughty <*> rnFieldLabel fl +rnIfaceIdDetails (IfRecSelId (Right decl) con naughty fl) + = IfRecSelId <$> fmap Right (rnIfaceDecl decl) <*> rnIfaceGlobal con <*> pure naughty <*> rnFieldLabel fl +rnIfaceIdDetails details + = pure details rnIfaceType :: Rename IfaceType rnIfaceType (IfaceFreeTyVar n) = pure (IfaceFreeTyVar n) diff --git a/GHC/Iface/Syntax.hs b/GHC/Iface/Syntax.hs --- a/GHC/Iface/Syntax.hs +++ b/GHC/Iface/Syntax.hs @@ -12,18 +12,22 @@ 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, - IfaceClsInst(..), IfaceFamInst(..), IfaceTickish(..), - IfaceClassBody(..), + IfaceWarnings(..), IfaceWarningTxt(..), IfaceStringLiteral(..), + IfaceDefault(..), IfaceClsInst(..), IfaceFamInst(..), IfaceTickish(..), + IfaceClassBody(..), IfaceBooleanFormula(..), IfaceBang(..), IfaceSrcBang(..), SrcUnpackedness(..), SrcStrictness(..), IfaceAxBranch(..), IfaceTyConParent(..), IfaceCompleteMatch(..), IfaceLFInfo(..), IfaceTopBndrInfo(..), + IfaceImport(..), + ifImpModule, + ImpIfaceList(..), IfaceExport, -- * Binding names IfaceTopBndr, @@ -32,9 +36,11 @@ -- Misc ifaceDeclImplicitBndrs, visibleIfConDecls, ifaceDeclFingerprints, - + fromIfaceWarnings, + fromIfaceWarningTxt, -- Free Names freeNamesIfDecl, freeNamesIfRule, freeNamesIfFamInst, + freeNamesIfConDecls, -- Pretty printing pprIfaceExpr, @@ -44,6 +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 ) @@ -54,37 +64,45 @@ 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.Data.BooleanFormula ( BooleanFormula, pprBooleanFormula, isTrue ) +import GHC.Types.SourceText 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(..) ) 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.Basic (FieldLabelString(..)) +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 &&& @@ -96,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 @@ -109,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, @@ -191,9 +255,25 @@ ifClassCtxt :: IfaceContext, -- Super classes ifATs :: [IfaceAT], -- Associated type families ifSigs :: [IfaceClassOp], -- Method signatures - ifMinDef :: BooleanFormula IfLclName -- 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 + + data IfaceTyConParent = IfNoParent | IfDataInstance @@ -261,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 @@ -289,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, @@ -323,6 +414,18 @@ ifRuleOrph :: IsOrphan -- Just like IfaceClsInst } +data IfaceWarnings + = IfWarnAll IfaceWarningTxt + | IfWarnSome [(OccName, IfaceWarningTxt)] + [(IfExtName, IfaceWarningTxt)] + +data IfaceWarningTxt + = IfWarningTxt (Maybe WarningCategory) SourceText [(IfaceStringLiteral, [IfExtName])] + | IfDeprecatedTxt SourceText [(IfaceStringLiteral, [IfExtName])] + +data IfaceStringLiteral + = IfStringLiteral SourceText FastString + data IfaceAnnotation = IfaceAnnotation { ifAnnotatedTarget :: IfaceAnnTarget, @@ -331,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 @@ -385,7 +488,11 @@ data IfaceIdDetails = IfVanillaId | IfWorkerLikeId [CbvMark] - | IfRecSelId (Either IfaceTyCon IfaceDecl) Bool + | IfRecSelId + { ifRecSelIdParent :: Either IfaceTyCon IfaceDecl + , ifRecSelFirstCon :: IfaceTopBndr + , ifRecSelIdIsNaughty :: Bool + , ifRecSelIdFieldLabel :: FieldLabel } | IfDFunId -- | Iface type for LambdaFormInfo. Fields not relevant for imported Ids are @@ -443,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] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -494,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] ++ @@ -509,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 _ = [] @@ -541,10 +650,26 @@ [ (occ, computeFingerprint' (hash,occ)) | occ <- ifaceDeclImplicitBndrs decl ] where - computeFingerprint' = - unsafeDupablePerformIO - . computeFingerprint (panic "ifaceDeclFingerprints") + computeFingerprint' = computeFingerprint (panic "ifaceDeclFingerprints") +fromIfaceWarnings :: IfaceWarnings -> Warnings GhcRn +fromIfaceWarnings = \case + IfWarnAll txt -> WarnAll (fromIfaceWarningTxt txt) + IfWarnSome vs ds -> WarnSome [(occ, fromIfaceWarningTxt txt) | (occ, txt) <- vs] + [(occ, fromIfaceWarningTxt txt) | (occ, txt) <- ds] + +fromIfaceWarningTxt :: IfaceWarningTxt -> WarningTxt GhcRn +fromIfaceWarningTxt = \case + 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) + +fromIfaceStringLiteral :: IfaceStringLiteral -> StringLiteral +fromIfaceStringLiteral (IfStringLiteral st fs) = StringLiteral st fs Nothing + + {- ************************************************************************ * * @@ -571,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 String -- 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 @@ -596,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 @@ -604,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] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -696,6 +819,27 @@ text "--" <+> text "incompatible with:" <+> pprWithCommas (\incomp -> text "#" <> ppr incomp) incomps +instance Outputable IfaceWarnings where + ppr = \case + IfWarnAll txt -> text "Warn all" <+> ppr txt + IfWarnSome vs ds -> + hang (text "Warnings:") 2 $ + text "Deprecated names:" <+> vcat [ppr name <+> ppr txt | (name, txt) <- vs] $$ + text "Deprecated exports:" <+> vcat [ppr name <+> ppr txt | (name, txt) <- ds] + +instance Outputable IfaceWarningTxt where + ppr = \case + IfWarningTxt _ _ ws -> pp_ws ws + IfDeprecatedTxt _ ds -> pp_ws ds + where + pp_ws [msg] = pp_with_name msg + pp_ws msgs = brackets $ vcat . punctuate comma . map pp_with_name $ msgs + + pp_with_name = ppr . fst + +instance Outputable IfaceStringLiteral where + ppr (IfStringLiteral st fs) = pprWithSourceText st (ftext fs) + instance Outputable IfaceAnnotation where ppr (IfaceAnnotation target value) = ppr target <+> colon <+> ppr value @@ -745,27 +889,6 @@ filtered and hide it in that case. -} -data ShowSub - = ShowSub - { ss_how_much :: ShowHowMuch - , ss_forall :: ShowForAllFlag } - --- See Note [Printing IfaceDecl binders] --- The alternative pretty printer referred to in the note. -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 - | ShowIface - -- ^Everything including GHC-internal information (used in --show-iface) - {- Note [Printing IfaceDecl binders] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -779,15 +902,13 @@ everything unqualified, so we can just print the OccName directly. -} -instance Outputable ShowHowMuch where - ppr (ShowHeader _) = text "ShowHeader" - ppr ShowIface = text "ShowIface" - ppr (ShowSome occs _) = text "ShowSome" <+> ppr occs - +-- | 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 } @@ -798,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 "..." @@ -839,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 @@ -870,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 @@ -926,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 minDef)])] + , 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 @@ -969,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 || @@ -1002,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 @@ -1034,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") @@ -1111,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 @@ -1168,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 @@ -1212,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 @@ -1235,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 @@ -1299,7 +1658,7 @@ | otherwise = Nothing where sel = flSelector lbl - occ = mkVarOccFS (field_label $ flLabel lbl) + occ = nameOccName sel mk_user_con_res_ty :: IfaceEqSpec -> SDoc -- See Note [Result type of a data family GADT] @@ -1346,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 @@ -1487,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 @@ -1496,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 @@ -1504,10 +1869,10 @@ instance Outputable IfaceIdDetails where ppr IfVanillaId = Outputable.empty ppr (IfWorkerLikeId dmd) = text "StrWork" <> parens (ppr dmd) - ppr (IfRecSelId tc b) = text "RecSel" <+> ppr tc - <+> if b - then text "" - else Outputable.empty + ppr (IfRecSelId tc _c b _fl) = text "RecSel" <+> ppr tc + <+> if b + then text "" + else Outputable.empty ppr IfDFunId = text "DFunId" instance Outputable IfaceInfoItem where @@ -1522,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 ] @@ -1623,9 +1984,13 @@ freeNamesIfType rhs freeNamesIfIdDetails :: IfaceIdDetails -> NameSet -freeNamesIfIdDetails (IfRecSelId tc _) = - either freeNamesIfTc freeNamesIfDecl tc -freeNamesIfIdDetails _ = emptyNameSet +freeNamesIfIdDetails (IfRecSelId tc first_con _ fl) = + either freeNamesIfTc freeNamesIfDecl tc &&& + unitFV first_con &&& + unitFV (flSelector fl) +freeNamesIfIdDetails IfVanillaId = emptyNameSet +freeNamesIfIdDetails (IfWorkerLikeId {}) = emptyNameSet +freeNamesIfIdDetails IfDFunId = emptyNameSet -- All other changes are handled via the version info on the tycon freeNamesIfFamFlav :: IfaceFamTyConFlav -> NameSet @@ -1657,7 +2022,7 @@ freeNamesIfConDecls :: IfaceConDecls -> NameSet freeNamesIfConDecls (IfDataTyCon _ cs) = fnList freeNamesIfConDecl cs freeNamesIfConDecls (IfNewTyCon c) = freeNamesIfConDecl c -freeNamesIfConDecls _ = emptyNameSet +freeNamesIfConDecls _ = emptyNameSet freeNamesIfConDecl :: IfaceConDecl -> NameSet freeNamesIfConDecl (IfCon { ifConExTCvs = ex_tvs, ifConCtxt = ctxt @@ -1710,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) @@ -1733,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 @@ -1791,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 @@ -1801,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 @@ -1838,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 @@ -1860,7 +2226,7 @@ data DynFlags = DF ... PackageState ... module Packages where - import GHC.Driver.Session + import GHC.Driver.DynFlags data PackageState = PS ... lookupModule (df :: DynFlags) = case df of @@ -1930,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 @@ -1943,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 @@ -2016,6 +2384,7 @@ a6 <- get bh a7 <- get bh a8 <- get bh + a9 <- get bh return (IfaceClass { ifName = a2, ifRoles = a3, @@ -2023,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 @@ -2056,6 +2426,20 @@ ifBody = IfAbstractClass }) _ -> panic (unwords ["Unknown IfaceDecl tag:", show h]) +instance Binary IfaceBooleanFormula where + put_ bh = \case + IfVar a1 -> putByte bh 0 >> put_ bh a1 + IfAnd a1 -> putByte bh 1 >> put_ bh a1 + IfOr a1 -> putByte bh 2 >> put_ bh a1 + IfParens a1 -> putByte bh 3 >> put_ bh a1 + + get bh = do + getByte bh >>= \case + 0 -> IfVar <$> get bh + 1 -> IfAnd <$> get bh + 2 -> IfOr <$> get bh + _ -> IfParens <$> get bh + {- Note [Lazy deserialization of IfaceId] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The use of lazyPut and lazyGet in the IfaceId Binary instance is @@ -2205,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 @@ -2254,6 +2651,27 @@ a8 <- get bh return (IfaceRule a1 a2 a3 a4 a5 a6 a7 a8) +instance Binary IfaceWarnings where + put_ bh = \case + IfWarnAll txt -> putByte bh 0 *> put_ bh txt + IfWarnSome vs ds -> putByte bh 1 *> put_ bh vs *> put_ bh ds + get bh = getByte bh >>= \case + 0 -> pure IfWarnAll <*> get bh + 1 -> pure IfWarnSome <*> get bh <*> get bh + _ -> fail "invalid tag(IfaceWarnings)" + +instance Binary IfaceWarningTxt where + put_ bh = \case + IfWarningTxt a1 a2 a3 -> putByte bh 0 *> put_ bh a1 *> put_ bh a2 *> put_ bh a3 + IfDeprecatedTxt a1 a2 -> putByte bh 1 *> put_ bh a1 *> put_ bh a2 + get bh = getByte bh >>= \case + 0 -> pure IfWarningTxt <*> get bh <*> get bh <*> get bh + _ -> pure IfDeprecatedTxt <*> get bh <*> get bh + +instance Binary IfaceStringLiteral where + put_ bh (IfStringLiteral a1 a2) = put_ bh a1 *> put_ bh a2 + get bh = IfStringLiteral <$> get bh <*> get bh + instance Binary IfaceAnnotation where put_ bh (IfaceAnnotation a1 a2) = do put_ bh a1 @@ -2264,16 +2682,25 @@ return (IfaceAnnotation a1 a2) instance Binary IfaceIdDetails where - put_ bh IfVanillaId = putByte bh 0 - put_ bh (IfRecSelId a b) = putByte bh 1 >> put_ bh a >> put_ bh b + put_ bh IfVanillaId = putByte bh 0 + put_ bh (IfRecSelId a b c d) = do { putByte bh 1 + ; put_ bh a + ; put_ bh b + ; put_ bh c + ; put_ bh d } put_ bh (IfWorkerLikeId dmds) = putByte bh 2 >> put_ bh dmds - put_ bh IfDFunId = putByte bh 3 + put_ bh IfDFunId = putByte bh 3 get bh = do h <- getByte bh case h of 0 -> return IfVanillaId - 1 -> do { a <- get bh; b <- get bh; return (IfRecSelId a b) } - 2 -> do { dmds <- get bh; return (IfWorkerLikeId dmds) } + 1 -> do { a <- get bh + ; b <- get bh + ; c <- get bh + ; d <- get bh + ; return (IfRecSelId a b c d) } + 2 -> do { dmds <- get bh + ; return (IfWorkerLikeId dmds) } _ -> return IfDFunId instance Binary IfaceInfoItem where @@ -2339,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 @@ -2355,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 @@ -2424,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 @@ -2473,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 @@ -2496,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 @@ -2516,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 @@ -2580,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 @@ -2624,48 +3049,63 @@ ************************************************************************ -} +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` 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 + IfVar f1 -> rnf f1 + IfAnd f1 -> rnf f1 + IfOr f1 -> rnf f1 + IfParens f1 -> rnf f1 + instance NFData IfaceAT where 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 @@ -2680,44 +3120,46 @@ 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` () - IfRecSelId (Left tycon) b -> rnf tycon `seq` rnf b - IfRecSelId (Right decl) b -> rnf decl `seq` rnf b + 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 -> () instance NFData IfaceInfoItem where 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 @@ -2725,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 @@ -2746,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 @@ -2765,35 +3207,50 @@ 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 + IfWarnAll txt -> rnf txt + 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 + +instance NFData IfaceStringLiteral where + 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, @@ -29,6 +24,7 @@ IfaceTvBndr, IfaceIdBndr, IfaceTyConBinder, IfaceForAllSpecBndr, IfaceForAllBndr, ForAllTyFlag(..), FunTyFlag(..), ShowForAllFlag(..), + ShowSub(..), ShowHowMuch(..), AltPpr(..), mkIfaceForAllTvBndr, mkIfaceTyConKind, ifaceForAllSpecToBndrs, ifaceForAllSpecToBndr, @@ -36,6 +32,8 @@ ifForAllBndrVar, ifForAllBndrName, ifaceBndrName, ifTyConBinderVar, ifTyConBinderName, + -- Binary utilities + putIfaceType, getIfaceType, ifaceTypeSharedByte, -- Equality testing isIfaceLiftedTypeKind, @@ -46,6 +44,7 @@ SuppressBndrSig(..), UseBndrParens(..), PrintExplicitKinds(..), + PrintArityInvisibles(..), pprIfaceType, pprParendIfaceType, pprPrecIfaceType, pprIfaceContext, pprIfaceContextArr, pprIfaceIdBndr, pprIfaceLamBndr, pprIfaceTvBndr, pprIfaceTyConBinders, @@ -58,6 +57,7 @@ isIfaceRhoType, suppressIfaceInvisibles, + visibleTypeVarOccurencies, stripIfaceInvisVars, stripInvisArgs, @@ -74,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 @@ -92,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 {- ************************************************************************ @@ -104,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) @@ -133,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 @@ -156,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 @@ -180,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 @@ -188,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 @@ -206,7 +254,7 @@ mkIfaceTyConKind bndrs res_kind = foldr mk res_kind bndrs where mk :: IfaceTyConBinder -> IfaceKind -> IfaceKind - mk (Bndr tv (AnonTCB af)) k = IfaceFunTy af many_ty (ifaceBndrType tv) k + mk (Bndr tv AnonTCB) k = IfaceFunTy FTF_T_T many_ty (ifaceBndrType tv) k mk (Bndr tv (NamedTCB vis)) k = IfaceForAllTy (Bndr tv vis) k ifaceForAllSpecToBndrs :: [IfaceForAllSpecBndr] -> [IfaceForAllBndr] @@ -232,6 +280,7 @@ -- arguments in @{...}. IfaceAppArgs -- The rest of the arguments + deriving (Eq, Ord) instance Semi.Semigroup IfaceAppArgs where IA_Nil <> xs = xs @@ -246,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 @@ -267,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" @@ -275,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 @@ -361,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 @@ -380,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 @@ -395,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] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -514,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 @@ -524,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 @@ -564,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 @@ -574,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] @@ -608,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) @@ -617,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 @@ -635,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 @@ -681,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] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -820,7 +993,7 @@ pprIfaceLamBndr (b, IfaceOneShot) = ppr b <> text "[OneShot]" pprIfaceIdBndr :: IfaceIdBndr -> SDoc -pprIfaceIdBndr (w, name, ty) = parens (ppr name <> brackets (ppr w) <+> dcolon <+> ppr ty) +pprIfaceIdBndr (w, name, ty) = parens (ppr name <> brackets (ppr_ty_nested w) <+> dcolon <+> ppr_ty_nested ty) {- Note [Suppressing binder signatures] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -848,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 @@ -880,7 +1053,7 @@ pprIfaceTvBndr (tv, ki) (SuppressBndrSig suppress_sig) (UseBndrParens use_parens) | suppress_sig = ppr tv | isIfaceLiftedTypeKind ki = ppr tv - | otherwise = maybe_parens (ppr tv <+> dcolon <+> ppr ki) + | otherwise = maybe_parens (ppr tv <+> dcolon <+> ppr_ty_nested ki) where maybe_parens | use_parens = parens | otherwise = id @@ -893,12 +1066,7 @@ go (Bndr (IfaceTvBndr bndr) vis) = -- See Note [Pretty-printing invisible arguments] case vis of - AnonTCB af - | isVisibleFunArg af -> ppr_bndr (UseBndrParens True) - | otherwise -> char '@' <> braces (ppr_bndr (UseBndrParens False)) - -- The above case is rare. (See Note [AnonTCB with constraint arg] - -- in GHC.Core.TyCon.) - -- Should we print these differently? + AnonTCB -> ppr_bndr (UseBndrParens True) NamedTCB Required -> ppr_bndr (UseBndrParens True) NamedTCB Specified -> char '@' <> ppr_bndr (UseBndrParens True) NamedTCB Inferred -> char '@' <> braces (ppr_bndr (UseBndrParens False)) @@ -937,9 +1105,13 @@ instance Outputable IfaceType where ppr ty = pprIfaceType ty -pprIfaceType, pprParendIfaceType :: IfaceType -> SDoc +-- The purpose of 'ppr_ty_nested' is to distinguish calls that should not +-- trigger 'hideNonStandardTypes', see Note [Defaulting RuntimeRep variables] +-- wrinkle (W2). +pprIfaceType, pprParendIfaceType, ppr_ty_nested :: IfaceType -> SDoc pprIfaceType = pprPrecIfaceType topPrec pprParendIfaceType = pprPrecIfaceType appPrec +ppr_ty_nested = ppr_ty topPrec pprPrecIfaceType :: PprPrec -> IfaceType -> SDoc -- We still need `hideNonStandardTypes`, since the `pprPrecIfaceType` may be @@ -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 @@ -991,7 +1163,7 @@ | isVisibleFunArg af = (pprTypeArrow af wthis <+> ppr_ty funPrec ty1) : ppr_fun_tail wnext ty2 ppr_fun_tail wthis other_ty - = [pprTypeArrow af wthis <+> pprIfaceType other_ty] + = [pprTypeArrow af wthis <+> ppr_ty_nested other_ty] ppr_ty ctxt_prec (IfaceAppTy t ts) = if_print_coercions @@ -1048,9 +1220,11 @@ syntactic overhead. For this reason it was decided that we would hide RuntimeRep variables -for now (see #11549). We do this by defaulting all type variables of -kind RuntimeRep to LiftedRep. -Likewise, we default all Multiplicity variables to Many. +for now (see #11549). We do this right in the pretty-printer, by pre-processing +the type we are about to print, to default any type variables of kind RuntimeRep +that are bound by toplevel invisible quantification to LiftedRep. +Likewise, we default Multiplicity variables to Many and Levity variables to +Lifted. This is done in a pass right before pretty-printing (defaultIfaceTyVarsOfKind, controlled by @@ -1077,6 +1251,32 @@ There's one exception though: TyVarTv metavariables should not be defaulted, as they appear during kind-checking of "newtype T :: TYPE r where..." (test T18357a). Therefore, we additionally test for isTyConableTyVar. + +Wrinkles: + +(W1) The loop 'go' in 'defaultIfaceTyVarsOfKind' passes a Bool flag, 'rank1', + around that indicates whether we haven't yet descended into the arguments + of a function type. + This is used to decide whether newly bound variables are eligible for + defaulting – we do not want contravariant foralls to be defaulted because + that would result in an incorrect, rather than specialized, type. + For example: + ∀ p (r1 :: RuntimeRep) . (∀ (r2 :: RuntimeRep) . p r2) -> p r1 + We want to default 'r1', but not 'r2'. + When examining the first forall, 'rank1' is True. + The toplevel function type is matched as IfaceFunTy, where we recurse into + 'go' by passing False for 'rank1'. + The forall in the first argument then skips adding a substitution for 'r2'. + +(W2) 'defaultIfaceTyVarsOfKind' ought to be called only once when printing a + type. + A few components of the printing machinery used to invoke 'ppr' on types + nested in secondary structures like IfaceBndr, which would repeat the + defaulting process, but treating the type as if it were top-level, causing + unwanted defaulting. + In order to prevent future developers from using 'ppr' again or being + confused that @ppr_ty topPrec@ is used, we introduced a marker function, + 'ppr_ty_nested'. -} -- | Default 'RuntimeRep' variables to 'LiftedRep', @@ -1101,28 +1301,29 @@ defaultIfaceTyVarsOfKind :: Bool -- ^ default 'RuntimeRep'/'Levity' variables? -> Bool -- ^ default 'Multiplicity' variables? -> IfaceType -> IfaceType -defaultIfaceTyVarsOfKind def_rep def_mult ty = go emptyFsEnv ty +defaultIfaceTyVarsOfKind def_rep def_mult ty = go emptyFsEnv True ty where go :: FastStringEnv IfaceType -- Set of enclosing forall-ed RuntimeRep/Levity/Multiplicity variables + -> Bool -- Are we in a toplevel forall, where defaulting is allowed? -> IfaceType -> IfaceType - go subs (IfaceForAllTy (Bndr (IfaceTvBndr (var, var_kind)) argf) ty) + 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' ty + in go subs' True ty - go subs (IfaceForAllTy bndr ty) - = IfaceForAllTy (go_ifacebndr subs bndr) (go subs ty) + 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 - go _ ty@(IfaceFreeTyVar tv) + go _ _ ty@(IfaceFreeTyVar tv) -- See Note [Defaulting RuntimeRep variables], about free vars | def_rep , GHC.Core.Type.isRuntimeRepTy (tyVarKind tv) @@ -1142,34 +1343,34 @@ | otherwise = ty - go subs (IfaceTyConApp tc tc_args) + go subs _ (IfaceTyConApp tc tc_args) = IfaceTyConApp tc (go_args subs tc_args) - go subs (IfaceTupleTy sort is_prom tc_args) + go subs _ (IfaceTupleTy sort is_prom tc_args) = IfaceTupleTy sort is_prom (go_args subs tc_args) - go subs (IfaceFunTy af w arg res) - = IfaceFunTy af (go subs w) (go subs arg) (go subs res) + go subs rank1 (IfaceFunTy af w arg res) + = IfaceFunTy af (go subs False w) (go subs False arg) (go subs rank1 res) - go subs (IfaceAppTy t ts) - = IfaceAppTy (go subs t) (go_args subs ts) + go subs _ (IfaceAppTy t ts) + = IfaceAppTy (go subs False t) (go_args subs ts) - go subs (IfaceCastTy x co) - = IfaceCastTy (go subs x) co + go subs rank1 (IfaceCastTy x co) + = IfaceCastTy (go subs rank1 x) co - go _ ty@(IfaceLitTy {}) = ty - go _ ty@(IfaceCoercionTy {}) = ty + go _ _ ty@(IfaceLitTy {}) = ty + go _ _ ty@(IfaceCoercionTy {}) = ty go_ifacebndr :: FastStringEnv IfaceType -> IfaceForAllBndr -> IfaceForAllBndr go_ifacebndr subs (Bndr (IfaceIdBndr (w, n, t)) argf) - = Bndr (IfaceIdBndr (w, n, go subs t)) argf + = Bndr (IfaceIdBndr (w, n, go subs False t)) argf go_ifacebndr subs (Bndr (IfaceTvBndr (n, t)) argf) - = Bndr (IfaceTvBndr (n, go subs t)) argf + = Bndr (IfaceTvBndr (n, go subs False t)) argf go_args :: FastStringEnv IfaceType -> IfaceAppArgs -> IfaceAppArgs go_args _ IA_Nil = IA_Nil go_args subs (IA_Arg ty argf args) - = IA_Arg (go subs ty) argf (go_args subs args) + = IA_Arg (go subs False ty) argf (go_args subs args) check_substitution :: IfaceType -> Maybe IfaceType check_substitution (IfaceTyConApp tc _) @@ -1240,7 +1441,7 @@ Specified | print_kinds -> char '@' <> ppr_ty appPrec t Inferred | print_kinds - -> char '@' <> braces (ppr_ty topPrec t) + -> char '@' <> braces (ppr_ty_nested t) _ -> empty ------------------- @@ -1253,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 ] @@ -1292,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 @@ -1311,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 -- @@ -1322,6 +1530,29 @@ -- or when compiling with -fprint-explicit-foralls. data ShowForAllFlag = ShowForAllMust | ShowForAllWhen +data ShowSub + = ShowSub + { ss_how_much :: ShowHowMuch + , ss_forall :: ShowForAllFlag } + +-- See Note [Printing IfaceDecl binders] +-- The alternative pretty printer referred to in the note. +newtype AltPpr = AltPpr (Maybe (OccName -> SDoc)) + +data ShowHowMuch + = 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) + +instance Outputable ShowHowMuch where + ppr (ShowHeader _) = text "ShowHeader" + ppr ShowIface = text "ShowIface" + ppr (ShowSome _ _) = text "ShowSome" + pprIfaceSigmaType :: ShowForAllFlag -> IfaceType -> SDoc pprIfaceSigmaType show_forall ty = hideNonStandardTypes (ppr_sigma show_forall topPrec) ty @@ -1345,7 +1576,7 @@ -- Then it could handle both invisible and required binders, and -- splitIfaceReqForallTy wouldn't be necessary here. in ppr_iface_forall_part show_forall invis_tvs theta $ - sep [pprIfaceForAll req_tvs, ppr tau'] + sep [pprIfaceForAll req_tvs, ppr_ty_nested tau'] pprUserIfaceForAll :: [IfaceForAllBndr] -> SDoc pprUserIfaceForAll tvs @@ -1516,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 @@ -1685,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) @@ -1798,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) @@ -1850,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 @@ -1857,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 }) @@ -1899,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 @@ -1922,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 @@ -1944,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) ------------------- @@ -2013,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 @@ -2072,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 @@ -2111,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 @@ -2155,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 @@ -2187,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 @@ -2221,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 @@ -2261,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 @@ -2283,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 @@ -2332,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 @@ -1,11 +1,12 @@ module GHC.Iface.Type ( IfaceType, IfaceTyCon, IfaceBndr , IfaceCoercion, IfaceTyLit, IfaceAppArgs + , ShowSub ) 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 @@ -15,3 +16,4 @@ data IfaceTyLit data IfaceCoercion data IfaceBndr +data ShowSub 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 @@ -10,7 +10,10 @@ {-# LANGUAGE NondecreasingIndentation #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RecursiveDo #-} + {-# OPTIONS_GHC -Wno-incomplete-record-updates #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE RecordWildCards #-} @@ -18,6 +21,7 @@ tcLookupImported_maybe, importDecl, checkWiredInTyCon, tcHiBootIface, typecheckIface, typecheckWholeCoreBindings, + tcIfaceDefaults, typecheckIfacesForMerging, typecheckIfaceForInstantiate, tcIfaceDecl, tcIfaceDecls, @@ -26,15 +30,15 @@ tcIfaceExpr, -- Desired by HERMIT (#7683) tcIfaceGlobal, tcIfaceOneShot, tcTopIfaceBindings, + tcIfaceImport, hydrateCgBreakInfo ) where + import GHC.Prelude import GHC.ByteCode.Types -import Data.Word - import GHC.Driver.Env import GHC.Driver.Session import GHC.Driver.Config.Core.Lint ( initLintConfig ) @@ -53,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 @@ -70,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 @@ -101,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 ) @@ -111,8 +117,9 @@ import GHC.Types.Var as Var import GHC.Types.Var.Set import GHC.Types.Name -import GHC.Types.Name.Env 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,17 +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 @@ -204,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 @@ -219,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) @@ -237,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 @@ -247,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 {- @@ -286,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 = BF.mkOr [noLocA bf1, noLocA 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] -- ~~~~~~~~~~~~~~~~~~~ @@ -342,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 @@ -444,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) @@ -451,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 @@ -471,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 -> @@ -483,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) @@ -490,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 @@ -563,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 - -> mkSelfBootInfo (hm_iface info) (hm_details info) - _ -> return NoSelfBoot } + -> SelfBoot { sb_mds = hm_details info } + _ -> NoSelfBoot } else do -- OK, so we're in one-shot mode. @@ -574,13 +622,14 @@ -- to check consistency against, rather than just when we notice -- that an hi-boot is necessary due to a circular import. { hsc_env <- getTopEnv - ; read_result <- liftIO $ findAndReadIface hsc_env - need (fst (getModuleInstantiation mod)) mod - IsBoot -- Hi-boot file + ; read_result <- liftIO $ findAndReadIface hsc_env need + (fst (getModuleInstantiation mod)) mod + IsBoot -- Hi-boot file ; case read_result of { - Succeeded (iface, _path) -> do { tc_iface <- initIfaceTcRn $ typecheckIface iface - ; mkSelfBootInfo iface tc_iface } ; + Succeeded (iface, _path) -> + do { tc_iface <- initIfaceTcRn $ typecheckIface iface + ; return $ SelfBoot { sb_mds = tc_iface } } ; Failed err -> -- There was no hi-boot file. But if there is circularity in @@ -596,9 +645,12 @@ Nothing -> return NoSelfBoot -- error cases Just (GWIB { gwib_isBoot = is_boot }) -> case is_boot of - IsBoot -> failWithTc (mkTcRnUnknownMessage $ mkPlainError noHints (elaborate err)) + IsBoot -> + let diag = Can'tFindInterface err + (LookingForHiBoot mod) + in failWithTc (TcRnInterfaceError diag) -- The hi-boot file has mysteriously disappeared. - NotBoot -> failWithTc (mkTcRnUnknownMessage $ mkPlainError noHints moduleLoop) + NotBoot -> failWithTc (TcRnInterfaceError (CircularImport mod)) -- Someone below us imported us! -- This is a loop with no hi-boot in the way }}}} @@ -606,36 +658,6 @@ need = text "Need the hi-boot interface for" <+> ppr mod <+> text "to compare against the Real Thing" - moduleLoop = text "Circular imports: module" <+> quotes (ppr mod) - <+> text "depends on itself" - - elaborate err = hang (text "Could not find hi-boot interface for" <+> - quotes (ppr mod) <> colon) 4 err - - -mkSelfBootInfo :: ModIface -> ModDetails -> TcRn SelfBootInfo -mkSelfBootInfo iface mds - = do -- NB: This is computed DIRECTLY from the ModIface rather - -- than from the ModDetails, so that we can query 'sb_tcs' - -- WITHOUT forcing the contents of the interface. - let tcs = map ifName - . filter isIfaceTyCon - . map snd - $ mi_decls iface - return $ SelfBoot { sb_mds = mds - , sb_tcs = mkNameSet tcs } - where - -- Returns @True@ if, when you call 'tcIfaceDecl' on - -- this 'IfaceDecl', an ATyCon would be returned. - -- NB: This code assumes that a TyCon cannot be implicit. - isIfaceTyCon IfaceId{} = False - isIfaceTyCon IfaceData{} = True - isIfaceTyCon IfaceSynonym{} = True - isIfaceTyCon IfaceFamily{} = True - isIfaceTyCon IfaceClass{} = True - isIfaceTyCon IfaceAxiom{} = False - isIfaceTyCon IfacePatSyn{} = False - {- ************************************************************************ * * @@ -699,7 +721,7 @@ tc_iface_decl _ ignore_prags (IfaceId {ifName = name, ifType = iface_type, ifIdDetails = details, ifIdInfo = info}) = do { ty <- tcIfaceType iface_type - ; details <- tcIdDetails ty details + ; details <- tcIdDetails name ty details ; info <- tcIdInfo ignore_prags TopLevel name ty info ; return (AnId (mkGlobalId details name ty info)) } @@ -729,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, @@ -758,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 @@ -770,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 @@ -786,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 @@ -797,7 +818,7 @@ ifBody = IfConcreteClass { ifClassCtxt = rdr_ctxt, ifATs = rdr_ats, ifSigs = rdr_sigs, - ifMinDef = mindef_occ + ifMinDef = if_mindef, ifUnary = unary }}) = bindIfaceTyConBinders binders $ \ binders' -> do { traceIf (text "tc-iface-class1" <+> ppr tc_name) @@ -806,11 +827,11 @@ ; sigs <- mapM tc_sig rdr_sigs ; fds <- mapM tc_fd rdr_fds ; traceIf (text "tc-iface-class3" <+> ppr tc_name) - ; 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) @@ -849,12 +870,18 @@ Just def -> forkM (mk_at_doc tc) $ extendIfaceTyVarEnv (tyConTyVars tc) $ do { tc_def <- tcIfaceType def - ; return (Just (tc_def, NoATVI)) } + ; return (Just (tc_def, NoVI)) } -- Must be done lazily in case the RHS of the defaults mention -- the type constructor being defined here -- 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] @@ -914,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 @@ -955,10 +982,15 @@ return $ mkExportedVanillaId gbl_name (mkTyConApp ioTyCon [unitTy]) | otherwise = tcIfaceExtId gbl_name mk_top_id (IfLclTopBndr raw_name iface_type info details) = do - name <- newIfaceName (mkVarOccFS raw_name) ty <- tcIfaceType iface_type + rec { details' <- tcIdDetails name ty details + ; let occ = case details' of + RecSelId { sel_tycon = parent } + -> let con_fs = getOccFS $ recSelFirstConName parent + in mkRecFieldOccFS con_fs (ifLclNameFS raw_name) + _ -> mkVarOccFS (ifLclNameFS raw_name) + ; name <- newIfaceName occ } info' <- tcIdInfo False TopLevel name ty info - details' <- tcIdDetails ty details let new_id = mkGlobalId details' name ty info' return new_id @@ -975,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 @@ -1243,24 +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 (mkImportedInstance 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 } ) + , 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'') } + ; let mb_tcs' = map tcRoughTyCon mb_tcs + ; return (mkImportedFamInst fam mb_tcs' axiom' orphan) } {- ************************************************************************ @@ -1373,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] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1458,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) {- @@ -1480,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 @@ -1497,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 - {- ************************************************************************ * * @@ -1579,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 @@ -1598,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') } @@ -1616,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! -} @@ -1637,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 name) +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 @@ -1650,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') @@ -1670,13 +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 { us <- newUniqueSupply - ; let uniqs = uniqsFromSupply us + = 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 $ @@ -1691,19 +1785,26 @@ ************************************************************************ -} -tcIdDetails :: Type -> IfaceIdDetails -> IfL IdDetails -tcIdDetails _ IfVanillaId = return VanillaId -tcIdDetails _ (IfWorkerLikeId dmds) = return $ WorkerLikeId dmds -tcIdDetails ty IfDFunId - = return (DFunId (isNewTyCon (classTyCon cls))) +tcIdDetails :: Name -> Type -> IfaceIdDetails -> IfL IdDetails +tcIdDetails _ _ IfVanillaId = return VanillaId +tcIdDetails _ _ (IfWorkerLikeId dmds) = return $ WorkerLikeId dmds +tcIdDetails _ ty IfDFunId = return (DFunId (isUnaryClass cls)) where (_, _, cls, _) = tcSplitDFunTy ty -tcIdDetails _ (IfRecSelId tc naughty) +tcIdDetails nm _ (IfRecSelId tc _first_con naughty fl) = do { tc' <- either (fmap RecSelData . tcIfaceTyCon) (fmap (RecSelPatSyn . tyThingPatSyn) . tcIfaceDecl False) tc - ; return (RecSelId { sel_tycon = tc', sel_naughty = naughty }) } + ; 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" @@ -1750,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 -> @@ -1793,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 @@ -1961,7 +2058,7 @@ { mb_thing <- importDecl name -- It's imported; go get it ; case mb_thing of - Failed err -> failIfM (ppr name <+> err) + Failed err -> failIfM (ppr name <+> pprDiagnostic err) Succeeded thing -> return thing }}} @@ -2031,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 @@ -2086,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' @@ -2129,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) } @@ -2181,9 +2279,19 @@ -- CgBreakInfo -hydrateCgBreakInfo :: CgBreakInfo -> IfL ([Maybe (Id, Word16)], Type) +hydrateCgBreakInfo :: CgBreakInfo -> IfL ([Maybe (Id, Word)], Type) hydrateCgBreakInfo CgBreakInfo{..} = do bindIfaceTyVars cgb_tyvars $ \_ -> do 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 ----------------------------------------------------------------------------- -- | @@ -36,20 +38,19 @@ -- construct new terms in the EDSL. Crucially, missing from this module are -- corresponding /elimination/ or /destructing/ functions which would -- project information from the EDSL back to Haskell. See --- 'GHC.StgToJS.UnitUtils' and 'GHC.StgToJS.CoreUtils' for such functions. +-- 'GHC.StgToJS.Utils' for such functions. -- -- * /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, jVar, jFor, 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,30 +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 - -- * Miscellaneous - -- $misc - , allocData, allocClsA - , dataFieldName, dataFieldNames ) where import GHC.Prelude hiding ((.|.)) -import GHC.JS.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 Data.Array import qualified Data.Map as M -import qualified Data.List as List -import GHC.Utils.Outputable (Outputable (..)) import GHC.Data.FastString -import GHC.Utils.Monad.State.Strict -import GHC.Utils.Panic import GHC.Utils.Misc import GHC.Types.Unique.Map @@ -160,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 @@ -225,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 -------------------------------------------------------------------------------- @@ -252,85 +265,139 @@ -- -- > 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 --- | Introduce a new variable into scope for the duration --- of the enclosed expression. The result is a block statement. +-- | 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: +-- +-- '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 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 [jVar x ||= one_, jVar y ||= two_, jVar x + jVar 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) +-- | 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 = List.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 = List.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)) --- | 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 = List.head is - return $ TryStat s i block s2 +-- | Create a 'for' statement given a function for initialization, a predicate +-- to step to, a step and a body +-- Usage: +-- +-- @ jFor (|= zero_) (.<. Int 65536) preIncrS +-- (\j -> ...something with the counter j...)@ +-- +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) --- | construct a JS variable reference -var :: FastString -> JExpr -var = ValExpr . JVar . TxtI +-- | As with "jForIn" but creating a \"for each in\" statement. +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 --- | Create a 'for' statement -jFor :: (ToJExpr a, ToStat b) => JStat -> a -> JStat -> b -> JStat -jFor before p after b = BlockStat [before, WhileStat False (toJExpr p) b'] - where b' = case toStat b of - BlockStat xs -> BlockStat $ xs ++ [after] - x -> BlockStat [x,after] - -- | 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 [] @@ -342,7 +409,7 @@ -- EDSL domain. -- | JS infix Equality operators -(.==.), (.===.), (.!=.), (.!==.) :: JExpr -> JExpr -> JExpr +(.==.), (.===.), (.!=.), (.!==.) :: JStgExpr -> JStgExpr -> JStgExpr (.==.) = InfixExpr EqOp (.===.) = InfixExpr StrictEqOp (.!=.) = InfixExpr NeqOp @@ -351,7 +418,7 @@ infixl 6 .==., .===., .!=., .!==. -- | JS infix Ord operators -(.>.), (.>=.), (.<.), (.<=.) :: JExpr -> JExpr -> JExpr +(.>.), (.>=.), (.<.), (.<=.) :: JStgExpr -> JStgExpr -> JStgExpr (.>.) = InfixExpr GtOp (.>=.) = InfixExpr GeOp (.<.) = InfixExpr LtOp @@ -360,7 +427,7 @@ infixl 7 .>., .>=., .<., .<=. -- | JS infix bit operators -(.|.), (.||.), (.&&.) :: JExpr -> JExpr -> JExpr +(.|.), (.||.), (.&&.) :: JStgExpr -> JStgExpr -> JStgExpr (.|.) = InfixExpr BOrOp (.||.) = InfixExpr LOrOp (.&&.) = InfixExpr LAndOp @@ -368,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 ||=, |= @@ -515,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 -------------------------------------------------------------------------------- @@ -544,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") []) -------------------------------------------------------------------------------- @@ -586,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" @@ -617,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 @@ -627,89 +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)) + -------------------------------------------------------------------------------- --- Miscellaneous +-- New Identifiers -------------------------------------------------------------------------------- --- $misc --- Everything else, --- | Cache "dXXX" field names -dataFieldCache :: Array Int FastString -dataFieldCache = listArray (0,nFieldCache) (map (mkFastString . ('d':) . show) [(0::Int)..nFieldCache]) +-- | 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 -nFieldCache :: Int -nFieldCache = 16384 +-- | 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 -dataFieldName :: Int -> FastString -dataFieldName i - | i < 1 || i > nFieldCache = panic "dataFieldName" (ppr i) - | otherwise = dataFieldCache ! i +instance JVarMagic Ident where + fresh = newIdent -dataFieldNames :: [FastString] -dataFieldNames = fmap dataFieldName [1..nFieldCache] +instance JVarMagic JVal where + fresh = JVar <$> fresh +instance JVarMagic JStgExpr where + fresh = do i <- fresh + return $ ValExpr $ JVar i --- | Cache "h$dXXX" names -dataCache :: Array Int FastString -dataCache = listArray (0,1024) (map (mkFastString . ("h$d"++) . show) [(0::Int)..1024]) +instance (JVarMagic a, ToJExpr a) => JSArgument (Solo a) where + argList (MkSolo a) = concatMap identsE [toJExpr a] + args = do i <- fresh + return $ MkSolo i -allocData :: Int -> JExpr -allocData i = toJExpr (TxtI (dataCache ! i)) +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 --- | Cache "h$cXXX" names -clsCache :: Array Int FastString -clsCache = listArray (0,1024) (map (mkFastString . ("h$c"++) . show) [(0::Int)..1024]) +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 -allocClsA :: Int -> JExpr -allocClsA i = toJExpr (TxtI (clsCache ! i)) +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 --------------------------------------------------------------------------------- --- New Identifiers --------------------------------------------------------------------------------- +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 --- | 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]) +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 ToSat [JStat] where - toSat_ f vs = IS $ return $ (BlockStat f, reverse vs) +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 ToSat JStat where - toSat_ f vs = IS $ return $ (f, reverse vs) +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 ToSat JExpr where - toSat_ f vs = IS $ return $ (toStat f, reverse vs) -instance ToSat [JExpr] where - toSat_ f vs = IS $ return $ (BlockStat $ map expr2stat f, reverse vs) - -instance (ToSat a, b ~ JExpr) => ToSat (b -> a) where - toSat_ f vs = IS $ do - x <- takeOneIdent - runIdentSupply $ toSat_ (f (ValExpr $ JVar x)) (x:vs) - --- | 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 - -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 + , 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 new file mode 100644 --- /dev/null +++ b/GHC/JS/Optimizer.hs @@ -0,0 +1,311 @@ +{-# LANGUAGE LambdaCase, OverloadedStrings #-} + +----------------------------------------------------------------------------- +-- | +-- Module : GHC.JS.Optimizer +-- 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.Optimizer is a shallow embedding of a peephole optimizer. That is, +-- this module defines transformations over the JavaScript IR in +-- 'GHC.JS.Syntax', transforming the IR forms from inefficient, or +-- non-idiomatic, JavaScript to more efficient and idiomatic JavaScript. The +-- optimizer is written in continuation passing style so optimizations +-- compose. +-- +-- * Architecture of the optimizer +-- +-- The design is that each optimization pattern matches on the head of a +-- block by pattern matching onto the head of the stream of nodes in the +-- JavaScript IR. If an optimization gets a successful match then it performs +-- whatever rewrite is necessary and then calls the 'loop' continuation. This +-- ensures that the result of the optimization is subject to the same +-- optimization, /and/ the rest of the optimizations. If there is no match +-- then the optimization should call the 'next' continuation to pass the +-- stream to the next optimization in the optimization chain. We then define +-- the last "optimization" to be @tailLoop@ which selects the next block of +-- code to optimize and begin the optimization pipeline again. +----------------------------------------------------------------------------- +module GHC.JS.Optimizer + ( jsOptimize + ) where + + +import Prelude + +import GHC.JS.Syntax + +import Control.Arrow + +import qualified GHC.JS.Opt.Simple as Simple + +{- +Note [Unsafe JavaScript optimizations] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +There are a number of optimizations that the JavaScript Backend performs that +are not sound with respect to arbritrary JavaScript. We still perform these +optimizations because we are not optimizing arbritrary javascript and under the +assumption that the JavaScript backend will not generate code that violates the +soundness of the optimizer. For example, the @deadCodeElim@ optimization removes +all statements that occur after a 'return' in JavaScript, however this is not +always sound because of hoisting, consider this program: + + function foo() { + var x = 2; + bar(); + return x; + + function bar() { + x = 10; + }} + + which is transformed to: + + function foo() { + var x = 2; + bar(); + return x; + }} + +The optimized form is clearly a program that goes wrong because `bar()` is no +longer defined. But the JavaScript backend will never generate this code, so as +long as that assumption holds we are safe to perform optimizations that would +normally be unsafe. +-} + + +-------------------------------------------------------------------------------- +-- Top level Driver +-------------------------------------------------------------------------------- +jsOptimize :: JStat -> JStat +jsOptimize s0 = jsOptimizeStat (Simple.simpleOpt s0) + +jsOptimizeStat :: JStat -> JStat +jsOptimizeStat s0 = go s0 + where + p_opt = jsOptimizeStat + opt = jsOptimize' + e_opt = jExprOptimize + -- base case + go (BlockStat xs) = BlockStat (opt xs) + -- recursive cases + go (ForStat i p s body) = ForStat (go i) (e_opt p) (go s) (p_opt body) + go (ForInStat b i p body) = ForInStat b i p (p_opt body) + go (WhileStat b c body) = WhileStat b (e_opt c) (p_opt body) + go (SwitchStat s ps body) = SwitchStat s (fmap (second go) ps) (p_opt body) + go (FuncStat i args body) = FuncStat i args (p_opt body) + go (IfStat c t e) = IfStat (e_opt c) (p_opt t) (p_opt e) + go (TryStat ths i c f) = TryStat (p_opt ths) i (p_opt c) (p_opt f) + go (LabelStat lbl s) = LabelStat lbl (p_opt s) + -- special case: drive the optimizer into expressions + go (AssignStat id op rhs) = AssignStat (e_opt id) op (e_opt rhs) + go (DeclStat i (Just e)) = DeclStat i (Just $ e_opt e) + go (ReturnStat e) = ReturnStat (e_opt e) + go (UOpStat op e) = UOpStat op (e_opt e) + go (ApplStat f args) = ApplStat (e_opt f) (e_opt <$> args) + -- all else is terminal, we match on these to force a warning in the event + -- another constructor is added + go x@BreakStat{} = x + go x@ContinueStat{} = x + go x@DeclStat{} = x -- match on the nothing case + +jsOptimize' :: [JStat] -> [JStat] +jsOptimize' = runBlockOpt opts . single_pass_opts + where + opts :: BlockOpt + opts = safe_opts + <> unsafe_opts + <> tailLoop -- tailloop must be last, see module description + + unsafe_opts :: BlockOpt + unsafe_opts = mconcat [ deadCodeElim ] + + safe_opts :: BlockOpt + safe_opts = mconcat [ declareAssign, combineOps ] + + single_pass_opts :: BlockTrans + single_pass_opts = runBlockTrans sp_opts + + sp_opts = [flattenBlocks] + +-- | recur over a @JExpr@ and optimize the @JVal@s +jExprOptimize :: JExpr -> JExpr +-- the base case +jExprOptimize (ValExpr val) = ValExpr (jValOptimize val) +-- recursive cases +jExprOptimize (SelExpr obj field) = SelExpr (jExprOptimize obj) field +jExprOptimize (IdxExpr obj ix) = IdxExpr (jExprOptimize obj) (jExprOptimize ix) +jExprOptimize (UOpExpr op exp) = UOpExpr op (jExprOptimize exp) +jExprOptimize (IfExpr c t e) = IfExpr c (jExprOptimize t) (jExprOptimize e) +jExprOptimize (ApplExpr f args ) = ApplExpr (jExprOptimize f) (jExprOptimize <$> args) +jExprOptimize (InfixExpr op l r) = InfixExpr op (jExprOptimize l) (jExprOptimize r) + +-- | drive optimizations to anonymous functions and over expressions +jValOptimize :: JVal -> JVal +-- base case +jValOptimize (JFunc args body) = JFunc args (jsOptimizeStat body) +-- recursive cases +jValOptimize (JList exprs) = JList (jExprOptimize <$> exprs) +jValOptimize (JHash hash) = JHash (jExprOptimize <$> hash) +-- all else is terminal +jValOptimize x@JVar{} = x +jValOptimize x@JDouble{} = x +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 +type BlockTrans = [JStat] -> [JStat] + +-- | A BlockOpt is a function that alters the stream, and a continuation that +-- represents the rest of the stream. The first @BlockTrans@ represents +-- restarting the optimizer after a change has happened. The second @BlockTrans@ +-- represents the rest of the continuation stream. +newtype BlockOpt = BlockOpt (BlockTrans -> BlockTrans -> BlockTrans) + +-- | To merge two BlockOpt we first run the left-hand side optimization and +-- capture the right-hand side in the continuation +instance Semigroup BlockOpt where + BlockOpt opt0 <> BlockOpt opt1 = BlockOpt + $ \loop next -> opt0 loop (opt1 loop next) + +instance Monoid BlockOpt where + -- don't loop, just finalize + mempty = BlockOpt $ \_loop next -> next + +-- | loop until a fixpoint is reached +runBlockOpt :: BlockOpt -> [JStat] -> [JStat] +runBlockOpt (BlockOpt opt) xs = recur xs + where recur = opt recur id + +runBlockTrans :: [BlockTrans] -> [JStat] -> [JStat] +runBlockTrans opts = foldl (.) id opts + +-- | Perform all the optimizations on the tail of a block. +tailLoop :: BlockOpt +tailLoop = BlockOpt $ \loop next -> \case + [] -> next [] + -- 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 (jsOptimizeStat x : loop xs) + +{- | + Catch modify and assign operators: + case 1: + i = i + 1; ==> ++i; + case 2: + i = i - 1; ==> --i; + case 3: + i = i + n; ==> i += n; + case 4: + i = i - n; ==> i -= n; +-} +combineOps :: BlockOpt +combineOps = BlockOpt $ \loop next -> + -- 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 + (InfixExpr op (ValExpr (JVar i')) e)) : 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 + -- commutative cases + (unchanged@(AssignStat + ident@(ValExpr (JVar i)) + AssignOp + (InfixExpr op e (ValExpr (JVar i')))) : xs) + | i == i' -> case (op, e) of + (AddOp, (ValExpr (JInt 1))) -> loop $ UOpStat PreIncOp ident : xs + (AddOp, e') -> loop $ AssignStat ident AddAssignOp e' : xs + _ -> next $ unchanged : xs + -- general case, we had nothing to optimize in this case so call the next + -- optimization + xs -> next xs + + +-- | Catch 'var i; i = q;' ==> 'var i = q;' +declareAssign :: BlockOpt +declareAssign = BlockOpt $ + \loop next -> \case + ( (DeclStat i Nothing) + : (AssignStat (ValExpr (JVar i')) AssignOp v) + : xs + ) | i == i' -> loop (DeclStat i (Just v) : xs) + xs -> next xs + +-- | Eliminate all code after a return statement. This is a special case +-- optimization that doesn't need to loop. See Note [Unsafe JavaScript +-- optimizations] +deadCodeElim :: BlockOpt +deadCodeElim = BlockOpt $ + \_loop next -> \case + (x@ReturnStat{}:_) -> next [x] + xs -> next xs + +-- | remove nested blocks +flattenBlocks :: BlockTrans +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 @@ -10,18 +10,55 @@ -- For Outputable instances for JS syntax {-# OPTIONS_GHC -Wno-orphans #-} --- | Pretty-printing JavaScript +----------------------------------------------------------------------------- +-- | +-- Module : GHC.JS.Ppr +-- 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.Ppr defines the code generation facilities for the JavaScript +-- backend. That is, this module exports a function from the JS backend IR +-- to JavaScript compliant concrete syntax that can readily be executed by +-- nodejs or called in a browser. +-- +-- * Design +-- +-- This module follows the architecture and style of the other backends in +-- 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. +-- +-- * How to use +-- +-- The key functions are @renderJS@, @jsToDoc@, and the @RenderJS@ record. +-- Use the @RenderJS@ record and @jsToDoc@ to define a custom renderers for +-- specific parts of the backend, for example in 'GHC.StgToJS.Linker.Opt' a +-- custom renderer ensures all @Ident@ generated by the linker optimization +-- pass are prefixed differently than the default. Use @renderJS@ to +-- generate JavaScript concrete syntax in the general case, suitable for +-- human consumption. +----------------------------------------------------------------------------- + module GHC.JS.Ppr ( renderJs - , renderJs' , renderPrefixJs , renderPrefixJs' , JsToDoc(..) , defaultRenderJs , RenderJs(..) + , JsRender(..) , jsToDoc , pprStringLit - , flattenBlocks + , interSemi , braceNest , hangBrace ) @@ -29,163 +66,168 @@ 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.Outputable (Outputable (..), docToSDoc) -import GHC.Utils.Ppr as PP +import GHC.Utils.Misc +import GHC.Utils.Outputable import GHC.Data.FastString import GHC.Types.Unique.Map instance Outputable JExpr where - ppr = docToSDoc . renderJs + ppr = renderJs instance Outputable JVal where - ppr = docToSDoc . renderJs - + ppr = renderJs -($$$) :: Doc -> Doc -> Doc -x $$$ y = nest 2 $ x $+$ y +-------------------------------------------------------------------------------- +-- Top level API +-------------------------------------------------------------------------------- -- | Render a syntax tree as a pretty-printable document -- (simply showing the resultant doc produces a nice, -- well formatted String). -renderJs :: (JsToDoc a, JMacro a) => a -> Doc +renderJs :: (JsToDoc a) => a -> SDoc renderJs = renderJs' defaultRenderJs -renderJs' :: (JsToDoc a, JMacro a) => RenderJs -> a -> Doc -renderJs' r = jsToDocR r . jsSaturate Nothing +{-# SPECIALISE renderJs' :: JsToDoc a => RenderJs HLine -> a -> HLine #-} +{-# SPECIALISE renderJs' :: JsToDoc a => RenderJs SDoc -> a -> SDoc #-} +renderJs' :: (JsToDoc a, JsRender doc) => RenderJs doc -> a -> doc +renderJs' r = jsToDocR r -data RenderJs = RenderJs - { renderJsS :: !(RenderJs -> JStat -> Doc) - , renderJsE :: !(RenderJs -> JExpr -> Doc) - , renderJsV :: !(RenderJs -> JVal -> Doc) - , renderJsI :: !(RenderJs -> Ident -> Doc) +data RenderJs doc = RenderJs + { renderJsS :: !(JsRender doc => RenderJs doc -> JStat -> doc) + , renderJsE :: !(JsRender doc => RenderJs doc -> JExpr -> doc) + , renderJsV :: !(JsRender doc => RenderJs doc -> JVal -> doc) + , renderJsI :: !(JsRender doc => RenderJs doc -> Ident -> doc) } -defaultRenderJs :: RenderJs +defaultRenderJs :: RenderJs doc defaultRenderJs = RenderJs defRenderJsS defRenderJsE defRenderJsV defRenderJsI -jsToDoc :: JsToDoc a => a -> Doc +jsToDoc :: JsToDoc a => a -> SDoc jsToDoc = jsToDocR defaultRenderJs -- | 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) => FastString -> a -> Doc -renderPrefixJs pfx = renderPrefixJs' defaultRenderJs pfx - -renderPrefixJs' :: (JsToDoc a, JMacro a) => RenderJs -> FastString -> a -> Doc -renderPrefixJs' r pfx = jsToDocR r . jsSaturate (Just $ "jmId_" `mappend` pfx) +renderPrefixJs :: (JsToDoc a) => a -> SDoc +renderPrefixJs = renderPrefixJs' defaultRenderJs -braceNest :: Doc -> Doc -braceNest x = char '{' <+> nest 2 x $$ char '}' +renderPrefixJs' :: (JsToDoc a, JsRender doc) => RenderJs doc -> a -> doc +renderPrefixJs' r = jsToDocR r --- | Hang with braces: --- --- hdr { --- body --- } -hangBrace :: Doc -> Doc -> Doc -hangBrace hdr body = sep [ hdr <> char ' ' <> char '{', nest 2 body, char '}' ] +-------------------------------------------------------------------------------- +-- Code Generator +-------------------------------------------------------------------------------- -class JsToDoc a where jsToDocR :: RenderJs -> a -> Doc -instance JsToDoc JStat where jsToDocR r = renderJsS r r -instance JsToDoc JExpr where jsToDocR r = renderJsE r r -instance JsToDoc JVal where jsToDocR r = renderJsV r r -instance JsToDoc Ident where jsToDocR r = renderJsI r r -instance JsToDoc [JExpr] where - jsToDocR r = vcat . map ((<> semi) . jsToDocR r) -instance JsToDoc [JStat] where - jsToDocR r = vcat . map ((<> semi) . jsToDocR r) +class JsToDoc a where jsToDocR :: JsRender doc => RenderJs doc -> a -> doc +instance JsToDoc JStat where jsToDocR r = renderJsS r r +instance JsToDoc JExpr where jsToDocR r = renderJsE r r +instance JsToDoc JVal where jsToDocR r = renderJsV r r +instance JsToDoc Ident where jsToDocR r = renderJsI r r +instance JsToDoc [JExpr] where jsToDocR r = jcat . map (addSemi . jsToDocR r) +instance JsToDoc [JStat] where jsToDocR r = jcat . map (addSemi . jsToDocR r) -defRenderJsS :: RenderJs -> JStat -> Doc +defRenderJsS :: JsRender doc => RenderJs doc -> JStat -> doc defRenderJsS r = \case - IfStat cond x y -> hangBrace (text "if" <> parens (jsToDocR r cond)) - (jsToDocR r x) - $$ mbElse - where mbElse | y == BlockStat [] = PP.empty - | otherwise = hangBrace (text "else") (jsToDocR r y) + IfStat cond x y -> jcat + [ hangBrace (text "if" <+?> parens (jsToDocR r cond)) (optBlock r x) + , mbElse + ] + where mbElse | y == BlockStat [] = empty + | otherwise = hangBrace (text "else") (optBlock r y) DeclStat x Nothing -> text "var" <+> jsToDocR r x - DeclStat x (Just e) -> text "var" <+> jsToDocR r x <+> char '=' <+> jsToDocR r e - WhileStat False p b -> hangBrace (text "while" <> parens (jsToDocR r p)) (jsToDocR r b) - WhileStat True p b -> (hangBrace (text "do") (jsToDocR r b)) $+$ text "while" <+> parens (jsToDocR r p) - UnsatBlock e -> jsToDocR r $ pseudoSaturate e - BreakStat l -> maybe (text "break") (\(LexicalFastString s) -> (text "break" <+> ftext s)) l - ContinueStat l -> maybe (text "continue") (\(LexicalFastString s) -> (text "continue" <+> ftext s)) l - LabelStat (LexicalFastString l) s -> ftext l <> char ':' $$ printBS s + -- special treatment for functions, otherwise there is too much left padding + -- (more than the length of the expression assigned to). E.g. + -- + -- var long_variable_name = (function() + -- { + -- ... + -- }); + -- + DeclStat x (Just (ValExpr f@(JFunc {}))) -> jhang (text "var" <+> jsToDocR r x <+?> char '=') (jsToDocR r f) + DeclStat x (Just e) -> text "var" <+> jsToDocR r x <+?> char '=' <+?> jsToDocR r e + WhileStat False p b -> hangBrace (text "while" <+?> parens (jsToDocR r p)) (optBlock r b) + WhileStat True p b -> hangBrace (text "do") (optBlock r b) <+?> text "while" <+?> parens (jsToDocR r p) + BreakStat l -> addSemi $ maybe (text "break") (\(LexicalFastString s) -> (text "break" <+> ftext s)) l + ContinueStat l -> addSemi $ maybe (text "continue") (\(LexicalFastString s) -> (text "continue" <+> ftext s)) l + LabelStat (LexicalFastString l) s -> ftext l <> char ':' $$$ printBS s where - printBS (BlockStat ss) = vcat $ interSemi $ flattenBlocks ss + printBS (BlockStat ss) = interSemi $ map (jsToDocR r) ss printBS x = jsToDocR r x - interSemi [x] = [jsToDocR r x] - interSemi [] = [] - interSemi (x:xs) = (jsToDocR r x <> semi) : interSemi xs - ForInStat each i e b -> hangBrace (text txt <> parens (jsToDocR r i <+> text "in" <+> jsToDocR r e)) (jsToDocR r b) + ForStat init p s1 sb -> hangBrace (text "for" <+?> parens forCond) (optBlock r sb) + where + forCond = jsToDocR r init <> semi <+?> jsToDocR r p <> semi <+?> parens (jsToDocR r s1) + ForInStat each i e b -> hangBrace (text txt <+?> parens (jsToDocR r i <+> text "in" <+> jsToDocR r e)) (optBlock r b) where txt | each = "for each" | otherwise = "for" - SwitchStat e l d -> hangBrace (text "switch" <+> parens (jsToDocR r e)) cases - where l' = map (\(c,s) -> (text "case" <+> parens (jsToDocR r c) <> char ':') $$$ (jsToDocR r s)) l ++ [text "default:" $$$ (jsToDocR r d)] - cases = vcat l' + 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 ($$$) $ expectNonEmpty l' ReturnStat e -> text "return" <+> jsToDocR r e - ApplStat e es -> jsToDocR r e <> (parens . hsep . punctuate comma $ map (jsToDocR r) es) - TryStat s i s1 s2 -> hangBrace (text "try") (jsToDocR r s) $$ mbCatch $$ mbFinally - where mbCatch | s1 == BlockStat [] = PP.empty - | otherwise = hangBrace (text "catch" <> parens (jsToDocR r i)) (jsToDocR r s1) - mbFinally | s2 == BlockStat [] = PP.empty - | otherwise = hangBrace (text "finally") (jsToDocR r s2) - AssignStat i x -> case x of + 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 + <> parens (foldl' (<+?>) empty . punctuate comma . map (jsToDocR r) $ is)) + (optBlock r b) + TryStat s i s1 s2 -> hangBrace (text "try") (jsToDocR r s) <+?> mbCatch <+?> mbFinally + where mbCatch | s1 == BlockStat [] = empty + | otherwise = hangBrace (text "catch" <+?> parens (jsToDocR r i)) (optBlock r s1) + mbFinally | s2 == BlockStat [] = empty + | otherwise = hangBrace (text "finally") (optBlock r s2) + AssignStat i op x -> case x of -- special treatment for functions, otherwise there is too much left padding -- (more than the length of the expression assigned to). E.g. -- - -- var long_variable_name = (function() + -- long_variable_name = (function() -- { -- ... -- }); -- - ValExpr (JFunc is b) -> sep [jsToDocR r i <+> text "= function" <> parens (hsep . punctuate comma . map (jsToDocR r) $ is) <> char '{', nest 2 (jsToDocR r b), text "}"] - _ -> jsToDocR r i <+> char '=' <+> jsToDocR r x + ValExpr f@(JFunc {}) -> jhang (jsToDocR r i <> ftext (aOpText op)) (jsToDocR r f) + _ -> jsToDocR r i <+?> ftext (aOpText op) <+?> jsToDocR r x UOpStat op x | isPre op && isAlphaOp op -> ftext (uOpText op) <+> optParens r x - | isPre op -> ftext (uOpText op) <> optParens r x - | otherwise -> optParens r x <> ftext (uOpText op) - BlockStat xs -> jsToDocR r (flattenBlocks xs) + | isPre op -> ftext (uOpText op) <+> optParens r x + | otherwise -> optParens r x <+> ftext (uOpText op) + BlockStat xs -> jsToDocR r xs -flattenBlocks :: [JStat] -> [JStat] -flattenBlocks = \case - BlockStat y:ys -> flattenBlocks y ++ flattenBlocks ys - y:ys -> y : flattenBlocks ys - [] -> [] +-- | Remove one Block layering if we know we already have braces around the +-- statement +optBlock :: JsRender doc => RenderJs doc -> JStat -> doc +optBlock r x = case x of + BlockStat{} -> jsToDocR r x + _ -> addSemi (jsToDocR r x) -optParens :: RenderJs -> JExpr -> Doc +optParens :: JsRender doc => RenderJs doc -> JExpr -> doc optParens r x = case x of UOpExpr _ _ -> parens (jsToDocR r x) _ -> jsToDocR r x -defRenderJsE :: RenderJs -> JExpr -> Doc +defRenderJsE :: JsRender doc => RenderJs doc -> JExpr -> doc defRenderJsE r = \case ValExpr x -> jsToDocR r x SelExpr x y -> jsToDocR r x <> char '.' <> jsToDocR r y IdxExpr x y -> jsToDocR r x <> brackets (jsToDocR r y) - IfExpr x y z -> parens (jsToDocR r x <+> char '?' <+> jsToDocR r y <+> char ':' <+> jsToDocR r z) - InfixExpr op x y -> parens $ hsep [jsToDocR r x, ftext (opText op), jsToDocR r y] + IfExpr x y z -> parens (jsToDocR r x <+?> char '?' <+?> jsToDocR r y <+?> colon <+?> jsToDocR r z) + InfixExpr op x y -> parens $ jsToDocR r x <+?> ftext (opText op) <+?> jsToDocR r y UOpExpr op x | isPre op && isAlphaOp op -> ftext (uOpText op) <+> optParens r x - | isPre op -> ftext (uOpText op) <> optParens r x - | otherwise -> optParens r x <> ftext (uOpText op) - ApplExpr je xs -> jsToDocR r je <> (parens . hsep . punctuate comma $ map (jsToDocR r) xs) - UnsatExpr e -> jsToDocR r $ pseudoSaturate e + | isPre op -> ftext (uOpText op) <+> optParens r x + | otherwise -> optParens r x <+> ftext (uOpText op) + ApplExpr je xs -> jsToDocR r je <> (parens . foldl' (<+?>) empty . punctuate comma $ map (jsToDocR r) xs) -defRenderJsV :: RenderJs -> JVal -> Doc +defRenderJsV :: JsRender doc => RenderJs doc -> JVal -> doc defRenderJsV r = \case JVar i -> jsToDocR r i - JList xs -> brackets . hsep . punctuate comma $ map (jsToDocR r) xs + JList xs -> brackets . foldl' (<+?>) empty . punctuate comma $ map (jsToDocR r) xs JDouble (SaneDouble d) | d < 0 || isNegativeZero d -> parens (double d) | otherwise -> double d @@ -193,49 +235,28 @@ | i < 0 -> parens (integer i) | otherwise -> integer i JStr s -> pprStringLit s - JRegEx s -> hcat [char '/',ftext s, char '/'] + JRegEx s -> char '/' <> ftext s <> char '/' + JBool b -> text (if b then "true" else "false") JHash m | isNullUniqMap m -> text "{}" - | otherwise -> braceNest . hsep . punctuate comma . - map (\(x,y) -> squotes (ftext x) <> colon <+> jsToDocR r y) - -- nonDetEltsUniqMap doesn't introduce non-determinism here + | otherwise -> braceNest . foldl' (<+?>) empty . punctuate comma . + map (\(x,y) -> char '\'' <> ftext x <> char '\'' <> colon <+?> jsToDocR r y) + -- nonDetKeysUniqMap doesn't introduce non-determinism here -- because we sort the elements lexically - $ sortOn (LexicalFastString . fst) (nonDetEltsUniqMap m) - JFunc is b -> parens $ hangBrace (text "function" <> parens (hsep . punctuate comma . map (jsToDocR r) $ is)) (jsToDocR r b) - UnsatVal f -> jsToDocR r $ pseudoSaturate f + $ sortOn (LexicalFastString . fst) (nonDetUniqMapToList m) + JFunc is b -> parens $ hangBrace (text "function" <> parens (foldl' (<+?>) empty . punctuate comma . map (jsToDocR r) $ is)) (jsToDocR r b) -defRenderJsI :: RenderJs -> Ident -> Doc -defRenderJsI _ (TxtI t) = ftext t +defRenderJsI :: JsRender doc => RenderJs doc -> Ident -> doc +defRenderJsI _ t = ftext (identFS t) +aOpText :: AOp -> FastString +aOpText = \case + AssignOp -> "=" + AddAssignOp -> "+=" + SubAssignOp -> "-=" -pprStringLit :: FastString -> Doc -pprStringLit s = hcat [char '\"',encodeJson s, char '\"'] -encodeJson :: FastString -> Doc -encodeJson xs = hcat (map encodeJsonChar (unpackFS xs)) - -encodeJsonChar :: Char -> Doc -encodeJsonChar = \case - '/' -> text "\\/" - '\b' -> text "\\b" - '\f' -> text "\\f" - '\n' -> text "\\n" - '\r' -> text "\\r" - '\t' -> text "\\t" - '"' -> text "\\\"" - '\\' -> text "\\\\" - c - | not (isControl c) && ord c <= 127 -> char c - | ord c <= 0xff -> hexxs "\\x" 2 (ord c) - | ord c <= 0xffff -> hexxs "\\u" 4 (ord c) - | otherwise -> let cp0 = ord c - 0x10000 -- output surrogate pair - in hexxs "\\u" 4 ((cp0 `shiftR` 10) + 0xd800) <> - hexxs "\\u" 4 ((cp0 .&. 0x3ff) + 0xdc00) - where hexxs prefix pad cp = - let h = showHex cp "" - in text (prefix ++ replicate (pad - length h) '0' ++ h) - -uOpText :: JUOp -> FastString +uOpText :: UOp -> FastString uOpText = \case NotOp -> "!" BNotOp -> "~" @@ -251,7 +272,7 @@ PreDecOp -> "--" PostDecOp -> "--" -opText :: JOp -> FastString +opText :: Op -> FastString opText = \case EqOp -> "==" StrictEqOp -> "===" @@ -278,13 +299,13 @@ InOp -> "in" -isPre :: JUOp -> Bool +isPre :: UOp -> Bool isPre = \case PostIncOp -> False PostDecOp -> False _ -> True -isAlphaOp :: JUOp -> Bool +isAlphaOp :: UOp -> Bool isAlphaOp = \case NewOp -> True TypeofOp -> True @@ -292,3 +313,95 @@ YieldOp -> True VoidOp -> True _ -> False + +pprStringLit :: IsLine doc => FastString -> doc +pprStringLit s = char '\"' <> encodeJson s <> char '\"' + +-------------------------------------------------------------------------------- +-- Utilities +-------------------------------------------------------------------------------- + +encodeJson :: IsLine doc => FastString -> doc +encodeJson xs = hcat (map encodeJsonChar (unpackFS xs)) + +encodeJsonChar :: IsLine doc => Char -> doc +encodeJsonChar = \case + '/' -> text "\\/" + '\b' -> text "\\b" + '\f' -> text "\\f" + '\n' -> text "\\n" + '\r' -> text "\\r" + '\t' -> text "\\t" + '"' -> text "\\\"" + '\\' -> text "\\\\" + c + | not (isControl c) && ord c <= 127 -> char c + | ord c <= 0xff -> hexxs "\\x" 2 (ord c) + | ord c <= 0xffff -> hexxs "\\u" 4 (ord c) + | otherwise -> let cp0 = ord c - 0x10000 -- output surrogate pair + in hexxs "\\u" 4 ((cp0 `shiftR` 10) + 0xd800) <> + hexxs "\\u" 4 ((cp0 .&. 0x3ff) + 0xdc00) + where hexxs prefix pad cp = + let h = showHex cp "" + in text (prefix ++ replicate (pad - length h) '0' ++ h) + + +interSemi :: JsRender doc => [doc] -> doc +interSemi = foldl ($$$) empty . punctuateFinal semi semi + +-- | The structure `{body}`, optionally indented over multiple lines +{-# INLINE braceNest #-} +braceNest :: JsRender doc => doc -> doc +braceNest x = lbrace $$$ jnest x $$$ rbrace + +-- | The structure `hdr {body}`, optionally indented over multiple lines +{-# INLINE hangBrace #-} +hangBrace :: JsRender doc => doc -> doc -> doc +hangBrace hdr body = jcat [ hdr <> char ' ' <> char '{', jnest body, char '}' ] + +{-# INLINE jhang #-} +jhang :: JsRender doc => doc -> doc -> doc +jhang hdr body = jcat [ hdr, jnest body] + +-- | JsRender controls the differences in whitespace between HLine and SDoc. +-- Generally, this involves the indentation and newlines in the human-readable +-- SDoc implementation being replaced in the HLine version by the minimal +-- whitespace required for valid JavaScript syntax. +class IsLine doc => JsRender doc where + + -- | Concatenate with an optional single space + (<+?>) :: doc -> doc -> doc + -- | Concatenate with an optional newline + ($$$) :: doc -> doc -> doc + -- | Concatenate these `doc`s, either vertically (SDoc) or horizontally (HLine) + jcat :: [doc] -> doc + -- | Optionally indent the following + jnest :: doc -> doc + -- | Append semi-colon (and line-break in HLine mode) + addSemi :: doc -> doc + +instance JsRender SDoc where + (<+?>) = (<+>) + {-# INLINE (<+?>) #-} + ($$$) = ($+$) + {-# INLINE ($$$) #-} + jcat = vcat + {-# INLINE jcat #-} + jnest = nest 2 + {-# INLINE jnest #-} + addSemi x = x <> semi + {-# INLINE addSemi #-} + + +instance JsRender HLine where + (<+?>) = (<>) + {-# INLINE (<+?>) #-} + ($$$) = (<>) + {-# INLINE ($$$) #-} + jcat = hcat + {-# INLINE jcat #-} + jnest = id + {-# INLINE jnest #-} + addSemi x = x <> semi <> char '\n' + -- we add a line-break to avoid issues with lines too long in minified outputs + {-# INLINE addSemi #-} 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. -- @@ -48,17 +48,19 @@ -- 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.Syntax ( -- * Deeply embedded JS datatypes JStat(..) , JExpr(..) , JVal(..) - , JOp(..) - , JUOp(..) + , Op(..) + , UOp(..) + , AOp(..) , Ident(..) - , identFS - , JsLabel + , JLabel -- * pattern synonyms over JS operators , pattern New , pattern Not @@ -76,63 +78,32 @@ , pattern LAnd , pattern Int , pattern String + , pattern Var , pattern PreInc , pattern PostInc , pattern PreDec , pattern PostDec - -- * Ident supply - , IdentSupply(..) - , newIdentSupply - , pseudoSaturate -- * Utility , SaneDouble(..) + , var + , true_ + , false_ ) 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.JS.Ident import GHC.Data.FastString -import GHC.Utils.Monad.State.Strict -import GHC.Types.Unique import GHC.Types.Unique.Map - --- | 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 +import GHC.Types.SaneDouble -newIdentSupply :: Maybe FastString -> [Ident] -newIdentSupply Nothing = newIdentSupply (Just "jmId") -newIdentSupply (Just pfx) = [ TxtI (mconcat [pfx,"_",mkFastString (show x)]) - | x <- [(0::Word64)..] - ] +import Control.DeepSeq --- | Given a Pseudo-saturate a value with garbage @<>@ identifiers. -pseudoSaturate :: IdentSupply a -> a -pseudoSaturate x = evalState (runIdentSupply x) $ newIdentSupply (Just "<>") +import Data.Data +import qualified Data.Semigroup as Semigroup -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) ++ ")" +import GHC.Generics -------------------------------------------------------------------------------- @@ -142,26 +113,27 @@ -- 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 - | ForInStat Bool Ident JExpr JStat -- ^ For-in, bool is "each' when True + = 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 - deriving (Eq, Typeable, Generic) + | TryStat JStat Ident JStat JStat -- ^ Try + | BlockStat [JStat] -- ^ Blocks + | ApplStat JExpr [JExpr] -- ^ Application + | UOpStat UOp JExpr -- ^ Unary operators + | AssignStat JExpr AOp JExpr -- ^ Binding form: @ @ + | LabelStat JLabel JStat -- ^ Statement Labels, makes me nostalgic for qbasic + | BreakStat (Maybe JLabel) -- ^ Break + | ContinueStat (Maybe JLabel) -- ^ Continue + | FuncStat !Ident [Ident] JStat -- ^ an explicit function definition + deriving (Eq, Generic) -- | A Label used for 'JStat', specifically 'BreakStat', 'ContinueStat' and of -- course 'LabelStat' -type JsLabel = LexicalFastString +type JLabel = LexicalFastString instance Semigroup JStat where (<>) = appendJStat @@ -178,9 +150,9 @@ 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 + (BlockStat xs , BlockStat ys) -> BlockStat $! xs ++ ys + (BlockStat xs , ys ) -> BlockStat $! xs ++ [ys] + (xs , BlockStat ys) -> BlockStat $! xs : ys (xs , ys ) -> BlockStat [xs,ys] @@ -189,20 +161,17 @@ -------------------------------------------------------------------------------- -- | 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 /Unsaturated/ expression. - -- See 'pseudoSaturate' - deriving (Eq, Typeable, Generic) + = 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 Op JExpr JExpr -- ^ Infix Expressions, see 'JExpr' pattern synonyms + | UOpExpr UOp JExpr -- ^ Unary Expressions + | IfExpr JExpr JExpr JExpr -- ^ If-expression + | ApplExpr JExpr [JExpr] -- ^ Application + 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. @@ -278,7 +247,6 @@ 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) @@ -287,30 +255,35 @@ 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 -------------------------------------------------------------------------------- + -- | 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 + = 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 + | JBool Bool -- ^ A Boolean | JHash (UniqMap FastString JExpr) -- ^ A JS HashMap: @{"foo": 0}@ - | JFunc [Ident] JStat -- ^ A function - | UnsatVal (IdentSupply JVal) -- ^ An /Unsaturated/ value, see 'pseudoSaturate' - deriving (Eq, Typeable, Generic) + | JFunc [Ident] JStat -- ^ A function + deriving (Eq, Generic) + -------------------------------------------------------------------------------- -- Operators -------------------------------------------------------------------------------- + -- | JS Binary Operators. We do not deeply embed the comma operator and the -- assignment operators -data JOp +data Op = EqOp -- ^ Equality: `==` | StrictEqOp -- ^ Strict Equality: `===` | NeqOp -- ^ InEquality: `!=` @@ -334,12 +307,12 @@ | LOrOp -- ^ Logical Or: || | InstanceofOp -- ^ @instanceof@ | InOp -- ^ @in@ - deriving (Show, Eq, Ord, Enum, Data, Typeable, Generic) + deriving (Show, Eq, Ord, Enum, Data, Generic) -instance NFData JOp +instance NFData Op -- | JS Unary Operators -data JUOp +data UOp = NotOp -- ^ Logical Not: @!@ | BNotOp -- ^ Bitwise Not: @~@ | NegOp -- ^ Negation: @-@ @@ -353,40 +326,27 @@ | PostIncOp -- ^ Postfix Increment: @x++@ | PreDecOp -- ^ Prefix Decrement: @--x@ | PostDecOp -- ^ Postfix Decrement: @x--@ - deriving (Show, Eq, Ord, Enum, Data, Typeable, Generic) - -instance NFData JUOp - --- | A newtype wrapper around 'Double' to ensure we never generate a 'Double' --- that becomes a 'NaN', see 'Eq SaneDouble', 'Ord SaneDouble' for details on --- Sane-ness -newtype SaneDouble = SaneDouble - { unSaneDouble :: Double - } - deriving (Data, Typeable, Fractional, Num, Generic, NFData) - -instance Eq SaneDouble where - (SaneDouble x) == (SaneDouble y) = x == y || (isNaN x && isNaN y) + deriving (Show, Eq, Ord, Enum, Data, Generic) -instance Ord SaneDouble where - compare (SaneDouble x) (SaneDouble y) = compare (fromNaN x) (fromNaN y) - where fromNaN z | isNaN z = Nothing - | otherwise = Just z +instance NFData UOp -instance Show SaneDouble where - show (SaneDouble x) = show x +-- | JS Unary Operators +data AOp + = AssignOp -- ^ Vanilla Assignment: = + | AddAssignOp -- ^ Addition Assignment: += + | SubAssignOp -- ^ Subtraction Assignment: -= + deriving (Show, Eq, Ord, Enum, Data, Generic) +instance NFData AOp --------------------------------------------------------------------------------- --- Identifiers --------------------------------------------------------------------------------- --- We use FastString for identifiers in JS backend +-- | construct a JS variable reference +var :: FastString -> JExpr +var = Var . name --- | A newtype wrapper around 'FastString' for JS identifiers. -newtype Ident = TxtI { itxt :: FastString } - deriving stock (Show, Eq) - deriving newtype (Uniquable) +-- | The JS literal 'true' +true_ :: JExpr +true_ = ValExpr (JBool True) -identFS :: Ident -> FastString -identFS = \case - TxtI fs -> fs +-- | 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,114 +1,57 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE BlockArguments #-} +{-# LANGUAGE TupleSections #-} module GHC.JS.Transform - ( mapIdent - , mapStatIdent - , mapExprIdent - , identsS + ( identsS , identsV , identsE - -- * Saturation - , jsSaturate - -- * Generic traversal (via compos) - , JMacro(..) - , JMGadt(..) - , Compos(..) - , composOp - , composOpM - , composOpM_ - , composOpFold + , jStgExprToJS + , jStgStatToJS ) where import GHC.Prelude -import GHC.JS.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.Bifunctor +import Data.List (sortBy) import GHC.Data.FastString -import GHC.Utils.Monad.State.Strict import GHC.Types.Unique.Map +import GHC.Types.Unique.FM -mapExprIdent :: (Ident -> JExpr) -> JExpr -> JExpr -mapExprIdent f = fst (mapIdent f) -mapStatIdent :: (Ident -> JExpr) -> JStat -> JStat -mapStatIdent f = snd (mapIdent f) - --- | Map on every variable ident -mapIdent :: (Ident -> JExpr) -> (JExpr -> JExpr, JStat -> JStat) -mapIdent f = (map_expr, map_stat) - where - map_expr = \case - ValExpr v -> map_val v - SelExpr e i -> SelExpr (map_expr e) i - IdxExpr e1 e2 -> IdxExpr (map_expr e1) (map_expr e2) - InfixExpr o e1 e2 -> InfixExpr o (map_expr e1) (map_expr e2) - UOpExpr o e -> UOpExpr o (map_expr e) - IfExpr e1 e2 e3 -> IfExpr (map_expr e1) (map_expr e2) (map_expr e3) - ApplExpr e es -> ApplExpr (map_expr e) (fmap map_expr es) - UnsatExpr me -> UnsatExpr (fmap map_expr me) - - map_val v = case v of - JVar i -> f i - JList es -> ValExpr $ JList (fmap map_expr es) - JDouble{} -> ValExpr $ v - JInt{} -> ValExpr $ v - JStr{} -> ValExpr $ v - JRegEx{} -> ValExpr $ v - JHash me -> ValExpr $ JHash (fmap map_expr me) - JFunc is s -> ValExpr $ JFunc is (map_stat s) - UnsatVal v2 -> ValExpr $ UnsatVal v2 - - map_stat s = case s of - DeclStat i e -> DeclStat i (fmap map_expr e) - ReturnStat e -> ReturnStat (map_expr e) - IfStat e s1 s2 -> IfStat (map_expr e) (map_stat s1) (map_stat s2) - WhileStat b e s2 -> WhileStat b (map_expr e) (map_stat s2) - ForInStat b i e s2 -> ForInStat b i (map_expr e) (map_stat s2) - SwitchStat e les s2 -> SwitchStat (map_expr e) (fmap (bimap map_expr map_stat) les) (map_stat s2) - TryStat s2 i s3 s4 -> TryStat (map_stat s2) i (map_stat s3) (map_stat s4) - BlockStat ls -> BlockStat (fmap map_stat ls) - ApplStat e es -> ApplStat (map_expr e) (fmap map_expr es) - UOpStat o e -> UOpStat o (map_expr e) - AssignStat e1 e2 -> AssignStat (map_expr e1) (map_expr e2) - UnsatBlock ms -> UnsatBlock (fmap map_stat ms) - LabelStat l s2 -> LabelStat l (map_stat s2) - BreakStat{} -> s - ContinueStat{} -> s - {-# INLINE identsS #-} -identsS :: JStat -> [Ident] +identsS :: JStgStat -> [Ident] identsS = \case 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 + 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 e2 -> identsE e1 ++ identsE e2 - UnsatBlock{} -> error "identsS: UnsatBlock" + 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 :: JExpr -> [Ident] +identsE :: JStgExpr -> [Ident] identsE = \case ValExpr v -> identsV v SelExpr e _i -> identsE e -- do not rename properties @@ -117,7 +60,6 @@ UOpExpr _ e -> identsE e IfExpr e1 e2 e3 -> identsE e1 ++ identsE e2 ++ identsE e3 ApplExpr e es -> identsE e ++ concatMap identsE es - UnsatExpr{} -> error "identsE: UnsatExpr" {-# INLINE identsV #-} identsV :: JVal -> [Ident] @@ -128,137 +70,109 @@ JInt{} -> [] JStr{} -> [] JRegEx{} -> [] - JHash m -> concatMap (identsE . snd) (nonDetEltsUniqMap m) + JBool{} -> [] + JHash m -> concatMap identsE (nonDetEltsUniqMap m) JFunc args s -> args ++ identsS s - UnsatVal{} -> error "identsV: UnsatVal" - -{-------------------------------------------------------------------- - 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) +-------------------------------------------------------------------------------- +-- 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 -instance Compos JMGadt where - compos = jmcompos +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 -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 - 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) - 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 (nonDetEltsUniqMap 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' +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,) $ 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 $ (map f . sortBy compareHash $ nonDetEltsUFM m) + JFunc args body -> JS.JFunc args $ jStgStatToJS body +jStgOpToJS :: Op -> JS.Op +jStgOpToJS = go 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 ---------------------------------------------------------------------} + 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 --- | Given an optional prefix, fills in all free variable names with a supply --- of names generated by the prefix. -jsSaturate :: (JMacro a) => Maybe FastString -> a -> a -jsSaturate str x = evalState (runIdentSupply $ jsSaturate_ x) (newIdentSupply str) +jStgUOpToJS :: UOp -> JS.UOp +jStgUOpToJS = go + where + 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 -jsSaturate_ :: (JMacro a) => a -> IdentSupply a -jsSaturate_ e = IS $ jfromGADT <$> go (jtoGADT e) - where - go :: forall a. JMGadt a -> State [Ident] (JMGadt a) - go v = case v of - JMGStat (UnsatBlock us) -> go =<< (JMGStat <$> runIdentSupply us) - JMGExpr (UnsatExpr us) -> go =<< (JMGExpr <$> runIdentSupply us) - JMGVal (UnsatVal us) -> go =<< (JMGVal <$> runIdentSupply us) - _ -> composOpM go v +jStgAOpToJS :: AOp -> JS.AOp +jStgAOpToJS AssignOp = JS.AssignOp +jStgAOpToJS AddAssignOp = JS.AddAssignOp +jStgAOpToJS SubAssignOp = JS.SubAssignOp 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 new file mode 100644 --- /dev/null +++ b/GHC/Linker/Deps.hs @@ -0,0 +1,312 @@ +-- The transition from Int to Word64 for uniques makes functions slightly larger +-- without this GHC option some optimizations fail to fire. +-- See https://gitlab.haskell.org/ghc/ghc/-/merge_requests/10568#note_505751 +{-# OPTIONS_GHC -fspec-constr-threshold=10000 #-} + +{-# LANGUAGE CPP #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE LambdaCase #-} + +module GHC.Linker.Deps + ( LinkDepsOpts (..) + , LinkDeps (..) + , getLinkDeps + ) +where + +import GHC.Prelude + +import GHC.Platform.Ways + +import GHC.Runtime.Interpreter + +import GHC.Linker.Types + +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.Error + +import GHC.Unit.Env +import GHC.Unit.Finder +import GHC.Unit.Module +import GHC.Unit.Module.WholeCoreBindings +import GHC.Unit.Home.ModInfo + +import GHC.Iface.Errors.Types + +import GHC.Utils.Misc +import qualified GHC.Unit.Home.Graph as HUG +import GHC.Data.Maybe + +import Control.Applicative + +import Data.List (isSuffixOf) + +import System.FilePath +import System.Directory + +data LinkDepsOpts = LinkDepsOpts + { ldObjSuffix :: !String -- ^ Suffix of .o files + , ldForceDyn :: !Bool -- ^ Always use .dyn_o? + , ldUnitEnv :: !UnitEnv + , ldPprOpts :: !SDocContext -- ^ Rendering options for error messages + , ldUseByteCode :: !Bool -- ^ Use bytecode rather than objects + , ldMsgOpts :: !(DiagnosticOpts IfaceMessage) -- ^ Options for diagnostics + , ldWays :: !Ways -- ^ Enabled ways + , ldFinderCache :: !FinderCache + , ldFinderOpts :: !FinderOpts + , ldLoadByteCode :: !(Module -> IO (Maybe Linkable)) + , ldGetDependencies :: !([Module] -> IO ([Module], UniqDSet UnitId)) + } + +data LinkDeps = LinkDeps + { ldNeededLinkables :: [Linkable] + , ldAllLinkables :: [Linkable] + , ldUnits :: [UnitId] + , ldNeededUnits :: UniqDSet UnitId + } + +-- | Find all the packages and linkables that a set of modules depends on +-- +-- Return the module and package dependencies for the needed modules. +-- See Note [Object File Dependencies] +-- +-- Fails with an IO exception if it can't find enough files +-- +getLinkDeps + :: LinkDepsOpts + -> Interp + -> LoaderState + -> SrcSpan -- for error messages + -> [Module] -- If you need these + -> IO LinkDeps -- ... then link these first +getLinkDeps opts interp pls span mods = do + -- The interpreter and dynamic linker can only handle object code built + -- the "normal" way, i.e. no non-std ways like profiling or ticky-ticky. + -- So here we check the build tag: if we're building a non-standard way + -- then we need to find & link object files built the "normal" way. + maybe_normal_osuf <- checkNonStdWay opts interp span + + get_link_deps opts pls maybe_normal_osuf span mods + +get_link_deps + :: LinkDepsOpts + -> LoaderState + -> Maybe FilePath -- replace object suffixes? + -> SrcSpan + -> [Module] + -> IO LinkDeps +get_link_deps opts pls maybe_normal_osuf span mods = do + + -- 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) <- ldGetDependencies opts relevant_mods + + let + -- 2. Exclude ones already linked + -- Main reason: avoid findModule calls in get_linkable + (mods_needed, links_got) = partitionWith split_mods mods_s + pkgs_needed = eltsUDFM $ getUniqDSet pkgs_s `minusUDFM` pkgs_loaded pls + + 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 + -- compilation) we may need to use maybe_getFileLinkable + lnks_needed <- mapM (get_linkable (ldObjSuffix opts)) mods_needed + + return $ LinkDeps + { ldNeededLinkables = lnks_needed + , ldAllLinkables = links_got ++ lnks_needed + , ldUnits = pkgs_needed + , ldNeededUnits = pkgs_s + } + where + unit_env = ldUnitEnv opts + relevant_mods = filterOut isInteractiveModule mods + + no_obj :: Outputable a => a -> IO b + no_obj mod = dieWith opts span $ + text "cannot find object file for module " <> + quotes (ppr mod) $$ + while_linking_expr + + while_linking_expr = text "while linking an interpreted expression" + + + -- See Note [Using Byte Code rather than Object Code for Template Haskell] + homeModLinkable :: HomeModInfo -> Maybe Linkable + homeModLinkable hmi = + if ldUseByteCode opts + then homeModInfoByteCode hmi <|> homeModInfoObject hmi + else homeModInfoObject hmi <|> homeModInfoByteCode hmi + + get_linkable osuf mod -- A home-package module + = HUG.lookupHugByModule mod (ue_home_unit_graph unit_env) >>= \case + Just mod_info -> adjust_linkable (expectJust (homeModLinkable mod_info)) + Nothing -> do + -- It's not in the HPT because we are in one shot mode, + -- so use the Finder to get a ModLocation... + case ue_homeUnit unit_env of + Nothing -> no_obj mod + Just home_unit -> do + from_bc <- ldLoadByteCode opts mod + maybe (fallback_no_bytecode home_unit mod) pure from_bc + where + + fallback_no_bytecode home_unit mod = do + 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_parts <- mapM (adjust_part new_osuf) + (linkableParts lnk) + return lnk{ linkableParts=new_parts } + | otherwise = + return lnk + + 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 + ok <- doesFileExist new_file + if (not ok) + then dieWith opts span $ + text "cannot find object file " + <> quotes (text new_file) $$ while_linking_expr + 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 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? + +* Producing object code is much slower than producing byte code (for example if you're using -fno-code) +* Linking many large object files, which happens once per splice, is quite expensive. (#21700) + +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 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 +dieWith opts span msg = throwProgramError opts (mkLocMessage MCFatal span msg) + +throwProgramError :: LinkDepsOpts -> SDoc -> IO a +throwProgramError opts doc = throwGhcExceptionIO (ProgramError (renderWithContext (ldPprOpts opts) doc)) + +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 + -- we will use the appropriate variant of the iserv binary to load them. + +-- #if-guard the following equations otherwise the pattern match checker will +-- complain that they are redundant. +#if defined(HAVE_INTERNAL_INTERPRETER) +checkNonStdWay opts _interp srcspan + | hostFullWays == targetFullWays = return Nothing + -- Only if we are compiling with the same ways as GHC is built + -- with, can we dynamically load those object files. (see #3604) + + | ldObjSuffix opts == normalObjectSuffix && not (null targetFullWays) + = failNonStd opts srcspan + + | otherwise = return (Just (hostWayTag ++ "o")) + where + targetFullWays = fullWays (ldWays opts) + hostWayTag = case waysTag hostFullWays of + "" -> "" + tag -> tag ++ "_" + + normalObjectSuffix :: String + normalObjectSuffix = "o" + +data Way' = Normal | Prof | Dyn | ProfDyn + +failNonStd :: LinkDepsOpts -> SrcSpan -> IO (Maybe FilePath) +failNonStd opts srcspan = dieWith opts srcspan $ + text "Cannot load" <+> pprWay' compWay <+> + text "objects when GHC is built" <+> pprWay' ghciWay $$ + text "To fix this, either:" $$ + 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 + buildTwiceMsg = case (ghciWay, compWay) of + (Normal, Dyn) -> dynamicTooMsg + (Dyn, Normal) -> dynamicTooMsg + _ -> + text " (2) Build the program twice: once" <+> + pprWay' ghciWay <> text ", and then" $$ + text " " <> pprWay' compWay <+> + text "using -osuf to set a different object file suffix." + dynamicTooMsg = text " (2) Use -dynamic-too," <+> + text "and use -osuf and -dynosuf to set object file suffixes as needed." + pprWay' :: Way' -> SDoc + pprWay' way = text $ case way of + 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 @@ -29,6 +27,12 @@ , withExtendedLoadedEnv , extendLoadedEnv , deleteFromLoadedEnv + -- * Internals + , allocateBreakArrays + , rmDupLinkables + , modifyLoaderState + , initLinkDepsOpts + , getGccSearchDirectory ) where @@ -43,20 +47,23 @@ import GHC.Driver.Env import GHC.Driver.Session import GHC.Driver.Ppr -import GHC.Driver.Config import GHC.Driver.Config.Diagnostic import GHC.Driver.Config.Finder import GHC.Tc.Utils.Monad import GHC.Runtime.Interpreter +import GHCi.BreakArray import GHCi.RemoteTypes - +import GHC.Iface.Load +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 @@ -68,24 +75,23 @@ import GHC.Utils.Outputable import GHC.Utils.Panic -import GHC.Utils.Panic.Plain import GHC.Utils.Error import GHC.Utils.Logger import GHC.Utils.TmpFs import GHC.Unit.Env -import GHC.Unit.Finder +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.Module.WholeCoreBindings -import GHC.Unit.Module.Deps -import GHC.Unit.Home.ModInfo import GHC.Unit.State as Packages import qualified GHC.Data.ShortText as ST -import qualified GHC.Data.Maybe as Maybes import GHC.Data.FastString +import GHC.Linker.Deps import GHC.Linker.MacOS import GHC.Linker.Dynamic import GHC.Linker.Types @@ -93,14 +99,18 @@ -- Standard libraries import Control.Monad +import Data.Array +import Data.ByteString (ByteString) import qualified Data.Set as Set -import qualified Data.Map as M import Data.Char (isSpace) +import qualified Data.Foldable as Foldable import Data.IORef -import Data.List (intercalate, isPrefixOf, isSuffixOf, nub, partition) +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 @@ -112,14 +122,40 @@ #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) -import GHC.Unit.Module.Graph -import GHC.Types.SourceFile -import GHC.Utils.Misc -import GHC.Iface.Load -import GHC.Unit.Home -import Data.Either -import Control.Applicative +-- 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" @@ -150,13 +186,17 @@ , 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. -- -- The linker's symbol table is populated with RTS symbols using an -- explicit list. See rts/Linker.c for details. - where init_pkgs = unitUDFM rtsUnitId (LoadedPkgInfo rtsUnitId [] [] emptyUniqDSet) + where init_pkgs = unitUDFM rtsUnitId (LoadedPkgInfo rtsUnitId [] [] [] emptyUniqDSet) extendLoadedEnv :: Interp -> [(Name,ForeignHValue)] -> IO () extendLoadedEnv interp new_bindings = @@ -190,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 @@ -205,30 +245,25 @@ -> SrcSpan -> [Module] -> IO (LoaderState, SuccessFlag, [Linkable], PkgsLoaded) -- ^ returns the set of linkables required +-- When called, the loader state must have been initialized (see `initLoaderState`) loadDependencies interp hsc_env pls span needed_mods = do --- initLoaderState (hsc_dflags hsc_env) dl - let dflags = hsc_dflags hsc_env - -- The interpreter and dynamic linker can only handle object code built - -- the "normal" way, i.e. no non-std ways like profiling or ticky-ticky. - -- So here we check the build tag: if we're building a non-standard way - -- then we need to find & link object files built the "normal" way. - maybe_normal_osuf <- checkNonStdWay dflags interp span + let opts = initLinkDepsOpts hsc_env -- Find what packages and linkables are required - (lnks, all_lnks, pkgs, this_pkgs_needed) - <- getLinkDeps hsc_env pls - maybe_normal_osuf span needed_mods + deps <- getLinkDeps opts interp pls span needed_mods + let this_pkgs_needed = ldNeededUnits deps + -- Link the packages and modules required - pls1 <- loadPackages' interp hsc_env pkgs pls - (pls2, succ) <- loadModuleLinkables interp hsc_env pls1 lnks + pls1 <- loadPackages' interp hsc_env (ldUnits deps) pls + (pls2, succ) <- loadModuleLinkables interp hsc_env pls1 (ldNeededLinkables deps) let this_pkgs_loaded = udfmRestrictKeys all_pkgs_loaded $ getUniqDSet trans_pkgs_needed all_pkgs_loaded = pkgs_loaded pls2 trans_pkgs_needed = unionManyUniqDSets (this_pkgs_needed : [ loaded_pkg_trans_deps pkg | pkg_id <- uniqDSetToList this_pkgs_needed , Just pkg <- [lookupUDFM all_pkgs_loaded pkg_id] ]) - return (pls2, succ, all_lnks, this_pkgs_loaded) + return (pls2, succ, ldAllLinkables deps, this_pkgs_loaded) -- | Temporarily extend the loaded env. @@ -303,17 +338,24 @@ -- Initialise the linker state let pls0 = emptyLoaderState - -- (a) initialise the C dynamic linker - initObjLinker interp + case platformArch (targetPlatform (hsc_dflags hsc_env)) of + -- FIXME: we don't initialize anything with the JS interpreter. + -- Perhaps we should load preload packages. We'll load them on demand + -- anyway. + ArchJavaScript -> return pls0 + _ -> do + -- (a) initialise the C dynamic linker + initObjLinker interp - -- (b) Load packages from the command-line (Note [preload packages]) - pls <- unitEnv_foldWithKey (\k u env -> k >>= \pls' -> loadPackages' interp (hscSetActiveUnitId u hsc_env) (preloadUnits (homeUnitEnv_units env)) pls') (return pls0) (hsc_HUG hsc_env) - -- steps (c), (d) and (e) - loadCmdLineLibs' interp hsc_env pls + -- (b) Load packages from the command-line (Note [preload packages]) + pls <- unitEnv_foldWithKey (\k u env -> k >>= \pls' -> loadPackages' interp (hscSetActiveUnitId u hsc_env) (preloadUnits (homeUnitEnv_units env)) pls') (return pls0) (hsc_HUG hsc_env) + -- steps (c), (d) and (e) + loadCmdLineLibs' interp hsc_env pls + loadCmdLineLibs :: Interp -> HscEnv -> IO () loadCmdLineLibs interp hsc_env = do initLoaderState interp hsc_env @@ -494,25 +536,25 @@ DLL dll_unadorned -> do maybe_errstr <- loadDLL interp (platformSOName platform dll_unadorned) case maybe_errstr of - Nothing -> maybePutStrLn logger "done" - Just mm | platformOS platform /= OSDarwin -> + Right _ -> maybePutStrLn logger "done" + Left mm | platformOS platform /= OSDarwin -> preloadFailed mm lib_paths lib_spec - Just mm | otherwise -> do + Left mm | otherwise -> do -- As a backup, on Darwin, try to also load a .so file -- since (apparently) some things install that way - see -- ticket #8770. let libfile = ("lib" ++ dll_unadorned) <.> "so" err2 <- loadDLL interp libfile case err2 of - Nothing -> maybePutStrLn logger "done" - Just _ -> preloadFailed mm lib_paths lib_spec + Right _ -> maybePutStrLn logger "done" + Left _ -> preloadFailed mm lib_paths lib_spec return pls DLLPath dll_path -> do do maybe_errstr <- loadDLL interp dll_path case maybe_errstr of - Nothing -> maybePutStrLn logger "done" - Just mm -> preloadFailed mm lib_paths lib_spec + Right _ -> maybePutStrLn logger "done" + Left mm -> preloadFailed mm lib_paths lib_spec return pls Framework framework -> @@ -545,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 @@ -554,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 @@ -567,394 +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 le bco_ix nobreakarray root_ul_bco - bco_opts <- initBCOOpts (hsc_dflags hsc_env) - [root_hvref] <- createBCOs interp bco_opts [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. - -dieWith :: DynFlags -> SrcSpan -> SDoc -> IO a -dieWith dflags span msg = throwGhcExceptionIO (ProgramError (showSDoc dflags (mkLocMessage MCFatal span msg))) - - -checkNonStdWay :: DynFlags -> Interp -> SrcSpan -> IO (Maybe FilePath) -checkNonStdWay _dflags interp _srcspan - | 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 - -- we will use the appropriate variant of the iserv binary to load them. - --- #if-guard the following equations otherwise the pattern match checker will --- complain that they are redundant. -#if defined(HAVE_INTERNAL_INTERPRETER) -checkNonStdWay dflags _interp srcspan - | hostFullWays == targetFullWays = return Nothing - -- Only if we are compiling with the same ways as GHC is built - -- with, can we dynamically load those object files. (see #3604) - - | objectSuf_ dflags == normalObjectSuffix && not (null targetFullWays) - = failNonStd dflags srcspan - - | otherwise = return (Just (hostWayTag ++ "o")) - where - targetFullWays = fullWays (ways dflags) - hostWayTag = case waysTag hostFullWays of - "" -> "" - tag -> tag ++ "_" - - normalObjectSuffix :: String - normalObjectSuffix = phaseInputExt StopLn - -data Way' = Normal | Prof | Dyn - -failNonStd :: DynFlags -> SrcSpan -> IO (Maybe FilePath) -failNonStd dflags srcspan = dieWith dflags srcspan $ - text "Cannot load" <+> pprWay' compWay <+> - text "objects when GHC is built" <+> pprWay' ghciWay $$ - text "To fix this, either:" $$ - text " (1) Use -fexternal-interpreter, or" $$ - buildTwiceMsg - where compWay - | ways dflags `hasWay` WayDyn = Dyn - | ways dflags `hasWay` WayProf = Prof - | otherwise = Normal - ghciWay - | hostIsDynamic = Dyn - | hostIsProfiled = Prof - | otherwise = Normal - buildTwiceMsg = case (ghciWay, compWay) of - (Normal, Dyn) -> dynamicTooMsg - (Dyn, Normal) -> dynamicTooMsg - _ -> - text " (2) Build the program twice: once" <+> - pprWay' ghciWay <> text ", and then" $$ - text " " <> pprWay' compWay <+> - text "using -osuf to set a different object file suffix." - dynamicTooMsg = text " (2) Use -dynamic-too," <+> - text "and use -osuf and -dynosuf to set object file suffixes as needed." - pprWay' :: Way' -> SDoc - pprWay' way = text $ case way of - Normal -> "the normal way" - Prof -> "with -prof" - Dyn -> "with -dynamic" -#endif - -getLinkDeps :: HscEnv - -> LoaderState - -> Maybe FilePath -- replace object suffixes? - -> SrcSpan -- for error messages - -> [Module] -- If you need these - -> IO ([Linkable], [Linkable], [UnitId], UniqDSet UnitId) -- ... then link these first - -- The module and package dependencies for the needed modules are returned. - -- See Note [Object File Dependencies] --- Fails with an IO exception if it can't find enough files - -getLinkDeps hsc_env pls replace_osuf span mods --- Find all the packages and linkables that a set of modules depends on - = do { - -- 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 isOneShot (ghcMode dflags) - 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)) - - ; 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 - - split_mods mod = - let is_linked = findModuleLinkable_maybe (objs_loaded pls) mod <|> findModuleLinkable_maybe (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 - -- compilation) we may need to use maybe_getFileLinkable - ; let { osuf = objectSuf dflags } - ; lnks_needed <- mapM (get_linkable osuf) mods_needed - - ; return (lnks_needed, links_got ++ lnks_needed, pkgs_needed, pkgs_s) } +initLinkDepsOpts :: HscEnv -> LinkDepsOpts +initLinkDepsOpts hsc_env = opts where + opts = LinkDepsOpts + { ldObjSuffix = objectSuf dflags + , ldForceDyn = sTargetRTSLinkerOnlySupportsSharedLibs $ settings dflags + , ldUnitEnv = hsc_unit_env hsc_env + , 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 - mod_graph = hsc_mod_graph hsc_env - -- 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 (hsc_HUG hsc_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 -> - let err = text "getLinkDeps: Home module not loaded" <+> ppr (gwib_mod gwib) <+> ppr uid - in throwGhcExceptionIO (ProgramError (showSDoc dflags err)) + 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) - -- 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 <- initIfaceCheck (text "getLinkDeps") hsc_env $ - loadInterface msg mod (ImportByUser NotBoot) - iface <- case mb_iface of - Maybes.Failed err -> throwGhcExceptionIO (ProgramError (showSDoc dflags err)) - Maybes.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 hsc_home_unit_maybe hsc_env of - Nothing -> [] - Just home_unit -> filter (not . (`elementOfUniqDSet` acc_mods)) (map (mkHomeModule home_unit) $ (boot_deps ++ mod_deps)) - acc_mods' = case hsc_home_unit_maybe hsc_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) +get_reachable_nodes :: HscEnv -> [Module] -> IO ([Module], UniqDSet UnitId) +get_reachable_nodes hsc_env mods - case hsc_home_unit_maybe hsc_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" + -- 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) - link_boot_mod_error :: Module -> IO a - link_boot_mod_error mod = - throwGhcExceptionIO (ProgramError (showSDoc dflags ( - text "module" <+> ppr mod <+> - text "cannot be linked; it is only available as a boot module"))) + hmgModKey mg m + | let k = NodeKey_Module (mkModuleNk m) + , mgMember mg k = k + | otherwise = NodeKey_ExternalUnit (moduleUnitId m) - no_obj :: Outputable a => a -> IO b - no_obj mod = dieWith dflags span $ - text "cannot find object file for module " <> - quotes (ppr mod) $$ - while_linking_expr + -- 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) - while_linking_expr = text "while linking an interpreted expression" + 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 - -- See Note [Using Byte Code rather than Object Code for Template Haskell] - homeModLinkable :: DynFlags -> HomeModInfo -> Maybe Linkable - homeModLinkable dflags hmi = - if gopt Opt_UseBytecodeRatherThanObjects dflags - then homeModInfoByteCode hmi <|> homeModInfoObject hmi - else homeModInfoObject hmi <|> homeModInfoByteCode hmi - - get_linkable osuf mod -- A home-package module - | Just mod_info <- lookupHugByModule mod (hsc_HUG hsc_env) - = adjust_linkable (Maybes.expectJust "getLinkDeps" (homeModLinkable dflags 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 hsc_home_unit_maybe hsc_env of - Nothing -> no_obj mod - Just home_unit -> do - - let fc = hsc_FC hsc_env - let dflags = hsc_dflags hsc_env - let fopts = initFinderOpts dflags - mb_stuff <- findHomeModule fc fopts home_unit (moduleName mod) - case mb_stuff of - Found loc mod -> found loc mod - _ -> no_obj (moduleName mod) - 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 - }} - - adjust_linkable lnk - | Just new_osuf <- replace_osuf = do - new_uls <- mapM (adjust_ul new_osuf) - (linkableUnlinked lnk) - return lnk{ linkableUnlinked=new_uls } - | otherwise = - return lnk - - adjust_ul new_osuf (DotO file) = do - massert (osuf `isSuffixOf` file) - let file_base = fromJust (stripExtension osuf file) - new_file = file_base <.> new_osuf - ok <- doesFileExist new_file - if (not ok) - then dieWith dflags 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) - -{- -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 -when executing Template Haskell splices. - -Why might you want to use byte code rather than object code? - -* Producing object code is much slower than producing byte code (for example if you're using -fno-code) -* Linking many large object files, which happens once per splice, is quite expensive. (#21700) - -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. -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. - --} - {- ********************************************************************** 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 - bco_opts <- initBCOOpts (hsc_dflags hsc_env) - new_bindings <- linkSomeBCOs bco_opts interp 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, @@ -993,9 +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) - bco_opts <- initBCOOpts (hsc_dflags hsc_env) + 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 @@ -1003,28 +774,15 @@ if failed ok_flag then return (pls1, Failed) else do - pls2 <- dynLinkBCOs bco_opts interp pls1 bcos + 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] - -findModuleLinkable_maybe :: LinkableSet -> Module -> Maybe Linkable -findModuleLinkable_maybe = lookupModuleEnv - linkableInSet :: Linkable -> LinkableSet -> Bool linkableInSet l objs_loaded = - case findModuleLinkable_maybe objs_loaded (linkableModule l) of + case lookupModuleEnv objs_loaded (linkableModule l) of Nothing -> False Just m -> linkableTime l == linkableTime m @@ -1048,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 @@ -1111,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 @@ -1132,8 +893,8 @@ changeTempFilesLifetime tmpfs TFL_GhcSession [soFile] m <- loadDLL interp soFile case m of - Nothing -> return $! pls { temp_sos = (libPath, libName) : temp_sos } - Just err -> linkFail msg err + Right _ -> return $! pls { temp_sos = (libPath, libName) : temp_sos } + Left err -> linkFail msg (text err) where msg = "GHC.Linker.Loader.dynLoadObjs: Loading temp shared object failed" @@ -1156,24 +917,29 @@ ********************************************************************* -} -dynLinkBCOs :: BCOOpts -> Interp -> LoaderState -> [Linkable] -> IO LoaderState -dynLinkBCOs bco_opts interp pls bcos = do +dynLinkBCOs :: Interp -> LoaderState -> [Linkable] -> IO LoaderState +dynLinkBCOs interp pls bcos = do 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 bco_opts interp 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 @@ -1184,34 +950,32 @@ 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 :: BCOOpts - -> Interp +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 bco_opts interp 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 le bco_ix breakarray bco - | (breakarray, bco) <- flat ] - hvrefs <- createBCOs interp bco_opts resolved + resolved <- sequence [ linkBCO interp pkgs_loaded le lb bco_ix bco | bco <- flat ] + hvrefs <- createBCOs interp resolved return (zip names hvrefs) -- | Useful to apply to the result of 'linkSomeBCOs' @@ -1220,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 @@ -1276,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' @@ -1303,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 () @@ -1317,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 @@ -1372,18 +1145,18 @@ -- Link dependents first ; pkgs' <- link pkgs deps -- Now link the package itself - ; (hs_cls, extra_cls) <- loadPackage interp hsc_env pkg_cfg + ; (hs_cls, extra_cls, loaded_dlls) <- loadPackage interp hsc_env pkg_cfg ; let trans_deps = unionManyUniqDSets [ addOneToUniqDSet (loaded_pkg_trans_deps loaded_pkg_info) dep_pkg | dep_pkg <- deps , Just loaded_pkg_info <- pure (lookupUDFM pkgs' dep_pkg) ] - ; return (addToUDFM pkgs' new_pkg (LoadedPkgInfo new_pkg hs_cls extra_cls trans_deps)) } + ; return (addToUDFM pkgs' new_pkg (LoadedPkgInfo new_pkg hs_cls extra_cls loaded_dlls trans_deps)) } | otherwise = throwGhcExceptionIO (CmdLineError ("unknown package: " ++ unpackFS (unitIdFS new_pkg))) -loadPackage :: Interp -> HscEnv -> UnitInfo -> IO ([LibrarySpec], [LibrarySpec]) +loadPackage :: Interp -> HscEnv -> UnitInfo -> IO ([LibrarySpec], [LibrarySpec], [RemotePtr LoadedDLL]) loadPackage interp hsc_env pkg = do let dflags = hsc_dflags hsc_env @@ -1425,7 +1198,9 @@ let classifieds = hs_classifieds ++ extra_classifieds -- Complication: all the .so's must be loaded before any of the .o's. - let known_dlls = [ dll | DLLPath dll <- classifieds ] + let known_hs_dlls = [ dll | DLLPath dll <- hs_classifieds ] + known_extra_dlls = [ dll | DLLPath dll <- extra_classifieds ] + known_dlls = known_hs_dlls ++ known_extra_dlls #if defined(CAN_LOAD_DLL) dlls = [ dll | DLL dll <- classifieds ] #endif @@ -1446,10 +1221,13 @@ loadFrameworks interp platform pkg -- See Note [Crash early load_dyn and locateLib] -- Crash early if can't load any of `known_dlls` - mapM_ (load_dyn interp hsc_env True) known_dlls + mapM_ (load_dyn interp hsc_env True) known_extra_dlls + loaded_dlls <- mapMaybeM (load_dyn interp hsc_env True) known_hs_dlls -- For remaining `dlls` crash early only when there is surely -- no package's DLL around ... (not is_dyn) mapM_ (load_dyn interp hsc_env (not is_dyn) . platformSOName platform) dlls +#else + let loaded_dlls = [] #endif -- After loading all the DLLs, we can load the static objects. -- Ordering isn't important here, because we do one final link @@ -1469,7 +1247,7 @@ if succeeded ok then do maybePutStrLn logger "done." - return (hs_classifieds, extra_classifieds) + return (hs_classifieds, extra_classifieds, loaded_dlls) else let errmsg = text "unable to load unit `" <> pprUnitInfoForUser pkg <> text "'" in throwGhcExceptionIO (InstallationError (showSDoc dflags errmsg)) @@ -1522,19 +1300,20 @@ -- can be passed directly to loadDLL. They are either fully-qualified -- ("/usr/lib/libfoo.so"), or unqualified ("libfoo.so"). In the latter case, -- loadDLL is going to search the system paths to find the library. -load_dyn :: Interp -> HscEnv -> Bool -> FilePath -> IO () +load_dyn :: Interp -> HscEnv -> Bool -> FilePath -> IO (Maybe (RemotePtr LoadedDLL)) load_dyn interp hsc_env crash_early dll = do r <- loadDLL interp dll case r of - Nothing -> return () - Just err -> + Right loaded_dll -> pure (Just loaded_dll) + Left err -> if crash_early then cmdLineErrorIO err - else + else do when (diag_wopt Opt_WarnMissedExtraSharedLib diag_opts) $ logMsg logger (mkMCDiagnostic diag_opts (WarningWithFlag Opt_WarnMissedExtraSharedLib) Nothing) noSrcSpan $ withPprStyle defaultUserStyle (note err) + pure Nothing where diag_opts = initDiagOpts (hsc_dflags hsc_env) logger = hsc_logger hsc_env @@ -1660,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) @@ -1762,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) @@ -1800,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 @@ -1871,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/MacOS.hs b/GHC/Linker/MacOS.hs --- a/GHC/Linker/MacOS.hs +++ b/GHC/Linker/MacOS.hs @@ -11,7 +11,7 @@ import GHC.Linker.Config -import GHC.Driver.Session +import GHC.Driver.DynFlags import GHC.Unit.Types import GHC.Unit.State @@ -172,6 +172,6 @@ findLoadDLL (p:ps) errs = do { dll <- loadDLL interp (p fwk_file) ; case dll of - Nothing -> return Nothing - Just err -> findLoadDLL ps ((p ++ ": " ++ err):errs) + Right _ -> return Nothing + Left err -> findLoadDLL ps ((p ++ ": " ++ err):errs) } 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,46 +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 ) +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 {- ********************************************************************** @@ -75,6 +93,53 @@ The LinkerEnv maps Names to actual closures (for interpreted code only), for use during linking. + +Note [Looking up symbols in the relevant objects] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In #23415, we determined that a lot of time (>10s, or even up to >35s!) was +being spent on dynamically loading symbols before actually interpreting code +when `:main` was run in GHCi. The root cause was that for each symbol we wanted +to lookup, we would traverse the list of loaded objects and try find the symbol +in each of them with dlsym (i.e. looking up a symbol was, worst case, linear in +the amount of loaded objects). + +To drastically improve load time (from +-38 seconds down to +-2s), we now: + +1. For every of the native objects loaded for a given unit, store the handles returned by `dlopen`. + - In `pkgs_loaded` of the `LoaderState`, which maps `UnitId`s to + `LoadedPkgInfo`s, where the handles live in its field `loaded_pkg_hs_dlls`. + +2. When looking up a Name (e.g. `lookupHsSymbol`), find that name's `UnitId` in + the `pkgs_loaded` mapping, + +3. And only look for the symbol (with `dlsym`) on the /handles relevant to that + unit/, rather than in every loaded object. + +Note [Symbols may not be found in pkgs_loaded] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Currently the `pkgs_loaded` mapping only contains the dynamic objects +associated with loaded units. Symbols defined in a static object (e.g. from a +statically-linked Haskell library) are found via the generic `lookupSymbol` +function call by `lookupHsSymbol` when the symbol is not found in any of the +dynamic objects of `pkgs_loaded`. + +The rationale here is two-fold: + + * we have only observed major link-time issues in dynamic linking; lookups in + the RTS linker's static symbol table seem to be fast enough + + * allowing symbol lookups restricted to a single ObjectCode would require the + maintenance of a symbol table per `ObjectCode`, which would introduce time and + space overhead + +This fallback is further needed because we don't look in the haskell objects +loaded for the home units (see the call to `loadModuleLinkables` in +`loadDependencies`, as opposed to the call to `loadPackages'` in the same +function which updates `pkgs_loaded`). We should ultimately keep track of the +objects loaded (probably in `objs_loaded`, for which `LinkableSet` is a bit +unsatisfactory, see a suggestion in 51c5c4eb1f2a33e4dc88e6a37b7b7c135234ce9b) +and be able to lookup symbols specifically in them too (similarly to +`lookupSymbolInDLL`). -} newtype Loader = Loader { loader_state :: MVar (Maybe LoaderState) } @@ -96,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 @@ -108,13 +176,13 @@ in pls { linker_env = le { closure_env = f ce } } data LinkerEnv = LinkerEnv - { closure_env :: ClosureEnv + { closure_env :: !ClosureEnv -- ^ Current global mapping from closure Names to their true values , 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. @@ -124,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) @@ -139,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 @@ -146,11 +237,13 @@ { loaded_pkg_uid :: !UnitId , loaded_pkg_hs_objs :: ![LibrarySpec] , loaded_pkg_non_hs_objs :: ![LibrarySpec] + , loaded_pkg_hs_dlls :: ![RemotePtr LoadedDLL] + -- ^ See Note [Looking up symbols in the relevant objects] , loaded_pkg_trans_deps :: UniqDSet UnitId } instance Outputable LoadedPkgInfo where - ppr (LoadedPkgInfo uid hs_objs non_hs_objs trans_deps) = + ppr (LoadedPkgInfo uid hs_objs non_hs_objs _ trans_deps) = vcat [ppr uid , ppr hs_objs , ppr non_hs_objs @@ -158,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 @@ -174,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 @@ -182,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 @@ -64,10 +74,16 @@ deriving (Eq, Ord, Enum) instance Outputable MetaId where - ppr (MetaId n) = char '!' <> int n + ppr = ppMetaId +ppMetaId :: IsLine doc => MetaId -> doc +ppMetaId (MetaId n) = char '!' <> int n +{-# SPECIALIZE ppMetaId :: MetaId -> SDoc #-} +{-# SPECIALIZE ppMetaId :: MetaId -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable + -- | LLVM metadata expressions data MetaExpr = MetaStr !LMString + | MetaLit !LlvmLit | MetaNode !MetaId | MetaVar !LlvmVar | MetaStruct [MetaExpr] @@ -86,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 @@ -1,5 +1,6 @@ {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE TypeApplications #-} -------------------------------------------------------------------------------- -- | Pretty print LLVM IR Code. @@ -26,7 +27,7 @@ ppLit, ppTypeLit, ppName, - ppPlainName + ppPlainName, ) where @@ -36,7 +37,6 @@ import GHC.Llvm.MetaData import GHC.Llvm.Types -import Data.Int import Data.List ( intersperse ) import GHC.Utils.Outputable @@ -49,30 +49,39 @@ -------------------------------------------------------------------------------- -- | Print out a whole LLVM module. -ppLlvmModule :: LlvmCgConfig -> LlvmModule -> SDoc +ppLlvmModule :: IsDoc doc => LlvmCgConfig -> LlvmModule -> doc ppLlvmModule opts (LlvmModule comments aliases meta globals decls funcs) - = ppLlvmComments comments $+$ newLine - $+$ ppLlvmAliases aliases $+$ newLine - $+$ ppLlvmMetas opts meta $+$ newLine - $+$ ppLlvmGlobals opts globals $+$ newLine - $+$ ppLlvmFunctionDecls decls $+$ newLine - $+$ ppLlvmFunctions opts funcs + = ppLlvmComments comments $$ newLine + $$ ppLlvmAliases aliases $$ newLine + $$ ppLlvmMetas opts meta $$ newLine + $$ ppLlvmGlobals opts globals $$ newLine + $$ ppLlvmFunctionDecls decls $$ newLine + $$ ppLlvmFunctions opts funcs +{-# SPECIALIZE ppLlvmModule :: LlvmCgConfig -> LlvmModule -> SDoc #-} +{-# SPECIALIZE ppLlvmModule :: LlvmCgConfig -> LlvmModule -> HDoc #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable + -- | Print out a multi-line comment, can be inside a function or on its own -ppLlvmComments :: [LMString] -> SDoc -ppLlvmComments comments = vcat $ map ppLlvmComment comments +ppLlvmComments :: IsDoc doc => [LMString] -> doc +ppLlvmComments comments = lines_ $ map ppLlvmComment comments +{-# SPECIALIZE ppLlvmComments :: [LMString] -> SDoc #-} +{-# SPECIALIZE ppLlvmComments :: [LMString] -> HDoc #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable -- | Print out a comment, can be inside a function or on its own -ppLlvmComment :: LMString -> SDoc +ppLlvmComment :: IsLine doc => LMString -> doc ppLlvmComment com = semi <+> ftext com +{-# SPECIALIZE ppLlvmComment :: LMString -> SDoc #-} +{-# SPECIALIZE ppLlvmComment :: LMString -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable -- | Print out a list of global mutable variable definitions -ppLlvmGlobals :: LlvmCgConfig -> [LMGlobal] -> SDoc -ppLlvmGlobals opts ls = vcat $ map (ppLlvmGlobal opts) ls +ppLlvmGlobals :: IsDoc doc => LlvmCgConfig -> [LMGlobal] -> doc +ppLlvmGlobals opts ls = lines_ $ map (ppLlvmGlobal opts) ls +{-# SPECIALIZE ppLlvmGlobals :: LlvmCgConfig -> [LMGlobal] -> SDoc #-} +{-# SPECIALIZE ppLlvmGlobals :: LlvmCgConfig -> [LMGlobal] -> HDoc #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable -- | Print out a global mutable variable definition -ppLlvmGlobal :: LlvmCgConfig -> LMGlobal -> SDoc +ppLlvmGlobal :: IsLine doc => LlvmCgConfig -> LMGlobal -> doc ppLlvmGlobal opts (LMGlobal var@(LMGlobalVar _ _ link x a c) dat) = let sect = case x of Just x' -> text ", section" <+> doubleQuotes (ftext x') @@ -84,7 +93,7 @@ rhs = case dat of Just stat -> pprSpecialStatic opts stat - Nothing -> ppr (pLower $ getVarType var) + Nothing -> ppLlvmType (pLower $ getVarType var) -- Position of linkage is different for aliases. const = case c of @@ -92,105 +101,130 @@ Constant -> "constant" Alias -> "alias" - in ppAssignment opts var $ ppr link <+> text const <+> rhs <> sect <> align - $+$ newLine + in ppAssignment opts var $ ppLlvmLinkageType link <+> text const <+> rhs <> sect <> align ppLlvmGlobal opts (LMGlobal var val) = pprPanic "ppLlvmGlobal" $ - text "Non Global var ppr as global! " <> ppVar opts var <> text "=" <> ppr (fmap (ppStatic opts) val) + text "Non Global var ppr as global! " <> ppVar opts var <> text "=" <> ppr (fmap (ppStatic @SDoc opts) val) +{-# SPECIALIZE ppLlvmGlobal :: LlvmCgConfig -> LMGlobal -> SDoc #-} +{-# SPECIALIZE ppLlvmGlobal :: LlvmCgConfig -> LMGlobal -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable -- | Print out a list of LLVM type aliases. -ppLlvmAliases :: [LlvmAlias] -> SDoc -ppLlvmAliases tys = vcat $ map ppLlvmAlias tys +ppLlvmAliases :: IsDoc doc => [LlvmAlias] -> doc +ppLlvmAliases tys = lines_ $ map ppLlvmAlias tys +{-# SPECIALIZE ppLlvmAliases :: [LlvmAlias] -> SDoc #-} +{-# SPECIALIZE ppLlvmAliases :: [LlvmAlias] -> HDoc #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable -- | Print out an LLVM type alias. -ppLlvmAlias :: LlvmAlias -> SDoc +ppLlvmAlias :: IsLine doc => LlvmAlias -> doc ppLlvmAlias (name, ty) - = char '%' <> ftext name <+> equals <+> text "type" <+> ppr ty + = char '%' <> ftext name <+> equals <+> text "type" <+> ppLlvmType ty +{-# SPECIALIZE ppLlvmAlias :: LlvmAlias -> SDoc #-} +{-# SPECIALIZE ppLlvmAlias :: LlvmAlias -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable -- | Print out a list of LLVM metadata. -ppLlvmMetas :: LlvmCgConfig -> [MetaDecl] -> SDoc -ppLlvmMetas opts metas = vcat $ map (ppLlvmMeta opts) metas +ppLlvmMetas :: IsDoc doc => LlvmCgConfig -> [MetaDecl] -> doc +ppLlvmMetas opts metas = lines_ $ map (ppLlvmMeta opts) metas +{-# SPECIALIZE ppLlvmMetas :: LlvmCgConfig -> [MetaDecl] -> SDoc #-} +{-# SPECIALIZE ppLlvmMetas :: LlvmCgConfig -> [MetaDecl] -> HDoc #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable -- | Print out an LLVM metadata definition. -ppLlvmMeta :: LlvmCgConfig -> MetaDecl -> SDoc +ppLlvmMeta :: IsLine doc => LlvmCgConfig -> MetaDecl -> doc ppLlvmMeta opts (MetaUnnamed n m) - = ppr n <+> equals <+> ppMetaExpr opts m + = ppMetaId n <+> equals <+> ppMetaExpr opts m ppLlvmMeta _opts (MetaNamed n m) = exclamation <> ftext n <+> equals <+> exclamation <> braces nodes where - nodes = hcat $ intersperse comma $ map ppr m + nodes = hcat $ intersperse comma $ map ppMetaId m +{-# SPECIALIZE ppLlvmMeta :: LlvmCgConfig -> MetaDecl -> SDoc #-} +{-# SPECIALIZE ppLlvmMeta :: LlvmCgConfig -> MetaDecl -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable -- | Print out a list of function definitions. -ppLlvmFunctions :: LlvmCgConfig -> LlvmFunctions -> SDoc +ppLlvmFunctions :: IsDoc doc => LlvmCgConfig -> LlvmFunctions -> doc ppLlvmFunctions opts funcs = vcat $ map (ppLlvmFunction opts) funcs +{-# SPECIALIZE ppLlvmFunctions :: LlvmCgConfig -> LlvmFunctions -> SDoc #-} +{-# SPECIALIZE ppLlvmFunctions :: LlvmCgConfig -> LlvmFunctions -> HDoc #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable -- | Print out a function definition. -ppLlvmFunction :: LlvmCgConfig -> LlvmFunction -> SDoc +ppLlvmFunction :: IsDoc doc => LlvmCgConfig -> LlvmFunction -> doc ppLlvmFunction opts fun = - let attrDoc = ppSpaceJoin (funcAttrs fun) + let attrDoc = ppSpaceJoin ppLlvmFuncAttr (funcAttrs fun) secDoc = case funcSect fun of Just s' -> text "section" <+> (doubleQuotes $ ftext s') Nothing -> empty prefixDoc = case funcPrefix fun of Just v -> text "prefix" <+> ppStatic opts v Nothing -> empty - in text "define" <+> ppLlvmFunctionHeader (funcDecl fun) (funcArgs fun) - <+> attrDoc <+> secDoc <+> prefixDoc - $+$ lbrace - $+$ ppLlvmBlocks opts (funcBody fun) - $+$ rbrace - $+$ newLine - $+$ newLine + in vcat + [line $ text "define" <+> ppLlvmFunctionHeader (funcDecl fun) (funcArgs fun) + <+> attrDoc <+> secDoc <+> prefixDoc + , line lbrace + , ppLlvmBlocks opts (funcBody fun) + , line rbrace + , newLine + , newLine] +{-# SPECIALIZE ppLlvmFunction :: LlvmCgConfig -> LlvmFunction -> SDoc #-} +{-# SPECIALIZE ppLlvmFunction :: LlvmCgConfig -> LlvmFunction -> HDoc #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable -- | Print out a function definition header. -ppLlvmFunctionHeader :: LlvmFunctionDecl -> [LMString] -> SDoc +ppLlvmFunctionHeader :: IsLine doc => LlvmFunctionDecl -> [LMString] -> doc ppLlvmFunctionHeader (LlvmFunctionDecl n l c r varg p a) args = let varg' = case varg of VarArgs | null p -> text "..." | otherwise -> text ", ..." _otherwise -> text "" align = case a of - Just a' -> text " align " <> ppr a' + Just a' -> text " align " <> int a' Nothing -> empty - args' = map (\((ty,p),n) -> ppr ty <+> ppSpaceJoin p <+> char '%' + args' = zipWith (\(ty,p) n -> ppLlvmType ty <+> ppSpaceJoin ppLlvmParamAttr p <+> char '%' <> ftext n) - (zip p args) - in ppr l <+> ppr c <+> ppr r <+> char '@' <> ftext n <> lparen <> - (hsep $ punctuate comma args') <> varg' <> rparen <> align + p + args + in ppLlvmLinkageType l <+> ppLlvmCallConvention c <+> ppLlvmType r <+> char '@' <> ftext n <> lparen <> + hsep (punctuate comma args') <> varg' <> rparen <> align +{-# SPECIALIZE ppLlvmFunctionHeader :: LlvmFunctionDecl -> [LMString] -> SDoc #-} +{-# SPECIALIZE ppLlvmFunctionHeader :: LlvmFunctionDecl -> [LMString] -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable -- | Print out a list of function declaration. -ppLlvmFunctionDecls :: LlvmFunctionDecls -> SDoc +ppLlvmFunctionDecls :: IsDoc doc => LlvmFunctionDecls -> doc ppLlvmFunctionDecls decs = vcat $ map ppLlvmFunctionDecl decs +{-# SPECIALIZE ppLlvmFunctionDecls :: LlvmFunctionDecls -> SDoc #-} +{-# SPECIALIZE ppLlvmFunctionDecls :: LlvmFunctionDecls -> HDoc #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable -- | Print out a function declaration. -- Declarations define the function type but don't define the actual body of -- the function. -ppLlvmFunctionDecl :: LlvmFunctionDecl -> SDoc +ppLlvmFunctionDecl :: IsDoc doc => LlvmFunctionDecl -> doc ppLlvmFunctionDecl (LlvmFunctionDecl n l c r varg p a) = let varg' = case varg of VarArgs | null p -> text "..." | otherwise -> text ", ..." _otherwise -> text "" align = case a of - Just a' -> text " align" <+> ppr a' + Just a' -> text " align" <+> int a' Nothing -> empty args = hcat $ intersperse (comma <> space) $ - map (\(t,a) -> ppr t <+> ppSpaceJoin a) p - in text "declare" <+> ppr l <+> ppr c <+> ppr r <+> char '@' <> - ftext n <> lparen <> args <> varg' <> rparen <> align $+$ newLine + map (\(t,a) -> ppLlvmType t <+> ppSpaceJoin ppLlvmParamAttr a) p + in lines_ + [ text "declare" <+> ppLlvmLinkageType l <+> ppLlvmCallConvention c + <+> ppLlvmType r <+> char '@' <> ftext n <> lparen <> args <> varg' <> rparen <> align + , empty] +{-# SPECIALIZE ppLlvmFunctionDecl :: LlvmFunctionDecl -> SDoc #-} +{-# SPECIALIZE ppLlvmFunctionDecl :: LlvmFunctionDecl -> HDoc #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable -- | Print out a list of LLVM blocks. -ppLlvmBlocks :: LlvmCgConfig -> LlvmBlocks -> SDoc +ppLlvmBlocks :: IsDoc doc => LlvmCgConfig -> LlvmBlocks -> doc ppLlvmBlocks opts blocks = vcat $ map (ppLlvmBlock opts) blocks +{-# SPECIALIZE ppLlvmBlocks :: LlvmCgConfig -> LlvmBlocks -> SDoc #-} +{-# SPECIALIZE ppLlvmBlocks :: LlvmCgConfig -> LlvmBlocks -> HDoc #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable -- | Print out an LLVM block. -- It must be part of a function definition. -ppLlvmBlock :: LlvmCgConfig -> LlvmBlock -> SDoc +ppLlvmBlock :: IsDoc doc => LlvmCgConfig -> LlvmBlock -> doc ppLlvmBlock opts (LlvmBlock blockId stmts) = let isLabel (MkLabel _) = True isLabel _ = False @@ -198,39 +232,44 @@ ppRest = case rest of MkLabel id:xs -> ppLlvmBlock opts (LlvmBlock id xs) _ -> empty - in ppLlvmBlockLabel blockId - $+$ (vcat $ map (ppLlvmStatement opts) block) - $+$ newLine - $+$ ppRest + in vcat $ + line (ppLlvmBlockLabel blockId) + : map (ppLlvmStatement opts) block + ++ [ empty , ppRest ] +{-# SPECIALIZE ppLlvmBlock :: LlvmCgConfig -> LlvmBlock -> SDoc #-} +{-# SPECIALIZE ppLlvmBlock :: LlvmCgConfig -> LlvmBlock -> HDoc #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable -- | Print out an LLVM block label. -ppLlvmBlockLabel :: LlvmBlockId -> SDoc +ppLlvmBlockLabel :: IsLine doc => LlvmBlockId -> doc ppLlvmBlockLabel id = pprUniqueAlways id <> colon +{-# SPECIALIZE ppLlvmBlockLabel :: LlvmBlockId -> SDoc #-} +{-# SPECIALIZE ppLlvmBlockLabel :: LlvmBlockId -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable --- | Print out an LLVM statement. -ppLlvmStatement :: LlvmCgConfig -> LlvmStatement -> SDoc +-- | Print out an LLVM statement, with any metadata to append to the statement. +ppLlvmStatement :: IsDoc doc => LlvmCgConfig -> LlvmStatement -> doc ppLlvmStatement opts stmt = - let ind = (text " " <>) + let ind = line . (text " " <>) in case stmt of Assignment dst expr -> ind $ ppAssignment opts dst (ppLlvmExpression opts expr) Fence st ord -> ind $ ppFence st ord Branch target -> ind $ ppBranch opts target BranchIf cond ifT ifF -> ind $ ppBranchIf opts cond ifT ifF - Comment comments -> ind $ ppLlvmComments comments - MkLabel label -> ppLlvmBlockLabel label - Store value ptr align - -> ind $ ppStore opts value ptr align - Switch scrut def tgs -> ind $ ppSwitch opts scrut def tgs + Comment comments -> ppLlvmComments comments + MkLabel label -> line $ ppLlvmBlockLabel label + Store value ptr align metas + -> ind $ ppStore opts value ptr align metas + Switch scrut def tgs -> ppSwitch opts scrut def tgs Return result -> ind $ ppReturn opts result Expr expr -> ind $ ppLlvmExpression opts expr Unreachable -> ind $ text "unreachable" - Nop -> empty - MetaStmt meta s -> ppMetaStatement opts meta s + Nop -> line empty +{-# SPECIALIZE ppLlvmStatement :: LlvmCgConfig -> LlvmStatement -> SDoc #-} +{-# SPECIALIZE ppLlvmStatement :: LlvmCgConfig -> LlvmStatement -> HDoc #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable -- | Print out an LLVM expression. -ppLlvmExpression :: LlvmCgConfig -> LlvmExpression -> SDoc +ppLlvmExpression :: IsLine doc => LlvmCgConfig -> LlvmExpression -> doc ppLlvmExpression opts expr = case expr of Alloca tp amount -> ppAlloca opts tp amount @@ -242,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 @@ -251,14 +291,19 @@ Phi tp predecessors -> ppPhi opts tp predecessors Asm asm c ty v se sk -> ppAsm opts asm c ty v se sk MExpr meta expr -> ppMetaAnnotExpr opts meta expr +{-# SPECIALIZE ppLlvmExpression :: LlvmCgConfig -> LlvmExpression -> SDoc #-} +{-# SPECIALIZE ppLlvmExpression :: LlvmCgConfig -> LlvmExpression -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable -ppMetaExpr :: LlvmCgConfig -> MetaExpr -> SDoc +ppMetaExpr :: IsLine doc => LlvmCgConfig -> MetaExpr -> doc ppMetaExpr opts = \case MetaVar (LMLitVar (LMNullLit _)) -> text "null" MetaStr s -> char '!' <> doubleQuotes (ftext s) - MetaNode n -> ppr n + MetaLit l -> ppTypeLit opts l + MetaNode n -> ppMetaId n MetaVar v -> ppVar opts v - MetaStruct es -> char '!' <> braces (ppCommaJoin (map (ppMetaExpr opts) es)) + MetaStruct es -> char '!' <> braces (ppCommaJoin (ppMetaExpr opts) es) +{-# SPECIALIZE ppMetaExpr :: LlvmCgConfig -> MetaExpr -> SDoc #-} +{-# SPECIALIZE ppMetaExpr :: LlvmCgConfig -> MetaExpr -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable -------------------------------------------------------------------------------- @@ -267,7 +312,8 @@ -- | Should always be a function pointer. So a global var of function type -- (since globals are always pointers) or a local var of pointer function type. -ppCall :: LlvmCgConfig -> LlvmCallType -> LlvmVar -> [MetaExpr] -> [LlvmFuncAttr] -> SDoc +ppCall :: forall doc. IsLine doc => LlvmCgConfig -> LlvmCallType -> LlvmVar -> [MetaExpr] + -> [LlvmFuncAttr] -> doc ppCall opts ct fptr args attrs = case fptr of -- -- if local var function pointer, unwrap @@ -285,32 +331,36 @@ ppCall' (LlvmFunctionDecl _ _ cc ret argTy params _) = let tc = if ct == TailCall then text "tail " else empty ppValues = ppCallParams opts (map snd params) args - ppArgTy = (ppCommaJoin $ map (ppr . fst) params) <> + ppArgTy = ppCommaJoin (ppLlvmType . fst) params <> (case argTy of VarArgs -> text ", ..." FixedArgs -> empty) fnty = space <> lparen <> ppArgTy <> rparen - attrDoc = ppSpaceJoin attrs - in tc <> text "call" <+> ppr cc <+> ppr ret + attrDoc = ppSpaceJoin ppLlvmFuncAttr attrs + in tc <> text "call" <+> ppLlvmCallConvention cc <+> ppLlvmType ret <> fnty <+> ppName opts fptr <> lparen <+> ppValues <+> rparen <+> attrDoc - ppCallParams :: LlvmCgConfig -> [[LlvmParamAttr]] -> [MetaExpr] -> SDoc + ppCallParams :: LlvmCgConfig -> [[LlvmParamAttr]] -> [MetaExpr] -> doc ppCallParams opts attrs args = hsep $ punctuate comma $ zipWith ppCallMetaExpr attrs args where -- Metadata needs to be marked as having the `metadata` type when used -- in a call argument ppCallMetaExpr attrs (MetaVar v) = ppVar' attrs opts v ppCallMetaExpr _ v = text "metadata" <+> ppMetaExpr opts v +{-# SPECIALIZE ppCall :: LlvmCgConfig -> LlvmCallType -> LlvmVar -> [MetaExpr] -> [LlvmFuncAttr] -> SDoc #-} +{-# SPECIALIZE ppCall :: LlvmCgConfig -> LlvmCallType -> LlvmVar -> [MetaExpr] -> [LlvmFuncAttr] -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable -ppMachOp :: LlvmCgConfig -> LlvmMachOp -> LlvmVar -> LlvmVar -> SDoc +ppMachOp :: IsLine doc => LlvmCgConfig -> LlvmMachOp -> LlvmVar -> LlvmVar -> doc ppMachOp opts op left right = - (ppr op) <+> (ppr (getVarType left)) <+> ppName opts left + ppLlvmMachOp op <+> ppLlvmType (getVarType left) <+> ppName opts left <> comma <+> ppName opts right +{-# SPECIALIZE ppMachOp :: LlvmCgConfig -> LlvmMachOp -> LlvmVar -> LlvmVar -> SDoc #-} +{-# SPECIALIZE ppMachOp :: LlvmCgConfig -> LlvmMachOp -> LlvmVar -> LlvmVar -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable -ppCmpOp :: LlvmCgConfig -> LlvmCmpOp -> LlvmVar -> LlvmVar -> SDoc +ppCmpOp :: IsLine doc => LlvmCgConfig -> LlvmCmpOp -> LlvmVar -> LlvmVar -> doc ppCmpOp opts op left right = let cmpOp | isInt (getVarType left) && isInt (getVarType right) = text "icmp" @@ -321,28 +371,35 @@ ++ (show $ getVarType left) ++ ", right = " ++ (show $ getVarType right)) -} - in cmpOp <+> ppr op <+> ppr (getVarType left) + in cmpOp <+> ppLlvmCmpOp op <+> ppLlvmType (getVarType left) <+> ppName opts left <> comma <+> ppName opts right - +{-# SPECIALIZE ppCmpOp :: LlvmCgConfig -> LlvmCmpOp -> LlvmVar -> LlvmVar -> SDoc #-} +{-# SPECIALIZE ppCmpOp :: LlvmCgConfig -> LlvmCmpOp -> LlvmVar -> LlvmVar -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable -ppAssignment :: LlvmCgConfig -> LlvmVar -> SDoc -> SDoc +ppAssignment :: IsLine doc => LlvmCgConfig -> LlvmVar -> doc -> doc ppAssignment opts var expr = ppName opts var <+> equals <+> expr +{-# SPECIALIZE ppAssignment :: LlvmCgConfig -> LlvmVar -> SDoc -> SDoc #-} +{-# SPECIALIZE ppAssignment :: LlvmCgConfig -> LlvmVar -> HLine -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable -ppFence :: Bool -> LlvmSyncOrdering -> SDoc +ppFence :: IsLine doc => Bool -> LlvmSyncOrdering -> doc ppFence st ord = let singleThread = case st of True -> text "singlethread" False -> empty in text "fence" <+> singleThread <+> ppSyncOrdering ord +{-# SPECIALIZE ppFence :: Bool -> LlvmSyncOrdering -> SDoc #-} +{-# SPECIALIZE ppFence :: Bool -> LlvmSyncOrdering -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable -ppSyncOrdering :: LlvmSyncOrdering -> SDoc +ppSyncOrdering :: IsLine doc => LlvmSyncOrdering -> doc ppSyncOrdering SyncUnord = text "unordered" ppSyncOrdering SyncMonotonic = text "monotonic" ppSyncOrdering SyncAcquire = text "acquire" ppSyncOrdering SyncRelease = text "release" ppSyncOrdering SyncAcqRel = text "acq_rel" ppSyncOrdering SyncSeqCst = text "seq_cst" +{-# SPECIALIZE ppSyncOrdering :: LlvmSyncOrdering -> SDoc #-} +{-# SPECIALIZE ppSyncOrdering :: LlvmSyncOrdering -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable -ppAtomicOp :: LlvmAtomicOp -> SDoc +ppAtomicOp :: IsLine doc => LlvmAtomicOp -> doc ppAtomicOp LAO_Xchg = text "xchg" ppAtomicOp LAO_Add = text "add" ppAtomicOp LAO_Sub = text "sub" @@ -354,184 +411,231 @@ ppAtomicOp LAO_Min = text "min" ppAtomicOp LAO_Umax = text "umax" ppAtomicOp LAO_Umin = text "umin" +{-# SPECIALIZE ppAtomicOp :: LlvmAtomicOp -> SDoc #-} +{-# SPECIALIZE ppAtomicOp :: LlvmAtomicOp -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable -ppAtomicRMW :: LlvmCgConfig -> LlvmAtomicOp -> LlvmVar -> LlvmVar -> LlvmSyncOrdering -> SDoc +ppAtomicRMW :: IsLine doc => LlvmCgConfig -> LlvmAtomicOp -> LlvmVar -> LlvmVar -> LlvmSyncOrdering -> doc ppAtomicRMW opts aop tgt src ordering = text "atomicrmw" <+> ppAtomicOp aop <+> ppVar opts tgt <> comma <+> ppVar opts src <+> ppSyncOrdering ordering +{-# SPECIALIZE ppAtomicRMW :: LlvmCgConfig -> LlvmAtomicOp -> LlvmVar -> LlvmVar -> LlvmSyncOrdering -> SDoc #-} +{-# SPECIALIZE ppAtomicRMW :: LlvmCgConfig -> LlvmAtomicOp -> LlvmVar -> LlvmVar -> LlvmSyncOrdering -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable -ppCmpXChg :: LlvmCgConfig -> LlvmVar -> LlvmVar -> LlvmVar - -> LlvmSyncOrdering -> LlvmSyncOrdering -> SDoc +ppCmpXChg :: IsLine doc => LlvmCgConfig -> LlvmVar -> LlvmVar -> LlvmVar + -> LlvmSyncOrdering -> LlvmSyncOrdering -> doc ppCmpXChg opts addr old new s_ord f_ord = text "cmpxchg" <+> ppVar opts addr <> comma <+> ppVar opts old <> comma <+> ppVar opts new <+> ppSyncOrdering s_ord <+> ppSyncOrdering f_ord +{-# SPECIALIZE ppCmpXChg :: LlvmCgConfig -> LlvmVar -> LlvmVar -> LlvmVar -> LlvmSyncOrdering -> LlvmSyncOrdering -> SDoc #-} +{-# SPECIALIZE ppCmpXChg :: LlvmCgConfig -> LlvmVar -> LlvmVar -> LlvmVar -> LlvmSyncOrdering -> LlvmSyncOrdering -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable -ppLoad :: LlvmCgConfig -> LlvmVar -> LMAlign -> SDoc +ppLoad :: IsLine doc => LlvmCgConfig -> LlvmVar -> LMAlign -> doc ppLoad opts var alignment = - text "load" <+> ppr derefType <> comma <+> ppVar opts var <> align + text "load" <+> ppLlvmType derefType <> comma <+> ppVar opts var <> align where derefType = pLower $ getVarType var align = case alignment of - Just n -> text ", align" <+> ppr n + Just n -> text ", align" <+> int n Nothing -> empty +{-# SPECIALIZE ppLoad :: LlvmCgConfig -> LlvmVar -> LMAlign -> SDoc #-} +{-# SPECIALIZE ppLoad :: LlvmCgConfig -> LlvmVar -> LMAlign -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable -ppALoad :: LlvmCgConfig -> LlvmSyncOrdering -> SingleThreaded -> LlvmVar -> SDoc +ppALoad :: IsLine doc => LlvmCgConfig -> LlvmSyncOrdering -> SingleThreaded -> LlvmVar -> doc ppALoad opts ord st var = let alignment = llvmWidthInBits (llvmCgPlatform opts) (getVarType var) `quot` 8 - align = text ", align" <+> ppr alignment + align = text ", align" <+> int alignment sThreaded | st = text " singlethread" | otherwise = empty derefType = pLower $ getVarType var - in text "load atomic" <+> ppr derefType <> comma <+> ppVar opts var <> sThreaded + in text "load atomic" <+> ppLlvmType derefType <> comma <+> ppVar opts var <> sThreaded <+> ppSyncOrdering ord <> align +{-# SPECIALIZE ppALoad :: LlvmCgConfig -> LlvmSyncOrdering -> SingleThreaded -> LlvmVar -> SDoc #-} +{-# SPECIALIZE ppALoad :: LlvmCgConfig -> LlvmSyncOrdering -> SingleThreaded -> LlvmVar -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable -ppStore :: LlvmCgConfig -> LlvmVar -> LlvmVar -> LMAlign -> SDoc -ppStore opts val dst alignment = - text "store" <+> ppVar opts val <> comma <+> ppVar opts dst <> align +ppStore :: IsLine doc => LlvmCgConfig -> LlvmVar -> LlvmVar -> LMAlign -> [MetaAnnot] -> doc +ppStore opts val dst alignment metas = + text "store" <+> ppVar opts val <> comma <+> ppVar opts dst <> align <+> ppMetaAnnots opts metas where align = case alignment of - Just n -> text ", align" <+> ppr n + Just n -> text ", align" <+> int n Nothing -> empty +{-# SPECIALIZE ppStore :: LlvmCgConfig -> LlvmVar -> LlvmVar -> LMAlign -> [MetaAnnot] -> SDoc #-} +{-# SPECIALIZE ppStore :: LlvmCgConfig -> LlvmVar -> LlvmVar -> LMAlign -> [MetaAnnot] -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable -ppCast :: LlvmCgConfig -> LlvmCastOp -> LlvmVar -> LlvmType -> SDoc +ppCast :: IsLine doc => LlvmCgConfig -> LlvmCastOp -> LlvmVar -> LlvmType -> doc ppCast opts op from to - = ppr op - <+> ppr (getVarType from) <+> ppName opts from + = ppLlvmCastOp op + <+> ppLlvmType (getVarType from) <+> ppName opts from <+> text "to" - <+> ppr to + <+> ppLlvmType to +{-# SPECIALIZE ppCast :: LlvmCgConfig -> LlvmCastOp -> LlvmVar -> LlvmType -> SDoc #-} +{-# SPECIALIZE ppCast :: LlvmCgConfig -> LlvmCastOp -> LlvmVar -> LlvmType -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable -ppMalloc :: LlvmCgConfig -> LlvmType -> Int -> SDoc +ppMalloc :: IsLine doc => LlvmCgConfig -> LlvmType -> Int -> doc ppMalloc opts tp amount = let amount' = LMLitVar $ LMIntLit (toInteger amount) i32 - in text "malloc" <+> ppr tp <> comma <+> ppVar opts amount' - + in text "malloc" <+> ppLlvmType tp <> comma <+> ppVar opts amount' +{-# SPECIALIZE ppMalloc :: LlvmCgConfig -> LlvmType -> Int -> SDoc #-} +{-# SPECIALIZE ppMalloc :: LlvmCgConfig -> LlvmType -> Int -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable -ppAlloca :: LlvmCgConfig -> LlvmType -> Int -> SDoc +ppAlloca :: IsLine doc => LlvmCgConfig -> LlvmType -> Int -> doc ppAlloca opts tp amount = let amount' = LMLitVar $ LMIntLit (toInteger amount) i32 - in text "alloca" <+> ppr tp <> comma <+> ppVar opts amount' - + in text "alloca" <+> ppLlvmType tp <> comma <+> ppVar opts amount' +{-# SPECIALIZE ppAlloca :: LlvmCgConfig -> LlvmType -> Int -> SDoc #-} +{-# SPECIALIZE ppAlloca :: LlvmCgConfig -> LlvmType -> Int -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable -ppGetElementPtr :: LlvmCgConfig -> Bool -> LlvmVar -> [LlvmVar] -> SDoc +ppGetElementPtr :: IsLine doc => LlvmCgConfig -> Bool -> LlvmVar -> [LlvmVar] -> doc ppGetElementPtr opts inb ptr idx = - let indexes = comma <+> ppCommaJoin (map (ppVar opts) idx) + let indexes = comma <+> ppCommaJoin (ppVar opts) idx inbound = if inb then text "inbounds" else empty derefType = pLower $ getVarType ptr - in text "getelementptr" <+> inbound <+> ppr derefType <> comma <+> ppVar opts ptr + in text "getelementptr" <+> inbound <+> ppLlvmType derefType <> comma <+> ppVar opts ptr <> indexes +{-# SPECIALIZE ppGetElementPtr :: LlvmCgConfig -> Bool -> LlvmVar -> [LlvmVar] -> SDoc #-} +{-# SPECIALIZE ppGetElementPtr :: LlvmCgConfig -> Bool -> LlvmVar -> [LlvmVar] -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable -ppReturn :: LlvmCgConfig -> Maybe LlvmVar -> SDoc +ppReturn :: IsLine doc => LlvmCgConfig -> Maybe LlvmVar -> doc ppReturn opts (Just var) = text "ret" <+> ppVar opts var -ppReturn _ Nothing = text "ret" <+> ppr LMVoid - +ppReturn _ Nothing = text "ret" <+> ppLlvmType LMVoid +{-# SPECIALIZE ppReturn :: LlvmCgConfig -> Maybe LlvmVar -> SDoc #-} +{-# SPECIALIZE ppReturn :: LlvmCgConfig -> Maybe LlvmVar -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable -ppBranch :: LlvmCgConfig -> LlvmVar -> SDoc +ppBranch :: IsLine doc => LlvmCgConfig -> LlvmVar -> doc ppBranch opts var = text "br" <+> ppVar opts var +{-# SPECIALIZE ppBranch :: LlvmCgConfig -> LlvmVar -> SDoc #-} +{-# SPECIALIZE ppBranch :: LlvmCgConfig -> LlvmVar -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable -ppBranchIf :: LlvmCgConfig -> LlvmVar -> LlvmVar -> LlvmVar -> SDoc +ppBranchIf :: IsLine doc => LlvmCgConfig -> LlvmVar -> LlvmVar -> LlvmVar -> doc ppBranchIf opts cond trueT falseT = text "br" <+> ppVar opts cond <> comma <+> ppVar opts trueT <> comma <+> ppVar opts falseT +{-# SPECIALIZE ppBranchIf :: LlvmCgConfig -> LlvmVar -> LlvmVar -> LlvmVar -> SDoc #-} +{-# SPECIALIZE ppBranchIf :: LlvmCgConfig -> LlvmVar -> LlvmVar -> LlvmVar -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable -ppPhi :: LlvmCgConfig -> LlvmType -> [(LlvmVar,LlvmVar)] -> SDoc +ppPhi :: IsLine doc => LlvmCgConfig -> LlvmType -> [(LlvmVar,LlvmVar)] -> doc ppPhi opts tp preds = let ppPreds (val, label) = brackets $ ppName opts val <> comma <+> ppName opts label - in text "phi" <+> ppr tp <+> hsep (punctuate comma $ map ppPreds preds) + in text "phi" <+> ppLlvmType tp <+> hsep (punctuate comma $ map ppPreds preds) +{-# SPECIALIZE ppPhi :: LlvmCgConfig -> LlvmType -> [(LlvmVar,LlvmVar)] -> SDoc #-} +{-# SPECIALIZE ppPhi :: LlvmCgConfig -> LlvmType -> [(LlvmVar,LlvmVar)] -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable -ppSwitch :: LlvmCgConfig -> LlvmVar -> LlvmVar -> [(LlvmVar,LlvmVar)] -> SDoc +ppSwitch :: IsDoc doc => LlvmCgConfig -> LlvmVar -> LlvmVar -> [(LlvmVar,LlvmVar)] -> doc ppSwitch opts scrut dflt targets = - let ppTarget (val, lab) = ppVar opts val <> comma <+> ppVar opts lab - ppTargets xs = brackets $ vcat (map ppTarget xs) - in text "switch" <+> ppVar opts scrut <> comma <+> ppVar opts dflt - <+> ppTargets targets + let ppTarget (val, lab) = text " " <> ppVar opts val <> comma <+> ppVar opts lab + in lines_ $ concat + [ [text "switch" <+> ppVar opts scrut <> comma <+> ppVar opts dflt <+> char '['] + , map ppTarget targets + , [char ']'] + ] +{-# SPECIALIZE ppSwitch :: LlvmCgConfig -> LlvmVar -> LlvmVar -> [(LlvmVar,LlvmVar)] -> SDoc #-} +{-# SPECIALIZE ppSwitch :: LlvmCgConfig -> LlvmVar -> LlvmVar -> [(LlvmVar,LlvmVar)] -> HDoc #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable -ppAsm :: LlvmCgConfig -> LMString -> LMString -> LlvmType -> [LlvmVar] -> Bool -> Bool -> SDoc +ppAsm :: IsLine doc => LlvmCgConfig -> LMString -> LMString -> LlvmType -> [LlvmVar] -> Bool -> Bool -> doc ppAsm opts asm constraints rty vars sideeffect alignstack = let asm' = doubleQuotes $ ftext asm cons = doubleQuotes $ ftext constraints - rty' = ppr rty - vars' = lparen <+> ppCommaJoin (map (ppVar opts) vars) <+> rparen + rty' = ppLlvmType rty + vars' = lparen <+> ppCommaJoin (ppVar opts) vars <+> rparen side = if sideeffect then text "sideeffect" else empty align = if alignstack then text "alignstack" else empty in text "call" <+> rty' <+> text "asm" <+> side <+> align <+> asm' <> comma <+> cons <> vars' +{-# SPECIALIZE ppAsm :: LlvmCgConfig -> LMString -> LMString -> LlvmType -> [LlvmVar] -> Bool -> Bool -> SDoc #-} +{-# SPECIALIZE ppAsm :: LlvmCgConfig -> LMString -> LMString -> LlvmType -> [LlvmVar] -> Bool -> Bool -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable -ppExtract :: LlvmCgConfig -> LlvmVar -> LlvmVar -> SDoc +ppExtract :: IsLine doc => LlvmCgConfig -> LlvmVar -> LlvmVar -> doc ppExtract opts vec idx = text "extractelement" - <+> ppr (getVarType vec) <+> ppName opts vec <> comma + <+> ppLlvmType (getVarType vec) <+> ppName opts vec <> comma <+> ppVar opts idx +{-# SPECIALIZE ppExtract :: LlvmCgConfig -> LlvmVar -> LlvmVar -> SDoc #-} +{-# SPECIALIZE ppExtract :: LlvmCgConfig -> LlvmVar -> LlvmVar -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable -ppExtractV :: LlvmCgConfig -> LlvmVar -> Int -> SDoc +ppExtractV :: IsLine doc => LlvmCgConfig -> LlvmVar -> Int -> doc ppExtractV opts struct idx = text "extractvalue" - <+> ppr (getVarType struct) <+> ppName opts struct <> comma - <+> ppr idx + <+> ppLlvmType (getVarType struct) <+> ppName opts struct <> comma + <+> int idx +{-# SPECIALIZE ppExtractV :: LlvmCgConfig -> LlvmVar -> Int -> SDoc #-} +{-# SPECIALIZE ppExtractV :: LlvmCgConfig -> LlvmVar -> Int -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable -ppInsert :: LlvmCgConfig -> LlvmVar -> LlvmVar -> LlvmVar -> SDoc +ppInsert :: IsLine doc => LlvmCgConfig -> LlvmVar -> LlvmVar -> LlvmVar -> doc ppInsert opts vec elt idx = text "insertelement" - <+> ppr (getVarType vec) <+> ppName opts vec <> comma - <+> ppr (getVarType elt) <+> ppName opts elt <> comma + <+> ppLlvmType (getVarType vec) <+> ppName opts vec <> comma + <+> ppLlvmType (getVarType elt) <+> ppName opts elt <> comma <+> ppVar opts idx - +{-# SPECIALIZE ppInsert :: LlvmCgConfig -> LlvmVar -> LlvmVar -> LlvmVar -> SDoc #-} +{-# SPECIALIZE ppInsert :: LlvmCgConfig -> LlvmVar -> LlvmVar -> LlvmVar -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable -ppMetaStatement :: LlvmCgConfig -> [MetaAnnot] -> LlvmStatement -> SDoc -ppMetaStatement opts meta stmt = - ppLlvmStatement opts stmt <> ppMetaAnnots opts meta +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 :: LlvmCgConfig -> [MetaAnnot] -> LlvmExpression -> SDoc +ppMetaAnnotExpr :: IsLine doc => LlvmCgConfig -> [MetaAnnot] -> LlvmExpression -> doc ppMetaAnnotExpr opts meta expr = ppLlvmExpression opts expr <> ppMetaAnnots opts meta +{-# SPECIALIZE ppMetaAnnotExpr :: LlvmCgConfig -> [MetaAnnot] -> LlvmExpression -> SDoc #-} +{-# SPECIALIZE ppMetaAnnotExpr :: LlvmCgConfig -> [MetaAnnot] -> LlvmExpression -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable -ppMetaAnnots :: LlvmCgConfig -> [MetaAnnot] -> SDoc +ppMetaAnnots :: IsLine doc => LlvmCgConfig -> [MetaAnnot] -> doc ppMetaAnnots opts meta = hcat $ map ppMeta meta where ppMeta (MetaAnnot name e) = comma <+> exclamation <> ftext name <+> case e of - MetaNode n -> ppr n - MetaStruct ms -> exclamation <> braces (ppCommaJoin (map (ppMetaExpr opts) ms)) + MetaNode n -> ppMetaId n + MetaStruct ms -> exclamation <> braces (ppCommaJoin (ppMetaExpr opts) ms) other -> exclamation <> braces (ppMetaExpr opts other) -- possible? +{-# SPECIALIZE ppMetaAnnots :: LlvmCgConfig -> [MetaAnnot] -> SDoc #-} +{-# SPECIALIZE ppMetaAnnots :: LlvmCgConfig -> [MetaAnnot] -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable -- | Return the variable name or value of the 'LlvmVar' -- in Llvm IR textual representation (e.g. @\@x@, @%y@ or @42@). -ppName :: LlvmCgConfig -> LlvmVar -> SDoc +ppName :: IsLine doc => LlvmCgConfig -> LlvmVar -> doc ppName opts v = case v of LMGlobalVar {} -> char '@' <> ppPlainName opts v LMLocalVar {} -> char '%' <> ppPlainName opts v LMNLocalVar {} -> char '%' <> ppPlainName opts v LMLitVar {} -> ppPlainName opts v +{-# SPECIALIZE ppName :: LlvmCgConfig -> LlvmVar -> SDoc #-} +{-# SPECIALIZE ppName :: LlvmCgConfig -> LlvmVar -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable -- | Return the variable name or value of the 'LlvmVar' -- in a plain textual representation (e.g. @x@, @y@ or @42@). -ppPlainName :: LlvmCgConfig -> LlvmVar -> SDoc +ppPlainName :: IsLine doc => LlvmCgConfig -> LlvmVar -> doc ppPlainName opts v = case v of (LMGlobalVar x _ _ _ _ _) -> ftext x (LMLocalVar x LMLabel ) -> pprUniqueAlways x (LMLocalVar x _ ) -> char 'l' <> pprUniqueAlways x (LMNLocalVar x _ ) -> ftext x (LMLitVar x ) -> ppLit opts x +{-# SPECIALIZE ppPlainName :: LlvmCgConfig -> LlvmVar -> SDoc #-} +{-# SPECIALIZE ppPlainName :: LlvmCgConfig -> LlvmVar -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable -- | Print a literal value. No type. -ppLit :: LlvmCgConfig -> LlvmLit -> SDoc +ppLit :: IsLine doc => LlvmCgConfig -> LlvmLit -> doc ppLit opts l = case l of - (LMIntLit i (LMInt 32)) -> ppr (fromInteger i :: Int32) - (LMIntLit i (LMInt 64)) -> ppr (fromInteger i :: Int64) - (LMIntLit i _ ) -> ppr ((fromInteger i)::Int) + (LMIntLit i _ ) -> integer i (LMFloatLit r LMFloat ) -> ppFloat (llvmCgPlatform opts) $ narrowFp r (LMFloatLit r LMDouble) -> ppDouble (llvmCgPlatform opts) r f@(LMFloatLit _ _) -> pprPanic "ppLit" (text "Can't print this float literal: " <> ppTypeLit opts f) - (LMVectorLit ls ) -> char '<' <+> ppCommaJoin (map (ppTypeLit opts) ls) <+> char '>' + (LMVectorLit ls ) -> char '<' <+> ppCommaJoin (ppTypeLit opts) ls <+> char '>' (LMNullLit _ ) -> text "null" -- #11487 was an issue where we passed undef for some arguments -- that were actually live. By chance the registers holding those @@ -544,61 +648,74 @@ | llvmCgFillUndefWithGarbage opts , Just lit <- garbageLit t -> ppLit opts lit | otherwise -> text "undef" +{-# SPECIALIZE ppLit :: LlvmCgConfig -> LlvmLit -> SDoc #-} +{-# SPECIALIZE ppLit :: LlvmCgConfig -> LlvmLit -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable -ppVar :: LlvmCgConfig -> LlvmVar -> SDoc +ppVar :: IsLine doc => LlvmCgConfig -> LlvmVar -> doc ppVar = ppVar' [] +{-# SPECIALIZE ppVar :: LlvmCgConfig -> LlvmVar -> SDoc #-} +{-# SPECIALIZE ppVar :: LlvmCgConfig -> LlvmVar -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable -ppVar' :: [LlvmParamAttr] -> LlvmCgConfig -> LlvmVar -> SDoc +ppVar' :: IsLine doc => [LlvmParamAttr] -> LlvmCgConfig -> LlvmVar -> doc ppVar' attrs opts v = case v of LMLitVar x -> ppTypeLit' attrs opts x - x -> ppr (getVarType x) <+> ppSpaceJoin attrs <+> ppName opts x + x -> ppLlvmType (getVarType x) <+> ppSpaceJoin ppLlvmParamAttr attrs <+> ppName opts x +{-# SPECIALIZE ppVar' :: [LlvmParamAttr] -> LlvmCgConfig -> LlvmVar -> SDoc #-} +{-# SPECIALIZE ppVar' :: [LlvmParamAttr] -> LlvmCgConfig -> LlvmVar -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable -ppTypeLit :: LlvmCgConfig -> LlvmLit -> SDoc +ppTypeLit :: IsLine doc => LlvmCgConfig -> LlvmLit -> doc ppTypeLit = ppTypeLit' [] +{-# SPECIALIZE ppTypeLit :: LlvmCgConfig -> LlvmLit -> SDoc #-} +{-# SPECIALIZE ppTypeLit :: LlvmCgConfig -> LlvmLit -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable -ppTypeLit' :: [LlvmParamAttr] -> LlvmCgConfig -> LlvmLit -> SDoc -ppTypeLit' attrs opts l = case l of - LMVectorLit {} -> ppLit opts l - _ -> ppr (getLitType l) <+> ppSpaceJoin attrs <+> ppLit opts l +ppTypeLit' :: IsLine doc => [LlvmParamAttr] -> LlvmCgConfig -> LlvmLit -> doc +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 -ppStatic :: LlvmCgConfig -> LlvmStatic -> SDoc +ppStatic :: IsLine doc => LlvmCgConfig -> LlvmStatic -> doc ppStatic opts st = case st of LMComment s -> text "; " <> ftext s LMStaticLit l -> ppTypeLit opts l - LMUninitType t -> ppr t <> text " undef" - LMStaticStr s t -> ppr t <> text " c\"" <> ftext s <> text "\\00\"" - LMStaticArray d t -> ppr t <> text " [" <> ppCommaJoin (map (ppStatic opts) d) <> char ']' - LMStaticStruc d t -> ppr t <> text "<{" <> ppCommaJoin (map (ppStatic opts) d) <> text "}>" - LMStaticStrucU d t -> ppr t <> text "{" <> ppCommaJoin (map (ppStatic opts) d) <> text "}" + LMUninitType t -> ppLlvmType t <> text " undef" + LMStaticStr s t -> ppLlvmType t <> text " c\"" <> ftext s <> text "\\00\"" + LMStaticArray d t -> ppLlvmType t <> text " [" <> ppCommaJoin (ppStatic opts) d <> char ']' + LMStaticStruc d t -> ppLlvmType t <> text "<{" <> ppCommaJoin (ppStatic opts) d <> text "}>" + LMStaticStrucU d t -> ppLlvmType t <> text "{" <> ppCommaJoin (ppStatic opts) d <> text "}" LMStaticPointer v -> ppVar opts v - LMTrunc v t -> ppr t <> text " trunc (" <> ppStatic opts v <> text " to " <> ppr t <> char ')' - LMBitc v t -> ppr t <> text " bitcast (" <> ppStatic opts v <> text " to " <> ppr t <> char ')' - LMPtoI v t -> ppr t <> text " ptrtoint (" <> ppStatic opts v <> text " to " <> ppr t <> char ')' + LMTrunc v t -> ppLlvmType t <> text " trunc (" <> ppStatic opts v <> text " to " <> ppLlvmType t <> char ')' + LMBitc v t -> ppLlvmType t <> text " bitcast (" <> ppStatic opts v <> text " to " <> ppLlvmType t <> char ')' + LMPtoI v t -> ppLlvmType t <> text " ptrtoint (" <> ppStatic opts v <> text " to " <> ppLlvmType t <> char ')' LMAdd s1 s2 -> pprStaticArith opts s1 s2 (text "add") (text "fadd") (text "LMAdd") LMSub s1 s2 -> pprStaticArith opts s1 s2 (text "sub") (text "fsub") (text "LMSub") +{-# SPECIALIZE ppStatic :: LlvmCgConfig -> LlvmStatic -> SDoc #-} +{-# SPECIALIZE ppStatic :: LlvmCgConfig -> LlvmStatic -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable -pprSpecialStatic :: LlvmCgConfig -> LlvmStatic -> SDoc +pprSpecialStatic :: IsLine doc => LlvmCgConfig -> LlvmStatic -> doc pprSpecialStatic opts stat = case stat of - LMBitc v t -> ppr (pLower t) + LMBitc v t -> ppLlvmType (pLower t) <> text ", bitcast (" - <> ppStatic opts v <> text " to " <> ppr t + <> ppStatic opts v <> text " to " <> ppLlvmType t <> char ')' - LMStaticPointer x -> ppr (pLower $ getVarType x) + LMStaticPointer x -> ppLlvmType (pLower $ getVarType x) <> comma <+> ppStatic opts stat _ -> ppStatic opts stat +{-# SPECIALIZE pprSpecialStatic :: LlvmCgConfig -> LlvmStatic -> SDoc #-} +{-# SPECIALIZE pprSpecialStatic :: LlvmCgConfig -> LlvmStatic -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable -pprStaticArith :: LlvmCgConfig -> LlvmStatic -> LlvmStatic -> SDoc -> SDoc - -> SDoc -> SDoc +pprStaticArith :: IsLine doc => LlvmCgConfig -> LlvmStatic -> LlvmStatic -> doc -> doc -> SDoc -> doc pprStaticArith opts s1 s2 int_op float_op op_name = let ty1 = getStatType s1 op = if isFloat ty1 then float_op else int_op in if ty1 == getStatType s2 - then ppr ty1 <+> op <+> lparen <> ppStatic opts s1 <> comma <> ppStatic opts s2 <> rparen + then ppLlvmType ty1 <+> op <+> lparen <> ppStatic opts s1 <> comma <> ppStatic opts s2 <> rparen else pprPanic "pprStaticArith" $ op_name <> text " with different types! s1: " <> ppStatic opts s1 <> text", s2: " <> ppStatic opts s2 +{-# SPECIALIZE pprStaticArith :: LlvmCgConfig -> LlvmStatic -> LlvmStatic -> SDoc -> SDoc -> SDoc -> SDoc #-} +{-# SPECIALIZE pprStaticArith :: LlvmCgConfig -> LlvmStatic -> LlvmStatic -> HLine -> HLine -> SDoc -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable -------------------------------------------------------------------------------- @@ -606,9 +723,13 @@ -------------------------------------------------------------------------------- -- | Blank line. -newLine :: SDoc +newLine :: IsDoc doc => doc newLine = empty +{-# SPECIALIZE newLine :: SDoc #-} +{-# SPECIALIZE newLine :: HDoc #-} -- | Exclamation point. -exclamation :: SDoc +exclamation :: IsLine doc => doc exclamation = char '!' +{-# SPECIALIZE exclamation :: SDoc #-} +{-# SPECIALIZE exclamation :: HLine #-} diff --git a/GHC/Llvm/Syntax.hs b/GHC/Llvm/Syntax.hs --- a/GHC/Llvm/Syntax.hs +++ b/GHC/Llvm/Syntax.hs @@ -150,7 +150,7 @@ * value: Variable/Constant to store. * ptr: Location to store the value in -} - | Store LlvmVar LlvmVar LMAlign + | Store LlvmVar LlvmVar LMAlign [MetaAnnot] {- | Multiway branch @@ -186,11 +186,6 @@ -} | Nop - {- | - A LLVM statement with metadata attached to it. - -} - | MetaStmt [MetaAnnot] LlvmStatement - deriving (Eq) @@ -241,6 +236,10 @@ * index: The index at which to insert the scalar -} | 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 diff --git a/GHC/Llvm/Types.hs b/GHC/Llvm/Types.hs --- a/GHC/Llvm/Types.hs +++ b/GHC/Llvm/Types.hs @@ -1,6 +1,13 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE LambdaCase #-} +-- Workaround for #21972. It can be removed once the minimal bootstrapping +-- compiler has a fix for this bug. +#if defined(darwin_HOST_OS) +{-# OPTIONS_GHC -fno-asm-shortcutting #-} +#endif + -------------------------------------------------------------------------------- -- | The LLVM Type System. -- @@ -61,28 +68,39 @@ deriving (Eq) instance Outputable LlvmType where - ppr = ppType + ppr = ppLlvmType -ppType :: LlvmType -> SDoc -ppType t = case t of - LMInt size -> char 'i' <> ppr size +ppLlvmType :: IsLine doc => LlvmType -> doc +ppLlvmType t = case t of + LMInt size -> char 'i' <> int size LMFloat -> text "float" LMDouble -> text "double" LMFloat80 -> text "x86_fp80" LMFloat128 -> text "fp128" - LMPointer x -> ppr x <> char '*' - LMArray nr tp -> char '[' <> ppr nr <> text " x " <> ppr tp <> char ']' - LMVector nr tp -> char '<' <> ppr nr <> text " x " <> ppr tp <> char '>' + LMPointer x -> ppLlvmType x <> char '*' + LMArray nr tp -> char '[' <> int nr <> text " x " <> ppLlvmType tp <> char ']' + LMVector nr tp -> char '<' <> int nr <> text " x " <> ppLlvmType tp <> char '>' LMLabel -> text "label" LMVoid -> text "void" - LMStruct tys -> text "<{" <> ppCommaJoin tys <> text "}>" - LMStructU tys -> text "{" <> ppCommaJoin tys <> text "}" + LMStruct tys -> text "<{" <> ppCommaJoin ppLlvmType tys <> text "}>" + LMStructU tys -> text "{" <> ppCommaJoin ppLlvmType tys <> text "}" LMMetadata -> text "metadata" LMAlias (s,_) -> char '%' <> ftext s LMFunction (LlvmFunctionDecl _ _ _ r varg p _) - -> ppr r <+> lparen <> ppParams varg p <> rparen + -> ppLlvmType r <+> lparen <> ppParams varg p <> rparen +{-# SPECIALIZE ppLlvmType :: LlvmType -> SDoc #-} +{-# SPECIALIZE ppLlvmType :: LlvmType -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable -ppParams :: LlvmParameterListType -> [LlvmParameter] -> SDoc +-- | 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 VarArgs | null args -> text "..." @@ -90,7 +108,9 @@ _otherwise -> text "" -- by default we don't print param attributes args = map fst p - in ppCommaJoin args <> varg' + in ppCommaJoin ppLlvmType args <> varg' +{-# SPECIALIZE ppParams :: LlvmParameterListType -> [LlvmParameter] -> SDoc #-} +{-# SPECIALIZE ppParams :: LlvmParameterListType -> [LlvmParameter] -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable -- | An LLVM section definition. If Nothing then let LLVM decide the section type LMSection = Maybe LMString @@ -219,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. @@ -337,14 +357,6 @@ } deriving (Eq) -instance Outputable LlvmFunctionDecl where - ppr (LlvmFunctionDecl n l c r varg p a) - = let align = case a of - Just a' -> text " align " <> ppr a' - Nothing -> empty - in ppr l <+> ppr c <+> ppr r <+> char '@' <> ftext n <> - lparen <> ppParams varg p <> rparen <> align - type LlvmFunctionDecls = [LlvmFunctionDecl] type LlvmParameter = (LlvmType, [LlvmParamAttr]) @@ -385,15 +397,20 @@ deriving (Eq) instance Outputable LlvmParamAttr where - ppr ZeroExt = text "zeroext" - ppr SignExt = text "signext" - ppr InReg = text "inreg" - ppr ByVal = text "byval" - ppr SRet = text "sret" - ppr NoAlias = text "noalias" - ppr NoCapture = text "nocapture" - ppr Nest = text "nest" + ppr = ppLlvmParamAttr +ppLlvmParamAttr :: IsLine doc => LlvmParamAttr -> doc +ppLlvmParamAttr ZeroExt = text "zeroext" +ppLlvmParamAttr SignExt = text "signext" +ppLlvmParamAttr InReg = text "inreg" +ppLlvmParamAttr ByVal = text "byval" +ppLlvmParamAttr SRet = text "sret" +ppLlvmParamAttr NoAlias = text "noalias" +ppLlvmParamAttr NoCapture = text "nocapture" +ppLlvmParamAttr Nest = text "nest" +{-# SPECIALIZE ppLlvmParamAttr :: LlvmParamAttr -> SDoc #-} +{-# SPECIALIZE ppLlvmParamAttr :: LlvmParamAttr -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable + -- | Llvm Function Attributes. -- -- Function attributes are set to communicate additional information about a @@ -473,21 +490,26 @@ deriving (Eq) instance Outputable LlvmFuncAttr where - ppr AlwaysInline = text "alwaysinline" - ppr InlineHint = text "inlinehint" - ppr NoInline = text "noinline" - ppr OptSize = text "optsize" - ppr NoReturn = text "noreturn" - ppr NoUnwind = text "nounwind" - ppr ReadNone = text "readnone" - ppr ReadOnly = text "readonly" - ppr Ssp = text "ssp" - ppr SspReq = text "ssqreq" - ppr NoRedZone = text "noredzone" - ppr NoImplicitFloat = text "noimplicitfloat" - ppr Naked = text "naked" + ppr = ppLlvmFuncAttr +ppLlvmFuncAttr :: IsLine doc => LlvmFuncAttr -> doc +ppLlvmFuncAttr AlwaysInline = text "alwaysinline" +ppLlvmFuncAttr InlineHint = text "inlinehint" +ppLlvmFuncAttr NoInline = text "noinline" +ppLlvmFuncAttr OptSize = text "optsize" +ppLlvmFuncAttr NoReturn = text "noreturn" +ppLlvmFuncAttr NoUnwind = text "nounwind" +ppLlvmFuncAttr ReadNone = text "readnone" +ppLlvmFuncAttr ReadOnly = text "readonly" +ppLlvmFuncAttr Ssp = text "ssp" +ppLlvmFuncAttr SspReq = text "ssqreq" +ppLlvmFuncAttr NoRedZone = text "noredzone" +ppLlvmFuncAttr NoImplicitFloat = text "noimplicitfloat" +ppLlvmFuncAttr Naked = text "naked" +{-# SPECIALIZE ppLlvmFuncAttr :: LlvmFuncAttr -> SDoc #-} +{-# SPECIALIZE ppLlvmFuncAttr :: LlvmFuncAttr -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable + -- | Different types to call a function. data LlvmCallType -- | Normal call, allocate a new stack frame. @@ -533,14 +555,19 @@ deriving (Eq) instance Outputable LlvmCallConvention where - ppr CC_Ccc = text "ccc" - ppr CC_Fastcc = text "fastcc" - ppr CC_Coldcc = text "coldcc" - ppr CC_Ghc = text "ghccc" - ppr (CC_Ncc i) = text "cc " <> ppr i - ppr CC_X86_Stdcc = text "x86_stdcallcc" + ppr = ppLlvmCallConvention +ppLlvmCallConvention :: IsLine doc => LlvmCallConvention -> doc +ppLlvmCallConvention CC_Ccc = text "ccc" +ppLlvmCallConvention CC_Fastcc = text "fastcc" +ppLlvmCallConvention CC_Coldcc = text "coldcc" +ppLlvmCallConvention CC_Ghc = text "ghccc" +ppLlvmCallConvention (CC_Ncc i) = text "cc " <> int i +ppLlvmCallConvention CC_X86_Stdcc = text "x86_stdcallcc" +{-# SPECIALIZE ppLlvmCallConvention :: LlvmCallConvention -> SDoc #-} +{-# SPECIALIZE ppLlvmCallConvention :: LlvmCallConvention -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable + -- | Functions can have a fixed amount of parameters, or a variable amount. data LlvmParameterListType -- Fixed amount of arguments. @@ -597,18 +624,23 @@ deriving (Eq) instance Outputable LlvmLinkageType where - ppr Internal = text "internal" - ppr LinkOnce = text "linkonce" - ppr Weak = text "weak" - ppr Appending = text "appending" - ppr ExternWeak = text "extern_weak" - -- ExternallyVisible does not have a textual representation, it is - -- the linkage type a function resolves to if no other is specified - -- in Llvm. - ppr ExternallyVisible = empty - ppr External = text "external" - ppr Private = text "private" + ppr = ppLlvmLinkageType +ppLlvmLinkageType :: IsLine doc => LlvmLinkageType -> doc +ppLlvmLinkageType Internal = text "internal" +ppLlvmLinkageType LinkOnce = text "linkonce" +ppLlvmLinkageType Weak = text "weak" +ppLlvmLinkageType Appending = text "appending" +ppLlvmLinkageType ExternWeak = text "extern_weak" +-- ExternallyVisible does not have a textual representation, it is +-- the linkage type a function resolves to if no other is specified +-- in Llvm. +ppLlvmLinkageType ExternallyVisible = empty +ppLlvmLinkageType External = text "external" +ppLlvmLinkageType Private = text "private" +{-# SPECIALIZE ppLlvmLinkageType :: LlvmLinkageType -> SDoc #-} +{-# SPECIALIZE ppLlvmLinkageType :: LlvmLinkageType -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable + -- ----------------------------------------------------------------------------- -- * LLVM Operations -- @@ -645,26 +677,31 @@ deriving (Eq) instance Outputable LlvmMachOp where - ppr LM_MO_Add = text "add" - ppr LM_MO_Sub = text "sub" - ppr LM_MO_Mul = text "mul" - ppr LM_MO_UDiv = text "udiv" - ppr LM_MO_SDiv = text "sdiv" - ppr LM_MO_URem = text "urem" - ppr LM_MO_SRem = text "srem" - ppr LM_MO_FAdd = text "fadd" - ppr LM_MO_FSub = text "fsub" - ppr LM_MO_FMul = text "fmul" - ppr LM_MO_FDiv = text "fdiv" - ppr LM_MO_FRem = text "frem" - ppr LM_MO_Shl = text "shl" - ppr LM_MO_LShr = text "lshr" - ppr LM_MO_AShr = text "ashr" - ppr LM_MO_And = text "and" - ppr LM_MO_Or = text "or" - ppr LM_MO_Xor = text "xor" + ppr = ppLlvmMachOp +ppLlvmMachOp :: IsLine doc => LlvmMachOp -> doc +ppLlvmMachOp LM_MO_Add = text "add" +ppLlvmMachOp LM_MO_Sub = text "sub" +ppLlvmMachOp LM_MO_Mul = text "mul" +ppLlvmMachOp LM_MO_UDiv = text "udiv" +ppLlvmMachOp LM_MO_SDiv = text "sdiv" +ppLlvmMachOp LM_MO_URem = text "urem" +ppLlvmMachOp LM_MO_SRem = text "srem" +ppLlvmMachOp LM_MO_FAdd = text "fadd" +ppLlvmMachOp LM_MO_FSub = text "fsub" +ppLlvmMachOp LM_MO_FMul = text "fmul" +ppLlvmMachOp LM_MO_FDiv = text "fdiv" +ppLlvmMachOp LM_MO_FRem = text "frem" +ppLlvmMachOp LM_MO_Shl = text "shl" +ppLlvmMachOp LM_MO_LShr = text "lshr" +ppLlvmMachOp LM_MO_AShr = text "ashr" +ppLlvmMachOp LM_MO_And = text "and" +ppLlvmMachOp LM_MO_Or = text "or" +ppLlvmMachOp LM_MO_Xor = text "xor" +{-# SPECIALIZE ppLlvmMachOp :: LlvmMachOp -> SDoc #-} +{-# SPECIALIZE ppLlvmMachOp :: LlvmMachOp -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable + -- | Llvm compare operations. data LlvmCmpOp = LM_CMP_Eq -- ^ Equal (Signed and Unsigned) @@ -689,24 +726,29 @@ deriving (Eq) instance Outputable LlvmCmpOp where - ppr LM_CMP_Eq = text "eq" - ppr LM_CMP_Ne = text "ne" - ppr LM_CMP_Ugt = text "ugt" - ppr LM_CMP_Uge = text "uge" - ppr LM_CMP_Ult = text "ult" - ppr LM_CMP_Ule = text "ule" - ppr LM_CMP_Sgt = text "sgt" - ppr LM_CMP_Sge = text "sge" - ppr LM_CMP_Slt = text "slt" - ppr LM_CMP_Sle = text "sle" - ppr LM_CMP_Feq = text "oeq" - ppr LM_CMP_Fne = text "une" - ppr LM_CMP_Fgt = text "ogt" - ppr LM_CMP_Fge = text "oge" - ppr LM_CMP_Flt = text "olt" - ppr LM_CMP_Fle = text "ole" + ppr = ppLlvmCmpOp +ppLlvmCmpOp :: IsLine doc => LlvmCmpOp -> doc +ppLlvmCmpOp LM_CMP_Eq = text "eq" +ppLlvmCmpOp LM_CMP_Ne = text "ne" +ppLlvmCmpOp LM_CMP_Ugt = text "ugt" +ppLlvmCmpOp LM_CMP_Uge = text "uge" +ppLlvmCmpOp LM_CMP_Ult = text "ult" +ppLlvmCmpOp LM_CMP_Ule = text "ule" +ppLlvmCmpOp LM_CMP_Sgt = text "sgt" +ppLlvmCmpOp LM_CMP_Sge = text "sge" +ppLlvmCmpOp LM_CMP_Slt = text "slt" +ppLlvmCmpOp LM_CMP_Sle = text "sle" +ppLlvmCmpOp LM_CMP_Feq = text "oeq" +ppLlvmCmpOp LM_CMP_Fne = text "une" +ppLlvmCmpOp LM_CMP_Fgt = text "ogt" +ppLlvmCmpOp LM_CMP_Fge = text "oge" +ppLlvmCmpOp LM_CMP_Flt = text "olt" +ppLlvmCmpOp LM_CMP_Fle = text "ole" +{-# SPECIALIZE ppLlvmCmpOp :: LlvmCmpOp -> SDoc #-} +{-# SPECIALIZE ppLlvmCmpOp :: LlvmCmpOp -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable + -- | Llvm cast operations. data LlvmCastOp = LM_Trunc -- ^ Integer truncate @@ -724,19 +766,23 @@ deriving (Eq) instance Outputable LlvmCastOp where - ppr LM_Trunc = text "trunc" - ppr LM_Zext = text "zext" - ppr LM_Sext = text "sext" - ppr LM_Fptrunc = text "fptrunc" - ppr LM_Fpext = text "fpext" - ppr LM_Fptoui = text "fptoui" - ppr LM_Fptosi = text "fptosi" - ppr LM_Uitofp = text "uitofp" - ppr LM_Sitofp = text "sitofp" - ppr LM_Ptrtoint = text "ptrtoint" - ppr LM_Inttoptr = text "inttoptr" - ppr LM_Bitcast = text "bitcast" + ppr = ppLlvmCastOp +ppLlvmCastOp :: IsLine doc => LlvmCastOp -> doc +ppLlvmCastOp LM_Trunc = text "trunc" +ppLlvmCastOp LM_Zext = text "zext" +ppLlvmCastOp LM_Sext = text "sext" +ppLlvmCastOp LM_Fptrunc = text "fptrunc" +ppLlvmCastOp LM_Fpext = text "fpext" +ppLlvmCastOp LM_Fptoui = text "fptoui" +ppLlvmCastOp LM_Fptosi = text "fptosi" +ppLlvmCastOp LM_Uitofp = text "uitofp" +ppLlvmCastOp LM_Sitofp = text "sitofp" +ppLlvmCastOp LM_Ptrtoint = text "ptrtoint" +ppLlvmCastOp LM_Inttoptr = text "inttoptr" +ppLlvmCastOp LM_Bitcast = text "bitcast" +{-# SPECIALIZE ppLlvmCastOp :: LlvmCastOp -> SDoc #-} +{-# SPECIALIZE ppLlvmCastOp :: LlvmCastOp -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable -- ----------------------------------------------------------------------------- -- * Floating point conversion @@ -747,7 +793,7 @@ -- regardless of underlying architecture. -- -- See Note [LLVM Float Types]. -ppDouble :: Platform -> Double -> SDoc +ppDouble :: IsLine doc => Platform -> Double -> doc ppDouble platform d = let bs = doubleToBytes d hex d' = case showHex d' "" of @@ -761,6 +807,8 @@ LittleEndian -> reverse str = map toUpper $ concat $ fixEndian $ map hex bs in text "0x" <> text str +{-# SPECIALIZE ppDouble :: Platform -> Double -> SDoc #-} +{-# SPECIALIZE ppDouble :: Platform -> Double -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable -- Note [LLVM Float Types] -- ~~~~~~~~~~~~~~~~~~~~~~~ @@ -787,16 +835,22 @@ {-# NOINLINE widenFp #-} widenFp = float2Double -ppFloat :: Platform -> Float -> SDoc +ppFloat :: IsLine doc => Platform -> Float -> doc ppFloat platform = ppDouble platform . widenFp +{-# SPECIALIZE ppFloat :: Platform -> Float -> SDoc #-} +{-# SPECIALIZE ppFloat :: Platform -> Float -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable -------------------------------------------------------------------------------- -- * Misc functions -------------------------------------------------------------------------------- -ppCommaJoin :: (Outputable a) => [a] -> SDoc -ppCommaJoin strs = hsep $ punctuate comma (map ppr strs) +ppCommaJoin :: IsLine doc => (a -> doc) -> [a] -> doc +ppCommaJoin ppr strs = hsep $ punctuate comma (map ppr strs) +{-# SPECIALIZE ppCommaJoin :: (a -> SDoc) -> [a] -> SDoc #-} +{-# SPECIALIZE ppCommaJoin :: (a -> HLine) -> [a] -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable -ppSpaceJoin :: (Outputable a) => [a] -> SDoc -ppSpaceJoin strs = hsep (map ppr strs) +ppSpaceJoin :: IsLine doc => (a -> doc) -> [a] -> doc +ppSpaceJoin ppr strs = hsep (map ppr strs) +{-# SPECIALIZE ppSpaceJoin :: (a -> SDoc) -> [a] -> SDoc #-} +{-# SPECIALIZE ppSpaceJoin :: (a -> HLine) -> [a] -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable diff --git a/GHC/Parser.hs b/GHC/Parser.hs --- a/GHC/Parser.hs +++ b/GHC/Parser.hs @@ -9,12994 +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.0 - -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 ((AnnList - ,([LImportDecl GhcPs], [LHsDecl GhcPs]) - ,LayoutInfo GhcPs)) -happyIn39 :: ((AnnList - ,([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 ((AnnList - ,([LImportDecl GhcPs], [LHsDecl GhcPs]) - ,LayoutInfo GhcPs)) -happyIn40 :: ((AnnList - ,([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 (Located ([AddEpAnn],ImpExpSubSpec)) -happyIn52 :: (Located ([AddEpAnn],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 (([AddEpAnn], [LocatedA ImpExpQcSpec])) -happyIn53 :: (([AddEpAnn], [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 (([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 (Located ([AddEpAnn], LocatedA ImpExpQcSpec)) -happyIn55 :: (Located ([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 (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,EpaLocation),SourceText),IsBootInterface)) -happyIn63 :: (((Maybe (EpaLocation,EpaLocation),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 EpaLocation,Bool)) -happyIn64 :: ((Maybe EpaLocation,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 EpaLocation, RawPkgQual)) -happyIn65 :: ((Maybe EpaLocation, RawPkgQual)) -> (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 (Located (Maybe EpaLocation)) -happyIn66 :: (Located (Maybe EpaLocation)) -> (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 EpaLocation,Located (Maybe (LocatedA ModuleName)))) -happyIn67 :: ((Maybe EpaLocation,Located (Maybe (LocatedA ModuleName)))) -> (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 (Located (Maybe (ImportListInterpretation, LocatedL [LIE GhcPs]))) -happyIn68 :: (Located (Maybe (ImportListInterpretation, LocatedL [LIE GhcPs]))) -> (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 (ImportListInterpretation, LocatedL [LIE GhcPs])) -happyIn69 :: (Located (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 (Maybe (Located (SourceText,Int))) -happyIn70 :: (Maybe (Located (SourceText,Int))) -> (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 (Located FixityDirection) -happyIn71 :: (Located FixityDirection) -> (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 (Located (OrdList (LocatedN RdrName))) -happyIn72 :: (Located (OrdList (LocatedN RdrName))) -> (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 (LHsDecl GhcPs)) -happyIn73 :: (OrdList (LHsDecl 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 (OrdList (LHsDecl GhcPs)) -happyIn74 :: (OrdList (LHsDecl GhcPs)) -> (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 (OrdList (LHsDecl GhcPs)) -happyIn75 :: (OrdList (LHsDecl GhcPs)) -> (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 (OrdList (LHsDecl GhcPs)) -happyIn76 :: (OrdList (LHsDecl GhcPs)) -> (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 (LHsDecl GhcPs) -happyIn77 :: (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 (LHsDecl GhcPs) -happyIn78 :: (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 (LTyClDecl GhcPs) -happyIn79 :: (LTyClDecl 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 (LTyClDecl GhcPs) -happyIn80 :: (LTyClDecl 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 (LStandaloneKindSig GhcPs) -happyIn81 :: (LStandaloneKindSig 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 (Located [LocatedN RdrName]) -happyIn82 :: (Located [LocatedN RdrName]) -> (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 (LInstDecl GhcPs) -happyIn83 :: (LInstDecl 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 (Maybe (LocatedP OverlapMode)) -happyIn84 :: (Maybe (LocatedP OverlapMode)) -> (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 (LDerivStrategy GhcPs) -happyIn85 :: (LDerivStrategy 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 (LDerivStrategy GhcPs) -happyIn86 :: (LDerivStrategy 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 (Maybe (LDerivStrategy GhcPs)) -happyIn87 :: (Maybe (LDerivStrategy 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 (Located ([AddEpAnn], Maybe (LInjectivityAnn GhcPs))) -happyIn88 :: (Located ([AddEpAnn], Maybe (LInjectivityAnn 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 (LInjectivityAnn GhcPs) -happyIn89 :: (LInjectivityAnn 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 (Located [LocatedN RdrName]) -happyIn90 :: (Located [LocatedN RdrName]) -> (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 (Located ([AddEpAnn],FamilyInfo GhcPs)) -happyIn91 :: (Located ([AddEpAnn],FamilyInfo 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 [LTyFamInstEqn GhcPs])) -happyIn92 :: (Located ([AddEpAnn],Maybe [LTyFamInstEqn 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 (Located [LTyFamInstEqn GhcPs]) -happyIn93 :: (Located [LTyFamInstEqn 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 (LTyFamInstEqn GhcPs) -happyIn94 :: (LTyFamInstEqn 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 (LHsDecl GhcPs) -happyIn95 :: (LHsDecl 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 ([AddEpAnn]) -happyIn96 :: ([AddEpAnn]) -> (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 ([AddEpAnn]) -happyIn97 :: ([AddEpAnn]) -> (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 (LInstDecl GhcPs) -happyIn98 :: (LInstDecl 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 ([AddEpAnn], Bool, NewOrData)) -happyIn99 :: (Located ([AddEpAnn], Bool, NewOrData)) -> (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 (Located (AddEpAnn, NewOrData)) -happyIn100 :: (Located (AddEpAnn, NewOrData)) -> (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 (Located ([AddEpAnn], Maybe (LHsKind GhcPs))) -happyIn101 :: (Located ([AddEpAnn], Maybe (LHsKind 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 (Located ([AddEpAnn], LFamilyResultSig GhcPs)) -happyIn102 :: (Located ([AddEpAnn], LFamilyResultSig 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], LFamilyResultSig GhcPs)) -happyIn103 :: (Located ([AddEpAnn], LFamilyResultSig GhcPs)) -> (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], ( LFamilyResultSig GhcPs - , Maybe (LInjectivityAnn GhcPs)))) -happyIn104 :: (Located ([AddEpAnn], ( LFamilyResultSig GhcPs - , Maybe (LInjectivityAnn 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 (Maybe (LHsContext GhcPs), LHsType GhcPs)) -happyIn105 :: (Located (Maybe (LHsContext GhcPs), LHsType 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 (Maybe (LHsContext GhcPs), HsOuterFamEqnTyVarBndrs GhcPs, LHsType GhcPs)) -happyIn106 :: (Located (Maybe (LHsContext GhcPs), HsOuterFamEqnTyVarBndrs GhcPs, LHsType 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 (Maybe (LocatedP CType)) -happyIn107 :: (Maybe (LocatedP CType)) -> (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 (LDerivDecl GhcPs) -happyIn108 :: (LDerivDecl 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 (LRoleAnnotDecl GhcPs) -happyIn109 :: (LRoleAnnotDecl 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 [Located (Maybe FastString)]) -happyIn110 :: (Located [Located (Maybe FastString)]) -> (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 [Located (Maybe FastString)]) -happyIn111 :: (Located [Located (Maybe FastString)]) -> (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 FastString)) -happyIn112 :: (Located (Maybe FastString)) -> (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 (LHsDecl GhcPs) -happyIn113 :: (LHsDecl 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 ((LocatedN RdrName, HsPatSynDetails GhcPs, [AddEpAnn])) -happyIn114 :: ((LocatedN RdrName, HsPatSynDetails GhcPs, [AddEpAnn])) -> (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 ([LocatedN RdrName]) -happyIn115 :: ([LocatedN RdrName]) -> (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 ([RecordPatSynField GhcPs]) -happyIn116 :: ([RecordPatSynField GhcPs]) -> (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 (LocatedL (OrdList (LHsDecl GhcPs))) -happyIn117 :: (LocatedL (OrdList (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 (LSig GhcPs) -happyIn118 :: (LSig GhcPs) -> (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 (LHsDecl GhcPs) -happyIn120 :: (LHsDecl 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 (Located ([AddEpAnn],OrdList (LHsDecl GhcPs))) -happyIn121 :: (Located ([AddEpAnn],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 (Located ([AddEpAnn] - , OrdList (LHsDecl GhcPs) - , LayoutInfo GhcPs)) -happyIn122 :: (Located ([AddEpAnn] - , OrdList (LHsDecl GhcPs) - , LayoutInfo 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 (Located ([AddEpAnn] - ,(OrdList (LHsDecl GhcPs)) -- Reversed - ,LayoutInfo GhcPs)) -happyIn123 :: (Located ([AddEpAnn] - ,(OrdList (LHsDecl GhcPs)) -- Reversed - ,LayoutInfo 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 (Located (OrdList (LHsDecl GhcPs))) -happyIn124 :: (Located (OrdList (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))) -happyIn126 :: (Located ([AddEpAnn] - , OrdList (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 ([AddEpAnn] - , OrdList (LHsDecl GhcPs))) -happyIn127 :: (Located ([AddEpAnn] - , 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 ([TrailingAnn], OrdList (LHsDecl GhcPs))) -happyIn128 :: (Located ([TrailingAnn], 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 (AnnList,Located (OrdList (LHsDecl GhcPs)))) -happyIn129 :: (Located (AnnList,Located (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 (HsLocalBinds GhcPs)) -happyIn130 :: (Located (HsLocalBinds 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 (Maybe (Located (HsLocalBinds GhcPs, Maybe EpAnnComments ))) -happyIn131 :: (Maybe (Located (HsLocalBinds GhcPs, Maybe EpAnnComments ))) -> (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 ([LRuleDecl GhcPs]) -happyIn132 :: ([LRuleDecl 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 (LRuleDecl GhcPs) -happyIn133 :: (LRuleDecl 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 (([AddEpAnn],Maybe Activation)) -happyIn134 :: (([AddEpAnn],Maybe Activation)) -> (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 ([AddEpAnn]) -happyIn135 :: ([AddEpAnn]) -> (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 (([AddEpAnn] - ,Activation)) -happyIn136 :: (([AddEpAnn] - ,Activation)) -> (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 (([AddEpAnn] -> HsRuleAnn, Maybe [LHsTyVarBndr () GhcPs], [LRuleBndr GhcPs])) -happyIn137 :: (([AddEpAnn] -> HsRuleAnn, Maybe [LHsTyVarBndr () GhcPs], [LRuleBndr 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 ([LRuleTyTmVar]) -happyIn138 :: ([LRuleTyTmVar]) -> (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 (LRuleTyTmVar) -happyIn139 :: (LRuleTyTmVar) -> (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 (OrdList (LWarnDecl GhcPs)) -happyIn140 :: (OrdList (LWarnDecl GhcPs)) -> (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 (OrdList (LWarnDecl GhcPs)) -happyIn141 :: (OrdList (LWarnDecl 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 (OrdList (LWarnDecl GhcPs)) -happyIn142 :: (OrdList (LWarnDecl GhcPs)) -> (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 (OrdList (LWarnDecl GhcPs)) -happyIn143 :: (OrdList (LWarnDecl 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 (Located ([AddEpAnn],[Located StringLiteral])) -happyIn144 :: (Located ([AddEpAnn],[Located StringLiteral])) -> (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 (Located (OrdList (Located StringLiteral))) -happyIn145 :: (Located (OrdList (Located StringLiteral))) -> (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 (LHsDecl GhcPs) -happyIn146 :: (LHsDecl 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 (Located ([AddEpAnn],EpAnn [AddEpAnn] -> HsDecl GhcPs)) -happyIn147 :: (Located ([AddEpAnn],EpAnn [AddEpAnn] -> HsDecl 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 (Located CCallConv) -happyIn148 :: (Located CCallConv) -> (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 Safety) -happyIn149 :: (Located Safety) -> (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 ([AddEpAnn] - ,(Located StringLiteral, LocatedN RdrName, LHsSigType GhcPs))) -happyIn150 :: (Located ([AddEpAnn] - ,(Located StringLiteral, LocatedN RdrName, LHsSigType GhcPs))) -> (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 (Maybe (AddEpAnn, LHsType GhcPs)) -happyIn151 :: (Maybe (AddEpAnn, LHsType 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 (([AddEpAnn], Maybe (LocatedN RdrName))) -happyIn152 :: (([AddEpAnn], Maybe (LocatedN RdrName))) -> (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 (LHsSigType GhcPs) -happyIn153 :: (LHsSigType GhcPs) -> (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 (LHsSigType GhcPs) -happyIn154 :: (LHsSigType GhcPs) -> (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 [LocatedN RdrName]) -happyIn155 :: (Located [LocatedN RdrName]) -> (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 (OrdList (LHsSigType GhcPs)) -happyIn156 :: (OrdList (LHsSigType 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 UnpackednessPragma) -happyIn157 :: (Located UnpackednessPragma) -> (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 (HsForAllTelescope GhcPs)) -happyIn158 :: (Located (HsForAllTelescope 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 (LHsType GhcPs) -happyIn159 :: (LHsType 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 (LHsType GhcPs) -happyIn160 :: (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 (LHsContext GhcPs) -happyIn161 :: (LHsContext 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 (LHsType GhcPs) -happyIn162 :: (LHsType 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 (Located (LHsUniToken "->" "\8594" GhcPs -> HsArrow GhcPs)) -happyIn163 :: (Located (LHsUniToken "->" "\8594" GhcPs -> HsArrow 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 (forall b. DisambTD b => PV (LocatedA b)) -happyIn165 :: (forall b. DisambTD b => PV (LocatedA b)) -> (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 (forall b. DisambTD b => PV (LocatedA b)) -happyIn166 :: (forall b. DisambTD b => PV (LocatedA b)) -> (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 ((LocatedN RdrName, PromotionFlag)) -happyIn168 :: ((LocatedN RdrName, PromotionFlag)) -> (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 (LHsSigType GhcPs) -happyIn170 :: (LHsSigType 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 ([LHsSigType GhcPs]) -happyIn171 :: ([LHsSigType GhcPs]) -> (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 ([LHsType GhcPs]) -happyIn173 :: ([LHsType 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 ([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 ([LHsTyVarBndr Specificity GhcPs]) -happyIn175 :: ([LHsTyVarBndr Specificity 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 (LHsTyVarBndr Specificity GhcPs) -happyIn176 :: (LHsTyVarBndr Specificity 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 (LHsTyVarBndr Specificity GhcPs) -happyIn177 :: (LHsTyVarBndr Specificity 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 (Located ([AddEpAnn],[LHsFunDep GhcPs])) -happyIn178 :: (Located ([AddEpAnn],[LHsFunDep 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 (Located [LHsFunDep GhcPs]) -happyIn179 :: (Located [LHsFunDep 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 (LHsFunDep GhcPs) -happyIn180 :: (LHsFunDep 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 (Located [LocatedN RdrName]) -happyIn181 :: (Located [LocatedN RdrName]) -> (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 (LHsKind GhcPs) -happyIn182 :: (LHsKind 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] - ,[LConDecl GhcPs])) -happyIn183 :: (Located ([AddEpAnn] - ,[LConDecl 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 [LConDecl GhcPs]) -happyIn184 :: (Located [LConDecl 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 (LConDecl GhcPs) -happyIn185 :: (LConDecl 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 ([AddEpAnn],[LConDecl GhcPs])) -happyIn186 :: (Located ([AddEpAnn],[LConDecl 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 (Located [LConDecl GhcPs]) -happyIn187 :: (Located [LConDecl 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 (LConDecl GhcPs) -happyIn188 :: (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 ([AddEpAnn], Maybe [LHsTyVarBndr Specificity GhcPs])) -happyIn189 :: (Located ([AddEpAnn], Maybe [LHsTyVarBndr Specificity 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 (LocatedN RdrName, HsConDeclH98Details GhcPs)) -happyIn190 :: (Located (LocatedN RdrName, HsConDeclH98Details 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 ([LConDeclField GhcPs]) -happyIn191 :: ([LConDeclField 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 ([LConDeclField GhcPs]) -happyIn192 :: ([LConDeclField 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 (LConDeclField GhcPs) -happyIn193 :: (LConDeclField 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 (HsDeriving GhcPs)) -happyIn194 :: (Located (HsDeriving 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 (HsDeriving GhcPs)) -happyIn195 :: (Located (HsDeriving 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 (LHsDerivingClause GhcPs) -happyIn196 :: (LHsDerivingClause 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 (LDerivClauseTys GhcPs) -happyIn197 :: (LDerivClauseTys 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 (LHsDecl GhcPs) -happyIn198 :: (LHsDecl 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 (LHsDecl GhcPs) -happyIn199 :: (LHsDecl 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 (GRHSs GhcPs (LHsExpr GhcPs))) -happyIn200 :: (Located (GRHSs GhcPs (LHsExpr 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 [LGRHS GhcPs (LHsExpr GhcPs)]) -happyIn201 :: (Located [LGRHS GhcPs (LHsExpr 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 (LGRHS GhcPs (LHsExpr GhcPs)) -happyIn202 :: (LGRHS GhcPs (LHsExpr 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 (([AddEpAnn],Maybe Activation)) -happyIn204 :: (([AddEpAnn],Maybe Activation)) -> (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 (([AddEpAnn],Activation)) -happyIn205 :: (([AddEpAnn],Activation)) -> (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 (HsUntypedSplice GhcPs)) -happyIn206 :: (Located (HsUntypedSplice 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 (ECP) -happyIn207 :: (ECP) -> (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 (ECP) -happyIn208 :: (ECP) -> (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 (ECP) -happyIn209 :: (ECP) -> (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 (ECP) -happyIn210 :: (ECP) -> (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 ((Maybe EpaLocation,Bool)) -happyIn211 :: ((Maybe EpaLocation,Bool)) -> (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 (Located (HsPragE GhcPs)) -happyIn212 :: (Located (HsPragE 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 (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 (ECP) -happyIn216 :: (ECP) -> (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 (NonEmpty (LocatedAn NoEpAnns (DotFieldOcc GhcPs)))) -happyIn217 :: (Located (NonEmpty (LocatedAn NoEpAnns (DotFieldOcc 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 (LHsExpr GhcPs) -happyIn218 :: (LHsExpr GhcPs) -> (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 (Located (HsUntypedSplice GhcPs)) -happyIn219 :: (Located (HsUntypedSplice GhcPs)) -> (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 ((EpAnnCO, EpAnn [AddEpAnn]), LHsExpr GhcPs)) -happyIn220 :: (Located ((EpAnnCO, EpAnn [AddEpAnn]), LHsExpr 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 ([LHsCmdTop GhcPs]) -happyIn221 :: ([LHsCmdTop GhcPs]) -> (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 (LHsCmdTop GhcPs) -happyIn222 :: (LHsCmdTop 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 (([AddEpAnn],[LHsDecl GhcPs])) -happyIn223 :: (([AddEpAnn],[LHsDecl 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 ([LHsDecl GhcPs]) -happyIn224 :: ([LHsDecl 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 (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 (forall b. DisambECP b => PV (SumOrTuple b)) -happyIn226 :: (forall b. DisambECP b => PV (SumOrTuple b)) -> (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 (forall b. DisambECP b => PV (SrcSpan,[Either (EpAnn EpaLocation) (LocatedA b)])) -happyIn227 :: (forall b. DisambECP b => PV (SrcSpan,[Either (EpAnn EpaLocation) (LocatedA b)])) -> (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 (forall b. DisambECP b => PV [Either (EpAnn EpaLocation) (LocatedA b)]) -happyIn228 :: (forall b. DisambECP b => PV [Either (EpAnn EpaLocation) (LocatedA b)]) -> (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 (forall b. DisambECP b => SrcSpan -> (AddEpAnn, AddEpAnn) -> PV (LocatedA b)) -happyIn229 :: (forall b. DisambECP b => SrcSpan -> (AddEpAnn, AddEpAnn) -> PV (LocatedA b)) -> (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 (forall b. DisambECP b => PV [LocatedA b]) -happyIn230 :: (forall b. DisambECP b => PV [LocatedA b]) -> (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 (Located [LStmt GhcPs (LHsExpr GhcPs)]) -happyIn231 :: (Located [LStmt GhcPs (LHsExpr GhcPs)]) -> (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 (Located [[LStmt GhcPs (LHsExpr GhcPs)]]) -happyIn232 :: (Located [[LStmt GhcPs (LHsExpr GhcPs)]]) -> (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 [LStmt GhcPs (LHsExpr GhcPs)]) -happyIn233 :: (Located [LStmt GhcPs (LHsExpr 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 (Located (RealSrcSpan -> [LStmt GhcPs (LHsExpr GhcPs)] -> Stmt GhcPs (LHsExpr GhcPs))) -happyIn234 :: (Located (RealSrcSpan -> [LStmt GhcPs (LHsExpr GhcPs)] -> Stmt GhcPs (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 [LStmt GhcPs (LHsExpr GhcPs)]) -happyIn235 :: (Located [LStmt GhcPs (LHsExpr 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 [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 (forall b. DisambECP b => PV (Located (GRHSs GhcPs (LocatedA b)))) -happyIn237 :: (forall b. DisambECP b => PV (Located (GRHSs GhcPs (LocatedA b)))) -> (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 (forall b. DisambECP b => PV (Located [LGRHS GhcPs (LocatedA b)])) -happyIn238 :: (forall b. DisambECP b => PV (Located [LGRHS GhcPs (LocatedA b)])) -> (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 (forall b. DisambECP b => PV (Located [LGRHS GhcPs (LocatedA b)])) -happyIn239 :: (forall b. DisambECP b => PV (Located [LGRHS GhcPs (LocatedA b)])) -> (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 ([AddEpAnn],[LGRHS GhcPs (LHsExpr GhcPs)])) -happyIn240 :: (Located ([AddEpAnn],[LGRHS 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 (forall b. DisambECP b => PV (LGRHS GhcPs (LocatedA b))) -happyIn241 :: (forall b. DisambECP b => PV (LGRHS GhcPs (LocatedA b))) -> (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 (LPat GhcPs) -happyIn242 :: (LPat GhcPs) -> (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 ([LPat GhcPs]) -happyIn243 :: ([LPat GhcPs]) -> (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 (LPat GhcPs) -happyIn244 :: (LPat GhcPs) -> (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 (LPat GhcPs) -happyIn245 :: (LPat 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 ([LPat GhcPs]) -happyIn246 :: ([LPat GhcPs]) -> (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 (forall b. DisambECP b => PV (LocatedL [LocatedA (Stmt GhcPs (LocatedA b))])) -happyIn247 :: (forall b. DisambECP b => PV (LocatedL [LocatedA (Stmt GhcPs (LocatedA b))])) -> (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 (forall b. DisambECP b => PV (Located (OrdList AddEpAnn,[LStmt GhcPs (LocatedA b)]))) -happyIn248 :: (forall b. DisambECP b => PV (Located (OrdList AddEpAnn,[LStmt GhcPs (LocatedA b)]))) -> (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 (Maybe (LStmt GhcPs (LHsExpr GhcPs))) -happyIn249 :: (Maybe (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 (LStmt GhcPs (LHsExpr GhcPs)) -happyIn250 :: (LStmt 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 (forall b. DisambECP b => PV (LStmt GhcPs (LocatedA b))) -happyIn251 :: (forall b. DisambECP b => PV (LStmt GhcPs (LocatedA b))) -> (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 (LStmt GhcPs (LocatedA b))) -happyIn252 :: (forall b. DisambECP b => PV (LStmt 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 ([Fbind b], Maybe SrcSpan)) -happyIn253 :: (forall b. DisambECP b => PV ([Fbind b], Maybe SrcSpan)) -> (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 ([Fbind b], Maybe SrcSpan)) -happyIn254 :: (forall b. DisambECP b => PV ([Fbind b], Maybe SrcSpan)) -> (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 (Fbind b)) -happyIn255 :: (forall b. DisambECP b => PV (Fbind 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 [LocatedAn NoEpAnns (DotFieldOcc GhcPs)]) -happyIn256 :: (Located [LocatedAn NoEpAnns (DotFieldOcc 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 (Located [LIPBind GhcPs]) -happyIn257 :: (Located [LIPBind GhcPs]) -> (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 (LIPBind GhcPs) -happyIn258 :: (LIPBind 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 (Located HsIPName) -happyIn259 :: (Located HsIPName) -> (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 (Located (SourceText, FastString)) -happyIn260 :: (Located (SourceText, FastString)) -> (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 (LBooleanFormula (LocatedN RdrName)) -happyIn261 :: (LBooleanFormula (LocatedN RdrName)) -> (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 (LBooleanFormula (LocatedN RdrName)) -happyIn262 :: (LBooleanFormula (LocatedN RdrName)) -> (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 (LBooleanFormula (LocatedN RdrName)) -happyIn263 :: (LBooleanFormula (LocatedN RdrName)) -> (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 ([LBooleanFormula (LocatedN RdrName)]) -happyIn264 :: ([LBooleanFormula (LocatedN RdrName)]) -> (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 (LBooleanFormula (LocatedN RdrName)) -happyIn265 :: (LBooleanFormula (LocatedN RdrName)) -> (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 (Located [LocatedN RdrName]) -happyIn266 :: (Located [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 (LocatedN RdrName) -happyIn267 :: (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 (LocatedN RdrName) -happyIn268 :: (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 (LocatedN RdrName) -happyIn269 :: (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 (LocatedN RdrName) -happyIn270 :: (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 (LocatedN RdrName) -happyIn271 :: (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 (Located (NonEmpty (LocatedN RdrName))) -happyIn272 :: (Located (NonEmpty (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 (Located [LocatedN RdrName]) -happyIn273 :: (Located [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 DataCon) -happyIn274 :: (LocatedN DataCon) -> (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 DataCon) -happyIn275 :: (LocatedN DataCon) -> (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 (LocatedN RdrName) -happyIn277 :: (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 (LocatedN RdrName) -happyIn278 :: (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 RdrName) -happyIn279 :: (LocatedN RdrName) -> (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 RdrName) -happyIn280 :: (LocatedN RdrName) -> (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 (forall b. DisambInfixOp b => PV (LocatedN b)) -happyIn290 :: (forall b. DisambInfixOp b => PV (LocatedN b)) -> (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 (forall b. DisambInfixOp b => PV (LocatedN b)) -happyIn291 :: (forall b. DisambInfixOp b => PV (LocatedN b)) -> (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 (forall b. DisambInfixOp b => PV (Located b)) -happyIn292 :: (forall b. DisambInfixOp b => PV (Located b)) -> (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 (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 FieldLabelString) -happyIn300 :: (LocatedN FieldLabelString) -> (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 (Located FastString) -happyIn308 :: (Located FastString) -> (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 (Located FastString) -happyIn309 :: (Located FastString) -> (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 (Located (HsLit GhcPs)) -happyIn314 :: (Located (HsLit GhcPs)) -> (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 (()) -happyIn315 :: (()) -> (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 (LocatedA ModuleName) -happyIn316 :: (LocatedA ModuleName) -> (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 (([SrcSpan],Int)) -happyIn317 :: (([SrcSpan],Int)) -> (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 (([SrcSpan],Int)) -happyIn318 :: (([SrcSpan],Int)) -> (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 (([SrcSpan],Int)) -happyIn319 :: (([SrcSpan],Int)) -> (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 (forall b. DisambECP b => PV (LocatedL [LMatch GhcPs (LocatedA b)])) -happyIn320 :: (forall b. DisambECP b => PV (LocatedL [LMatch GhcPs (LocatedA b)])) -> (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 (forall b. DisambECP b => PV (LocatedL [LMatch GhcPs (LocatedA b)])) -happyIn321 :: (forall b. DisambECP b => PV (LocatedL [LMatch GhcPs (LocatedA b)])) -> (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 (ECP) -happyIn322 :: (ECP) -> (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 (ECP) -happyIn323 :: (ECP) -> (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 (forall b. DisambECP b => PV (Located ([AddEpAnn],[LMatch GhcPs (LocatedA b)]))) -happyIn324 :: (forall b. DisambECP b => PV (Located ([AddEpAnn],[LMatch GhcPs (LocatedA b)]))) -> (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 (Located ([AddEpAnn],[LMatch GhcPs (LocatedA b)]))) -happyIn325 :: (forall b. DisambECP b => PV (Located ([AddEpAnn],[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 (Located ([AddEpAnn],[LMatch GhcPs (LocatedA b)]))) -happyIn326 :: (forall b. DisambECP b => PV (Located ([AddEpAnn],[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 (forall b. DisambECP b => PV (Located ([AddEpAnn],[LMatch GhcPs (LocatedA b)]))) -happyIn327 :: (forall b. DisambECP b => PV (Located ([AddEpAnn],[LMatch GhcPs (LocatedA b)]))) -> (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 (forall b. DisambECP b => PV (LMatch GhcPs (LocatedA b))) -happyIn328 :: (forall b. DisambECP b => PV (LMatch GhcPs (LocatedA b))) -> (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 (LMatch GhcPs (LocatedA b))) -happyIn329 :: (forall b. DisambECP b => PV (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 #-} -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\x04\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\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\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\xc0\xc1\x40\x44\xff\xff\xf8\x03\x01\x00\x04\x78\x00\xa0\x0a\x67\xfe\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\xe0\x6f\xbe\xea\xff\x5f\xfe\xdf\x33\x08\x02\x3c\x00\x50\x85\x33\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\x70\x30\x10\xd1\xff\x2f\xfe\x40\x00\x00\x01\x1e\x00\xa8\xc2\x99\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\x38\x18\x88\xe8\xff\x17\x7f\x20\x00\x80\x00\x0f\x00\x54\xe1\xcc\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\x1c\xcc\x45\xf4\xff\xcb\xff\x13\x04\x41\x80\x07\x00\xaa\x70\xe6\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\x0e\x06\x22\xfa\xff\xc7\x1f\x08\x00\x20\xc0\x03\x00\x55\x38\xf3\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\x02\x01\x10\xfd\x7f\xc2\x0f\x00\x00\x02\x22\x42\x80\x0a\xfa\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\x80\x81\x00\x88\x7e\x3e\xe1\x07\x30\x00\x01\x70\x21\x44\x05\xbf\xd3\x01\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\x40\x00\x00\x00\x80\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\x20\x10\x00\xd1\xff\x27\xfc\x00\x00\x00\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x21\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\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\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\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\x00\x00\x00\x00\x00\x18\x08\x80\xe0\xe7\x13\x7e\x00\x03\x10\x00\x17\x42\x54\xf0\x3b\x1c\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\x0c\x04\x40\xf4\xf3\x09\x3f\x80\x01\x08\x80\x0b\x21\x2a\xf8\x9d\x0e\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\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\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\xc0\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\x18\x08\x80\xe0\xe7\x13\x7e\x00\x03\x10\x00\x17\x52\x54\xf0\x3b\x1c\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x04\x02\x20\xf8\xf9\x84\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\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\x06\x02\x20\xf8\xf9\x84\x1f\x00\x00\x00\x80\x05\x10\x15\x38\x02\x07\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\x03\x01\x10\xfc\x7c\xc2\x0f\x00\x00\x00\xc0\x02\x88\x0a\x1c\x81\x03\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\x40\x20\x00\xa2\xff\x4f\xf8\x01\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\x30\x10\x00\xd1\xcf\x27\xfc\x00\x06\x20\x00\x2e\x84\xb8\xe0\x77\x3a\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\x18\x08\x80\xe8\xe7\x13\x7e\x00\x03\x10\x10\x17\x42\x74\xf8\x3b\x1d\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\x0c\x04\x40\xf4\xf3\x09\x3f\x80\x01\x08\x82\x0b\x21\x6a\xfc\x9d\x0e\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\x04\x02\x20\xf8\xf9\x84\x1f\x00\x00\x00\x00\x00\x00\x00\x30\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\x02\x01\x10\xfd\x7f\xc2\x0f\x00\x00\x02\x20\x42\x80\x0a\x7a\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\xff\x27\xfc\x00\x00\x00\x00\x00\x00\xa8\xc2\x19\xfe\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x10\x10\x11\x02\x20\x08\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\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\x04\x02\x20\xfa\xff\x84\x1f\x00\x00\x00\x00\x00\x00\x00\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x7e\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\xc0\xc1\x40\x44\xff\xbf\xf8\x03\x01\x00\x04\x78\x00\xa0\x0a\x67\xfe\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\xe0\x60\x20\xa2\xff\x5f\xf8\x01\x00\x00\x02\x38\x40\x50\x85\x33\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\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\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\x70\x30\x10\xd1\xff\x2f\xfe\x40\x00\x00\x01\x1e\x00\xa8\xc2\x99\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\x38\x18\x88\xe8\xff\x17\x7f\x20\x00\x80\x04\x0f\x40\x54\xe1\xcc\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\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\x0e\x06\x22\xfa\xff\x85\x1f\x00\x00\x20\x80\x03\x00\x55\x38\xf3\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\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\x80\x83\x81\x88\xfe\x7f\xe1\x07\x00\x00\x08\xe0\x00\x40\x15\xce\xfc\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\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\xe0\x60\x20\xa2\xff\x5f\xf8\x01\x00\x00\x0e\x38\x00\x50\x85\x33\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\x70\x30\x10\xd1\xff\x2f\xfe\x00\x00\x00\x01\x1c\x00\xa8\xc2\x99\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\x38\x18\x88\xe8\xff\x17\x7e\x00\x00\x80\x00\x0e\x00\x54\xe1\xcc\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\x1c\x0c\x44\xf4\xff\x0b\x3f\x00\x00\x40\x00\x07\x00\xaa\x70\xe6\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\x0e\x06\x22\xfa\xff\x85\x1f\x00\x00\x20\x80\x03\x00\x55\x38\xf3\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\x07\x03\x11\xfd\xff\xe2\x0f\x04\x00\x12\xe0\x43\x80\x2b\xfe\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\x80\x83\x81\x88\xfe\x7f\xf1\x07\x02\x00\x49\xf0\x61\x40\x97\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\xc0\xc1\x40\x44\xff\xbf\xf8\x03\x01\x80\x24\xf8\x10\xa0\xce\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\xe0\x60\x20\xa2\xff\x5f\xf8\x01\x00\x00\x02\x38\x00\x50\x85\x33\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\x20\x10\x00\xd1\xff\x27\xfc\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\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\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\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\xe0\x60\x20\xa2\xff\x5f\xfc\x01\x00\x00\x02\x3c\x00\x50\x85\x33\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\x30\x10\x00\xd1\xcf\x27\xfc\x00\x06\x20\x00\x2e\x84\xa8\xe0\x77\x3a\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\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\x1c\x0c\x44\xf4\xff\x8b\x3f\x10\x00\x40\x80\x07\x00\xaa\x70\xe6\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\x06\x02\x20\xfa\xff\x84\x1f\x00\x00\x00\x00\x00\x00\x55\x38\xc3\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\x02\x01\x10\xfc\x7c\xc2\x0f\x00\x00\x00\x00\x00\x80\x0a\x18\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\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\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\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\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\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\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\x10\x08\x80\xe8\xff\x13\x7e\x00\x00\x00\x00\x00\x00\x10\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\x02\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\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\x01\x10\xfd\x7f\xc2\x0f\x00\x00\x00\x00\x00\x00\x02\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\x81\x00\x88\xfe\x3f\xe1\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\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\xe0\x60\x20\xa2\xff\x5f\xfc\x81\x00\x40\x12\x7c\x18\xd0\xe5\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\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\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\x18\x08\x80\xe0\xe7\x13\x7e\x00\x03\x10\x00\x17\x42\x54\xf0\x3b\x1c\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\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\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\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\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x01\x0c\x40\x00\x5c\x08\x51\xc1\xef\x70\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\x40\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\x08\x80\xe8\xff\x13\x7e\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\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\x04\x02\x20\xfa\xff\x84\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\x02\x01\x10\xfd\x7f\xc2\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\x81\x00\xa9\xfe\x3f\xe1\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\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\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\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\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\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\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\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\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\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\x1c\x0c\x44\xf4\xff\x0b\x3f\x00\x00\x40\x00\x07\x00\xaa\x70\xe6\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\x70\x30\x10\xd1\xff\x2f\xfc\x00\x00\x00\x01\x1c\x00\xa8\xc2\x99\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\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\x08\x80\x08\x01\x10\x84\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\x01\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\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\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\x10\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\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\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\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\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\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\x02\x40\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\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\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\x10\x00\x00\x00\x20\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x00\x00\x00\x00\x00\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\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\xc0\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\x0c\x04\x40\xf4\xf3\x09\x3f\x80\x01\x08\x80\x0b\x21\x2a\xf8\x1d\x0e\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\x06\x02\x20\xf8\xf9\x84\x1f\xc0\x00\x04\xc0\x85\x10\x15\xfc\x0e\x07\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\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\x80\x81\x00\x88\x7e\x3e\xe1\x07\x30\x00\x01\x70\x21\x44\x05\xbf\xd3\x01\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\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\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\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\x60\x20\x00\xa2\x9f\x4f\xf8\x01\x0c\x40\x00\x5c\x08\x51\xc1\xef\x74\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\x30\x10\x00\xd1\xcf\x27\xfc\x00\x06\x20\x00\x2e\x84\xa8\xe0\x77\x3a\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\x18\x08\x80\xe0\xe7\x13\x7e\x00\x03\x10\x00\x17\x42\x54\xf0\x3b\x1c\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\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\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\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\xe0\x60\x20\xa2\xff\x5f\xfc\x81\x00\x00\x02\x3c\x00\x50\x85\x33\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\x0c\x04\x40\xf4\xf3\x09\x3f\x80\x01\x08\x80\x0b\x21\x2a\xf8\x9d\x0e\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\x06\x02\x20\xfa\xff\x84\x1f\x00\x00\x00\x00\x00\x00\x00\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\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\x80\x81\x00\x08\x7e\x3e\xe1\x07\x30\x00\x01\x70\x21\x44\x05\xbf\xc3\x01\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\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\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\x60\x00\xe2\x07\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\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\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\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\x80\x83\x81\x88\xfe\x7f\xf1\x07\x00\x00\x08\xf0\x00\x40\x15\xce\xfc\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\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x80\x83\x81\x88\xfe\x7f\xf1\x07\x02\x00\x09\xf0\x21\x40\x97\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\xc0\xc1\x40\x44\xff\xbf\xf8\x03\x01\x80\x24\xf8\x10\xa0\x8a\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\x70\x30\x10\xd1\xff\x2f\xfe\x00\x00\x00\x01\x1c\x00\xa8\xc2\x99\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\x10\x08\x80\xe8\xff\x13\x7e\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\x03\x01\x10\xfd\x7f\xc2\x0f\x00\x00\x00\x00\x00\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\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\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\x40\x00\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\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\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\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\x80\x40\x00\x44\xff\x9f\xf0\x03\x00\x80\x00\x88\x10\xa0\x43\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\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\x20\x10\x00\xd1\xff\x27\xfc\x00\x00\x00\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\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\x04\x02\x20\xfa\xff\x84\x1f\x00\x00\x00\x00\x00\x00\x04\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\x03\x01\x10\xfd\x7c\xc2\x0f\x60\x00\x02\xe0\x42\x88\x0a\x7e\xa7\x03\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\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\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\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\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\x1c\xcc\x45\xf4\xff\xcb\xff\x13\x04\x41\x80\x07\x00\xaa\x70\xe6\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\x0e\xe6\x22\xfa\xff\xe5\xff\x09\x82\x20\xc0\x03\x00\x55\x38\xf3\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\x02\x01\x10\xfd\x7f\xc2\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\x80\x81\x00\x88\x7e\x3e\xe1\x07\x30\x00\x01\x70\x21\x44\x05\xbf\xd3\x01\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\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x02\x22\x40\x00\x04\x61\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\x40\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\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\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\x01\x10\x21\x00\x00\x31\x03\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\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\x70\x30\x10\xd1\xff\x3f\xfe\x40\x00\x00\x01\x1e\x00\xa8\xc2\x99\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\x38\x18\x88\xe8\xff\x1f\x7f\x20\x00\x80\x00\x0f\x00\x54\xe1\xcc\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\x01\x10\x21\x00\x82\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\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\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\x0e\x06\x22\xfa\xff\xc5\x1f\x08\x00\x24\xc0\x87\x00\x75\xfe\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\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\x40\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\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\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\x80\x83\x81\x88\xfe\x7f\xe1\x07\x00\x00\x08\xe0\x00\x41\x15\xce\xfc\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\xe0\x60\x20\xa2\xff\x5f\xf8\x01\x00\x00\x02\x38\x00\x50\x85\x33\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\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\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\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\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\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\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\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\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\x80\x83\x81\x88\xfe\x7f\xf1\x07\x02\x00\x08\xf0\x00\x40\x15\xce\xfc\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\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\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\x70\x30\x10\xd1\xff\x2f\xfc\x00\x00\x00\x01\x1c\x00\xa8\xc2\x99\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\x38\x18\x88\xe8\xff\x17\x7f\x20\x00\x80\x00\x0f\x00\x54\xe1\xcc\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\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\x04\x02\x20\xfa\xff\x84\x1f\x00\x00\x02\x00\x00\x00\x04\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\x80\x81\x00\x08\x7e\x3e\xe1\x07\x00\x00\x00\x60\x01\x44\x05\x8e\xc0\x01\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\x60\x20\x00\xa2\x9f\x4f\xf8\x01\x0c\x40\x00\x5c\x08\x51\xc1\xef\x74\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\x70\x30\x10\xd1\xff\x2f\xfe\x40\x00\x00\x01\x1e\x00\xa8\xc2\x99\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\x38\x18\x88\xe8\xff\x17\x7f\x20\x00\x80\x00\x0f\x00\x54\xe1\xcc\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\x1c\x0c\x44\xf4\xff\x8b\x3f\x10\x00\x40\x80\x07\x00\xaa\x70\xe6\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\x0e\x06\x22\xfa\xff\xc5\x1f\x08\x00\x20\xc0\x03\x00\x55\x38\xf3\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\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\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\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\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\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\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\x06\x02\x20\xfa\xf9\x84\x1f\xc0\x00\x04\xc0\x85\x10\x15\xfc\x4e\x07\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\x03\x01\x10\xfd\x7c\xc2\x0f\x60\x00\x02\xe0\x42\x88\x0e\x7f\xa7\x03\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\x81\x00\x88\xfe\x3f\xe1\x07\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\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\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\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\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\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\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\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\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\x02\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\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x02\x01\x10\xfd\x7f\xc2\x0f\x00\x00\x00\x00\x00\x80\x0a\x18\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\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\x10\x08\x80\xe0\xe7\x13\x7e\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\x02\x01\x10\xfc\x7c\xc2\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\x81\x00\x08\x7e\x3e\xe1\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\xc0\x40\x00\x44\x3f\x9f\xf0\x03\x18\x80\x00\xb8\x10\xa2\x82\xdf\xe9\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\x60\x20\x00\x82\x9f\x4f\xf8\x01\x00\x00\x00\x58\x00\x51\x81\x23\x70\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\x18\x08\x80\xe0\xe7\x13\x7e\x00\x03\x10\x00\x17\x42\x54\xf0\x3b\x1c\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\x06\x02\x20\xf8\xf9\x84\x1f\x00\x00\x00\x80\x05\x10\x15\x38\x02\x07\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\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\x80\x81\x00\x88\x7e\x3e\xe1\x07\x30\x00\x01\x70\x21\x44\x05\xbf\xd3\x01\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\xc0\x40\x00\x44\x3f\x9f\xf0\x03\x18\x80\x00\xb8\x10\xa2\x82\xdf\xe9\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\x60\x20\x00\x82\x9f\x4f\xf8\x01\x00\x00\x00\x58\x00\x51\x81\x23\x70\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\x30\x10\x00\xd1\xcf\x27\xfc\x00\x06\x20\x00\x2e\x84\xa8\xe0\x77\x3a\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\x18\x08\x80\xe8\xe7\x13\x7e\x00\x03\x10\x00\x17\x42\x54\xf0\x3b\x1d\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\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\x80\x40\x00\x04\x07\x9f\xf0\x03\x00\x00\x00\x00\x00\x00\x00\x06\x40\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\x08\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\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\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\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\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\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\x10\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\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\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\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\x60\x20\x00\xa2\x9f\x4f\xf8\x01\x0c\x40\x00\x5c\x08\x51\xc1\xef\x74\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\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\x02\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\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\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\x03\x01\x10\xfd\x7c\xc2\x0f\x60\x00\x02\xe0\x42\x88\x0a\x7e\xa7\x03\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\x81\x00\x88\xfe\x3f\xe1\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x01\x0c\x40\x00\x5c\x08\x51\xc1\xef\x74\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\x80\x81\x00\x88\x7e\x3e\xe1\x07\x30\x00\x01\x70\x21\x44\x05\xbf\xd3\x01\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\x06\x02\x20\xfa\xf9\x84\x1f\xc0\x00\x04\xc0\x85\x10\x15\xfc\x4e\x07\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\x03\x01\x10\xfd\x7c\xc2\x0f\x60\x00\x02\xe0\x42\x88\x0a\x7e\xa7\x03\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\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\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\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\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\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\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\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\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\x80\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\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\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\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\x07\x03\x11\xfd\xff\xe2\x0f\x04\x00\x10\xe0\x01\x80\x2a\x9c\xf9\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\x80\x83\x81\x88\xfe\x7f\xf1\x07\x02\x00\x08\xf0\x00\x40\x15\xce\xfc\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\x38\x18\x88\xe8\xff\x17\x7e\x00\x00\x80\x00\x0e\x80\x54\xe5\xcc\xff\xff\xfa\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\x1c\x0c\x44\xf4\xff\x0b\x3f\x00\x00\x40\x00\x07\x00\xab\x72\xe6\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\x07\x03\x11\xfd\xff\xe2\x0f\x04\x00\x10\xe0\x01\x90\xaa\x9c\xf9\xff\x5f\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\x80\x83\x81\x88\xfe\x7f\xf1\x07\x02\x00\x08\xf0\x00\x60\x55\xce\xfc\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\xc0\xc1\x40\x44\xff\xbf\xf8\x03\x01\x00\x04\x78\x00\xa0\x0a\x67\xfe\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\x70\x30\x10\xd1\xff\x2f\xfe\x40\x00\x20\x01\x3e\x04\xa8\xe2\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\x1c\x0c\x44\xf4\xff\x8b\x3f\x10\x00\x40\x80\x07\x00\xaa\x70\xe6\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\x0e\x06\x62\xfa\xff\xc5\x1f\x08\x00\x20\xc0\x03\x00\x55\x38\xf3\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\x07\x03\x11\xfd\xff\xe2\x0f\x04\x00\x12\xe0\x43\x80\x2a\xfe\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\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\x1c\x0c\x44\xf4\xff\x8b\x3f\x10\x00\x48\x80\x0f\x01\xaa\xfc\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\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\x80\x83\x81\x88\xfe\x7f\xe1\x07\x00\x00\x08\xe0\x00\x40\x35\xce\xfc\xff\xaf\x2f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\xbf\xf9\xaa\xff\x7f\xf9\x7f\xcf\x20\x08\xf0\x00\x40\x15\xce\xfc\xff\xaf\x2f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\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\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\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\x04\x02\x20\xfa\xff\x84\x1f\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\x01\x00\x00\x00\x40\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\x08\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\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\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\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\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\x80\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\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\x15\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\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\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\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\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\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\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\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\x02\x01\x10\xfd\x7f\xc2\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\x81\x00\x88\xfe\x3f\xe1\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\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\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\x54\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\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\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\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\x40\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\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\x07\x03\x11\xfd\xff\xe2\x0f\x04\x00\x10\xe0\x01\x80\x2a\x9c\xf9\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\x80\x83\x81\x88\xfe\x7f\xf1\x07\x02\x00\x09\xf0\x21\x40\x15\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\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\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\x30\x10\x00\xd1\xcf\x27\xfc\x00\x06\x20\x00\x2e\x84\xa8\xe0\x77\x38\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\xfd\xff\xe2\x0f\x04\x00\x10\xe0\x01\x80\x2a\x9c\xf9\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\x10\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\x38\x18\x88\xe8\xff\x17\x7f\x20\x00\x80\x00\x0f\x00\x54\xe1\xcc\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\x1c\x0c\x44\xf4\xff\x8b\x3f\x10\x00\x40\x80\x07\x00\xaa\x70\xe6\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\x06\x02\x20\xf8\xf9\x84\x1f\xc0\x00\x04\xc0\x85\x10\x15\xfc\x0e\x07\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\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\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\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x08\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\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\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\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\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\x60\x20\x00\xa2\x9f\x4f\xf8\x01\x0c\x40\x00\x5c\x08\x51\xc1\xef\x74\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\x30\x10\x00\xd1\xcf\x27\xfc\x00\x06\x20\x00\x2e\x84\xa8\xe0\x77\x3a\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\x10\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\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\x20\x10\x00\xd1\xff\x27\xfc\x00\x00\x00\x00\x00\x00\x20\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\x10\x08\x80\xe8\xff\x13\x7e\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\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\x06\x02\x20\xfa\xf9\x84\x1f\xc0\x00\x04\xc0\x85\x10\x15\xfc\x4e\x07\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\x81\x00\x88\xfe\x3f\xe1\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\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\xe0\x60\x20\xa2\xff\x5f\xfc\x81\x00\x00\x02\x3c\x00\x50\x85\x33\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\x70\x30\x10\xd1\xff\x2f\xfe\x40\x00\x00\x01\x1e\x00\xa8\xc2\x99\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x40\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\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\x04\x02\x20\xfa\xff\x84\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\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\x70\x30\x10\xd1\xff\x2f\xfc\x00\x00\x00\x01\x1c\x00\xa8\xc2\x99\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\x10\x00\x01\x02\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\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\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\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\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\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\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\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\xf0\x37\x5f\xf5\xff\x2f\xff\xef\x19\x04\x01\x1e\x00\xa8\xc2\x99\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\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\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\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\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x80\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\x10\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\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\x1c\x0c\x44\xf4\xff\x8b\x3f\x00\x00\x40\x80\x07\x00\xaa\x70\xe6\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\x04\x02\x20\xfa\xff\x84\x1f\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\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\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\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\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\x02\x01\x10\xfd\x7f\xc2\x0f\x00\x00\x00\x00\x00\x00\x02\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\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\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\x30\x10\x00\xd1\xcf\x27\xfc\x00\x06\x20\x00\x2e\x84\xa8\xe0\x77\x3a\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\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\x0c\x04\x40\xf4\xf3\x09\x3f\x80\x01\x08\x80\x0b\x21\x2a\xf8\x9d\x0e\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\x04\x02\x20\xf8\xf9\x84\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\x80\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\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\x06\x02\x20\xfa\xf9\x84\x1f\xc0\x00\x04\xc0\x85\x10\x15\xfc\x4e\x07\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\x03\x01\x10\xfd\x7c\xc2\x0f\x60\x00\x02\xe0\x42\x88\x0a\x7e\xa7\x03\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\x60\x20\x00\xa2\x9f\x4f\xf8\x01\x0c\x40\x00\x5c\x08\x51\xc1\xef\x74\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\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\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\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\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\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\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\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\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\x40\x20\x00\x82\x9f\x4f\xf8\x01\x00\x00\x00\x00\x00\x41\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x0c\x04\x40\xf4\xf3\x09\x3f\x80\x01\x08\x80\x0b\x21\x2a\xf8\x9d\x0e\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\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\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\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x0f\x60\x00\x02\xe0\x42\x88\x0a\x7e\xa7\x03\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\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\x60\x20\x00\xa2\x9f\x4f\xf8\x01\x0c\x40\x00\x5c\x08\x51\xc1\xef\x74\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\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\xc0\xc1\x5c\x44\xff\xbf\xfc\x3f\x41\x10\x04\x78\x00\xa0\x0a\x67\xfe\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\xe0\x60\x20\xa2\xff\x5f\xfc\x81\x00\x00\x02\x3c\x00\x50\x85\x33\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\x0c\x04\x40\xf4\xf3\x09\x3f\x80\x01\x08\x80\x0b\x21\x2a\xf8\x9d\x0e\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\x04\x44\x84\x00\x00\xc4\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x70\x30\x10\xd1\xff\x3f\xfe\x40\x00\x00\x01\x1e\x00\xa8\xc2\x99\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\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\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\xc0\xc1\x40\x44\xff\xbf\xf8\x03\x01\x00\x04\x78\x00\xa0\x0a\x67\xfe\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\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\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\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\x70\x30\x10\xd1\xff\x2f\xfe\x40\x00\x00\x01\x1e\x00\xa8\xca\x99\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\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\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\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\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\x70\x30\x10\xd1\xff\x2f\xfc\x00\x00\x00\x01\x1c\x00\xa8\xca\x99\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\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\x80\x83\x81\x88\xfe\x7f\xf1\x07\x02\x00\x08\xf0\x00\x40\x15\xce\xfc\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\xc0\xc1\x40\x44\xff\xbf\xf8\x03\x01\x00\x04\x78\x00\xa0\x0a\x67\xfe\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\xe0\x60\x20\xa2\xff\x5f\xfc\x81\x00\x00\x02\x3c\x00\x50\x85\x33\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\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\x0e\x06\x22\xfa\xff\xc5\x1f\x08\x00\x24\xc0\x87\x00\x55\xfc\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\x02\x01\x10\xfd\x7f\xc2\x0f\x00\x00\x01\x00\x00\x00\x02\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\x60\x20\x00\xa2\x9f\x4f\xf8\x01\x0c\x40\x00\x5c\x08\x51\xc1\xef\x74\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\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\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\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\x0c\x04\x40\xf4\xf3\x09\x3f\x80\x01\x08\x80\x0b\x21\x2a\xf8\x9d\x0e\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\x03\x01\x10\xfd\x7c\xc2\x0f\x60\x00\x02\xe0\x42\x88\x0a\x7e\xa7\x03\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\x80\x40\x00\x04\x07\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\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\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\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\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x01\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\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\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\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\x01\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\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\xc0\xc1\x40\x44\xff\xbf\xf0\x03\x00\x00\x04\x70\x00\xa0\x0a\x67\xfe\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\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\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\x0e\x06\x22\xfa\xff\xc5\x1f\x08\x00\x20\xc0\x03\x00\x55\x38\xf3\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\xc0\xc1\x40\x44\xff\xbf\xf8\x03\x01\x00\x04\x78\x00\xa0\x0a\x67\xfe\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\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\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\x0e\x06\x62\xfa\xff\xc5\x1f\x08\x00\x20\xc0\x03\x00\x55\x38\xf3\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\x07\x03\x31\xfd\xff\xe2\x0f\x04\x00\x10\xe0\x01\x80\x2a\x9c\xf9\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\x80\x83\x81\x88\xfe\x7f\xf1\x07\x02\x00\x08\xf0\x00\x40\x15\xce\xfc\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\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\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\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\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\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\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\xc0\x40\x00\x04\x3f\x9f\xf0\x03\x18\x80\x00\xb8\x10\xa2\x82\xdf\xe1\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\x40\x20\x00\x82\x9f\x4f\xf8\x01\x00\x00\x00\x00\x00\x41\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\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\x04\x00\x00\xc0\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\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\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\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\x30\x10\x00\xc1\xcf\x27\xfc\x00\x06\x20\x00\x2e\x84\xa8\xe0\x77\x38\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\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x88\xfe\x7f\xf1\x07\x02\x00\x08\xf0\x00\x40\x15\xce\xfc\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\xe0\x66\x2e\xaa\xff\x5f\xfe\x9f\x20\x08\x02\x3c\x00\x50\x85\x33\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\x70\x33\x17\xd5\xff\x2f\xff\x4f\x10\x04\x01\x1e\x00\xa8\xc2\x99\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\x00\x00\x00\x00\x00\x00\x00\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\x31\x57\xd5\xff\x2f\xff\x4f\x10\x04\x01\x1e\x00\xa8\xc2\x99\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\xb8\x98\xab\xea\xff\x97\xff\x27\x08\x82\x00\x0f\x00\x54\xe1\xcc\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\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\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\x30\x10\x00\xc1\xcf\x27\xfc\x00\x06\x20\x00\x2e\x84\xa8\xe0\x77\x38\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\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\x0c\x04\x40\xf4\xf3\x09\x3f\x80\x01\x08\x80\x0b\x21\x2a\xf8\x9d\x0e\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\x81\x00\x88\xfe\x3f\xe1\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\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\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\x02\x01\x10\xfd\x7f\xc2\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\x05\x10\x21\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\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\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\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\x00\x00\x00\x00\x00\x00\x00\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\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\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\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\x10\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\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\x04\x40\x84\x00\x00\xc0\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\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\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\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\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\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\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\xa8\xfe\x3f\xe1\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\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x07\x03\x11\xfd\xff\xe2\x0f\x04\x00\x10\xe0\x01\x80\x2a\x9c\xf9\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\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\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\x70\x30\x17\xd1\xff\x2f\xff\x4f\x10\x04\x01\x1e\x00\xa8\xc2\x99\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\x38\x98\x8b\xe8\xff\x97\xff\x27\x08\x82\x00\x0f\x00\x54\xe1\xcc\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\x03\x01\x10\xfd\x7c\xc2\x0f\x60\x00\x02\xe0\x42\x88\x0a\x7e\xa7\x03\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\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\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\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\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\x02\x01\x10\xfc\x7c\xc2\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x08\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\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\x1c\x0c\x44\xf4\xff\x8b\x3f\x00\x00\x40\x80\x07\x00\xaa\x70\xe6\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\x06\x02\x21\xfa\xfb\x84\x1f\xc0\x00\x04\xc0\x85\x10\x15\xfc\x0e\x07\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\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\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\x18\x08\x80\xe0\xe7\x13\x7e\x00\x03\x10\x00\x17\x42\x54\xf0\x3b\x1c\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\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\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\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\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\x06\x02\x20\xfa\xf9\x84\x1f\xc0\x00\x04\xc0\x85\x10\x1d\xfc\x4e\x07\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\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\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\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\x80\x81\x00\x88\x7e\x3e\xe1\x07\x30\x00\x01\x70\x21\x44\x05\xbf\xd3\x01\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\x1c\x0c\x44\xf4\xff\x8b\x3f\x10\x00\x40\x80\x07\x00\xaa\x70\xe6\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\x0e\x06\x22\xfa\xff\xc5\x1f\x08\x00\x20\xc0\x03\x00\x55\x38\xf3\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\x07\x03\x11\xfd\xff\xe2\x0f\x04\x00\x10\xe0\x01\x80\x2a\x9c\xf9\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\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\x1c\x0c\x44\xf4\xff\x8b\x3f\x10\x00\x48\x80\x0f\x01\xaa\xf8\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\x04\x02\x20\xfa\xff\x84\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x08\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\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\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\x04\x02\x20\x38\xf8\x84\x1f\x00\x00\x00\x00\x00\x00\x00\x30\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\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\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\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\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\x40\x20\x00\x82\x83\x4f\xf8\x01\x00\x00\x00\x00\x00\x00\x00\x03\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\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\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\x00\x00\x00\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\x88\xfe\x7f\xf1\x07\x02\x00\x08\xf0\x00\x40\x15\xce\xfc\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\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\x06\x02\x20\xf8\xf9\x84\x1f\xc0\x00\x04\xc0\x85\x10\x15\xfc\x0e\x07\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\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\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\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\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\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\x80\x0a\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\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\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\xdc\xcc\x45\xf5\xff\xcb\xff\x13\x04\x41\x80\x07\x00\xaa\x70\xe6\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\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\x80\x81\x00\x88\x7e\x3e\xe1\x07\x30\x00\x01\x70\x21\x44\x05\xbf\xc3\x01\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\xc0\x40\x00\x04\x3f\x9f\xf0\x03\x18\x80\x00\xb8\x10\xa2\x82\xdf\xe1\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\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\x30\x10\x00\xc1\xcf\x27\xfc\x00\x06\x20\x00\x2e\x84\xa8\xe0\x77\x38\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\xfd\xff\xf2\xff\x04\x41\x10\xe0\x01\x80\x2a\x9c\xf9\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\x80\x81\x00\x88\x7e\x3e\xe1\x07\x30\x00\x01\x70\x21\x44\x05\xbf\xc3\x01\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\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\x0c\x04\x40\xf4\xf3\x09\x3f\x80\x01\x0c\x80\x0b\x21\x2a\xf8\x1d\x0e\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\x06\x02\x20\xfa\xf9\x84\x1f\xc0\x00\x06\xc0\x85\x10\x15\xfc\x0e\x07\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\x02\x01\x10\xfc\x7c\xc2\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\x80\x81\x00\x88\x7e\x3e\xe1\x07\x30\x00\x01\x70\x21\x44\x05\xbf\xd3\x01\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\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\x08\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\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\x10\x08\x80\xe8\xff\x13\x7e\x00\x00\x00\x00\x00\x00\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\x0c\x04\x40\xf4\xf3\x09\x3f\x80\x01\x08\x80\x0b\x21\x2a\xf8\x9d\x0e\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\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\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\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\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\x08\x04\x40\xf5\xff\x09\x3f\x00\x00\x04\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\x01\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\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\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\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\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\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\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\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\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\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\x0c\x04\x40\xf4\xf3\x09\x3f\x80\x01\x08\x80\x0b\x21\x2a\xf8\x1d\x0e\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\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\xc0\x40\x00\x44\x3f\x9f\xf0\x03\x18\x80\x00\xb8\x10\xa2\x82\xdf\xe9\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\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\x0c\x04\x40\xf4\xf3\x09\x3f\x80\x01\x08\x80\x0b\x21\x2a\xf8\x9d\x0e\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\x06\x02\x20\xfa\xf9\x84\x1f\xc0\x00\x04\xc0\x85\x10\x15\xfc\x4e\x07\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\x80\x81\x00\x08\x7e\x3e\xe1\x07\x30\x00\x01\x70\x21\x44\x05\xbf\xc3\x01\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\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\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\x06\x02\x20\xfa\xf9\x84\x1f\xc0\x00\x04\xc0\x85\x10\x15\xfc\x4e\x07\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\xc0\xc1\x40\x44\xff\xbf\xf8\x03\x01\x00\x04\x78\x00\xa0\x0a\x67\xfe\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\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\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\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\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\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\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\x08\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\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\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\x0c\x04\x40\xf4\xf3\x09\x3f\x80\x01\x08\x80\x0b\x21\x2a\xf8\x9d\x0e\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\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\xc0\x40\x00\x44\x3f\x9f\xf0\x03\x18\x80\x80\xb8\x10\xa2\xc3\xdf\xe9\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\x10\x08\x80\xe0\xe7\x13\x7e\x00\x00\x00\x00\x00\x00\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\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\x60\x20\x00\xa2\x9f\x4f\xf8\x01\x0c\x40\x00\x5c\x08\x51\xc1\xef\x70\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x10\x08\x90\xea\xff\x93\x7e\x00\x00\x00\x00\x00\x00\x10\xc8\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\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\x02\x01\x52\xfd\x7f\xd2\x0f\x00\x00\x00\x00\x00\x00\x02\x99\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\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\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\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\x10\x08\x80\xe0\xe7\x13\x7e\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\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\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\x81\x00\x08\x0e\x3e\xe1\x07\x00\x00\x00\x00\x00\x00\x00\x1c\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\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\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\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\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\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\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\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\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"# - -{-# 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","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","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","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","PRIMFLOAT","PRIMDOUBLE","'[|'","'[p|'","'[t|'","'[d|'","'|]'","'[||'","'||]'","PREFIX_DOLLAR","PREFIX_DOLLAR_DOLLAR","TH_TY_QUOTE","TH_QUASIQUOTE","TH_QQUASIQUOTE","%eof"] - bit_start = st Prelude.* 479 - bit_end = (st Prelude.+ 1) Prelude.* 479 - read_bit = readArrayBit happyExpList - bits = Prelude.map read_bit [bit_start..bit_end Prelude.- 1] - bits_indexed = Prelude.zip bits [0..478] - token_strs_expected = Prelude.concatMap f bits_indexed - f (Prelude.False, _) = [] - f (Prelude.True, nr) = [token_strs Prelude.!! nr] - -happyActOffsets :: HappyAddr -happyActOffsets = HappyA# "\x1d\x00\x26\x00\x32\x00\x9d\x29\xcf\x1c\x86\x2c\x86\x2c\xcb\x23\x9d\x29\x8f\x48\x7c\x3f\x33\x00\x38\x00\x2c\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\x34\x15\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc0\x02\x00\x00\x00\x00\x00\x00\x60\x00\x00\x00\x06\x03\x06\x03\x00\x00\x6f\x00\xff\x00\xff\x00\xed\x44\x7c\x3f\x76\x00\xf9\x00\x21\x01\x00\x00\xbe\x18\x00\x00\xf9\x16\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x17\x00\x00\x27\x18\x00\x00\x00\x00\x00\x00\x00\x00\x27\x61\x00\x00\x00\x00\x00\x00\xba\x01\xcb\x01\x00\x00\x00\x00\x68\x45\x68\x45\x00\x00\x00\x00\x67\x60\xfb\x3d\x76\x3b\xf8\x3b\x5b\x4b\xf6\x48\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe1\x3a\x00\x00\x00\x00\xa5\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\x16\x02\x95\x09\x2f\x02\xf9\x4a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2b\x02\x55\x19\x00\x00\x86\x2c\xec\x19\x00\x00\x0c\x02\x00\x00\x00\x00\x00\x00\x3c\x02\x0d\x02\x00\x00\x00\x00\xcb\x15\x00\x00\x00\x00\x83\x02\x00\x00\x00\x00\x00\x00\x86\x2c\x73\x28\x83\x01\x54\x39\xb2\x03\x54\x39\x0b\x01\xc3\x31\x95\x37\x54\x39\x54\x39\x54\x39\xb4\x26\x4d\x20\xa1\x22\x54\x39\xce\x49\xb2\x03\xb2\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x86\x2c\x58\x32\x7c\x3f\xf9\x03\x86\x2c\xe1\x3a\x62\x16\x6f\x02\x00\x00\x8c\x02\x02\x05\xd7\x02\xf1\x02\x00\x00\x00\x00\x00\x00\x77\x04\xbb\x02\xfa\x49\x2c\x4c\x90\x4b\xbc\x4b\x2c\x4c\x93\x5e\x29\x03\x4d\x20\x00\x00\x94\x02\x94\x02\x94\x02\x00\x00\x00\x00\x00\x00\x00\x00\x36\x03\x5b\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x74\x05\xed\x44\xfa\x00\x1e\x03\x6a\x02\xd4\x04\x90\x03\xfc\x3c\x36\x02\xf0\x5e\x24\x03\x1c\x5f\x1c\x5f\x67\x5e\x4c\x03\x00\x00\x4c\x03\xae\x03\x63\x03\x71\x03\x63\x03\x00\x00\x00\x00\x71\x03\x00\x00\x9d\x03\x9f\x03\xfb\x02\x00\x00\x00\x00\x3e\x00\xfb\x02\xfd\x03\xd8\x03\x54\x39\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x54\x39\x46\x00\x4c\x06\xd0\x00\x00\x00\xe3\xff\xbb\x03\x22\x01\x00\x00\xe3\xff\x5c\x01\x00\x00\xed\x32\xbd\x01\x2e\x60\xf3\x03\xf7\xff\x13\x01\x00\x00\x29\x06\x29\x06\x09\x00\x00\x04\xad\x02\x38\x01\x00\x00\x7e\x42\xed\x44\xe8\x01\x7c\x3f\x25\x04\x31\x04\x46\x04\x50\x04\x00\x00\x76\x04\x00\x00\x00\x00\x00\x00\x7c\x3f\x7c\x3f\xed\x44\x14\x04\x6e\x04\x00\x00\x33\x04\x00\x00\x86\x2c\x00\x00\x00\x00\x7c\x3f\x0d\x3b\x67\x04\xed\x44\x47\x04\x7d\x04\x1b\x47\x1c\x01\x79\x01\x95\x04\x00\x00\x82\x33\x00\x00\x00\x00\x00\x00\xa1\x04\xa7\x04\xb2\x04\xb7\x04\x60\x24\x49\x27\x00\x00\x95\x37\xa4\x4d\x00\x00\x00\x00\x0d\x3b\x74\x04\xe3\x04\x84\x01\xdf\x04\x00\x00\x9a\x04\x00\x00\xc7\x04\x00\x00\x5f\x4c\x0a\x00\x2c\x4c\x00\x00\xfc\xff\x2c\x4c\x7c\x3f\xf5\x04\x5c\x4a\xd3\x04\x00\x00\x42\x05\xf5\x24\xf5\x24\x67\x60\x7c\x3f\x3c\x07\x00\x00\x00\x00\x00\x00\x00\x00\xfa\x04\xe0\x05\x28\x01\x00\x00\x00\x00\xc4\x04\xdd\x04\x00\x00\x00\x00\xe2\x04\x7f\x04\xe5\x04\x00\x00\x9d\x29\x9d\x29\x00\x00\x00\x00\x00\x00\xf9\x09\x00\x00\xac\x01\x09\x05\x00\x00\x00\x00\x8a\x25\x00\x00\x13\x05\x30\x01\x1d\x05\x1e\x05\x00\x00\x00\x00\x00\x00\x00\x00\x83\x1a\x00\x00\x54\x39\x40\x05\x7c\x04\xeb\x04\x58\x05\x66\x05\x00\x00\x00\x00\x6f\x05\xa7\x05\x48\x05\x42\x00\x00\x00\x00\x00\x1b\x2d\x81\x05\xb4\x05\x54\x39\xb0\x2d\xa4\x4d\xf9\x4b\x00\x00\x68\x45\x00\x00\x7c\x3f\xb0\x2d\xb0\x2d\xb0\x2d\xb0\x2d\x63\x05\x6b\x05\x28\x04\x75\x05\x7d\x05\x7a\x01\x85\x05\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7c\x3f\x79\x3d\x2f\x4b\x86\x05\x8a\x05\x7b\x01\x92\x05\x9b\x05\x54\x04\xf4\xff\x00\x00\xe9\x01\xe9\x39\x7a\x02\xa3\x05\x00\x00\x10\x02\x00\x00\x49\x01\xc0\x05\x00\x00\xb1\x05\x00\x00\x85\x02\x00\x00\xcd\x4a\x00\x00\x00\x00\x00\x00\x70\x01\x27\x61\x00\x00\x00\x00\x87\x61\x87\x61\x7c\x3f\x68\x45\x00\x00\xed\x44\x00\x00\x68\x45\xe9\x05\x7c\x3f\x7c\x3f\x68\x45\x7c\x3f\x7c\x3f\x00\x00\x00\x00\x43\x02\x00\x00\x56\x38\x3b\x00\x00\x00\xd4\x05\xfb\x02\xfb\x02\x00\x00\xe8\x05\xe3\xff\xe3\xff\xe8\x05\x00\x00\x00\x00\x57\x06\x00\x00\x00\x00\x00\x00\x00\x00\x3c\x06\x62\x06\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\x7c\x3f\x00\x00\x00\x00\x00\x00\x00\x00\x35\x06\xab\x01\x00\x00\x00\x00\x00\x00\x2d\x06\x67\x60\x00\x00\x7c\x3f\x67\x60\x00\x00\x7c\x3f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7c\x3f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7c\x3f\x7c\x3f\x00\x00\x00\x00\x49\x06\x3d\x06\x53\x06\x5f\x06\x64\x06\x6a\x06\x6e\x06\x70\x06\x72\x06\x5c\x06\x7c\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\x85\x06\x00\x00\x80\x06\xae\x06\xb1\x06\xb5\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x35\x05\x05\x00\xc6\x06\xac\x06\x00\x00\x00\x00\x00\x00\x0e\x07\x00\x00\xb0\x2d\xb0\x2d\x00\x00\x00\x00\x00\x00\x17\x34\xb0\x1b\x00\x00\x08\x29\x1a\x1b\xb0\x2d\x00\x00\xde\x27\x00\x00\xb0\x2d\x32\x2a\xde\x27\x00\x00\xc7\x06\x00\x00\x00\x00\x00\x00\x36\x23\xd6\x06\x00\x00\x2a\x38\x4e\x00\x00\x00\x87\x02\x00\x00\x00\x00\x00\x00\x00\x00\xcf\x1c\x3e\x00\xd9\x06\x00\x00\x00\x00\x00\x00\xd0\x06\x00\x00\xce\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x60\x00\x00\x00\x00\x4f\x01\x5a\x00\x00\x00\x00\x00\x7b\x0c\x00\x00\xe2\x20\x77\x21\x83\x00\x00\x00\x0c\x22\x8a\x02\xb0\x02\xbb\x02\x01\x07\x00\x00\x00\x00\x00\x00\x00\x00\x02\x07\xfd\x06\xc9\x06\x00\x00\x00\x00\xe4\x06\x06\x07\x00\x00\x0d\x07\xe9\x06\xeb\x06\x79\x5f\x79\x5f\x00\x00\x0f\x07\x70\x03\x8b\x03\xec\x06\xed\x06\x00\x00\x0b\x07\xf0\x06\xce\x10\x00\x00\x00\x00\xa4\x4d\x00\x00\xb0\x2d\xde\x27\x37\x00\xa1\x03\xfb\x42\x6c\x04\x00\x00\x00\x00\xb0\x2d\x00\x00\x00\x00\x30\x00\x00\x00\xb0\x2d\x45\x2e\xed\x44\x45\x07\x00\x00\x19\x07\xfa\x06\x00\x00\x00\x00\x21\x07\xd4\x04\x00\x00\x00\x00\x00\x00\x00\x00\x5a\x07\x2c\x00\x5d\x01\xdb\x03\x00\x00\x28\x07\x27\x61\x7c\x3f\x7c\x3f\xe8\x01\x94\x45\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xfd\x45\xa4\x4d\xfe\x06\x7c\x3f\x00\x00\xa4\x4d\x67\x60\xda\x2e\xda\x2e\xac\x34\x00\x00\x85\x00\x00\x00\xf5\x06\x00\x00\xf6\x06\x00\x00\x00\x00\xa5\x5f\xa5\x5f\x00\x00\x00\x00\xa5\x5f\x00\x00\x54\x39\x77\x02\x31\x07\x35\x07\x00\x00\x6c\x07\x00\x00\x1a\x07\x00\x00\x1a\x07\x00\x00\x00\x00\x7d\x07\x00\x00\x1d\x07\x00\x00\xcf\x1c\x72\x07\x65\x49\x78\x07\x12\x07\x00\x00\x00\x00\x00\x00\x29\x07\x4d\x07\x00\x00\x00\x00\x00\x00\x9c\x02\x00\x00\x00\x00\x8f\x00\x2e\x07\x41\x35\x93\x60\x80\x07\x00\x00\x37\x07\x2c\x07\x00\x00\x00\x00\x2d\x07\x00\x00\x29\x46\x00\x00\x4f\x07\x5b\x07\x5c\x07\x5d\x07\xc7\x60\x00\x00\x00\x00\x00\x00\x00\x00\x4a\x07\x7c\x3f\x5f\x07\x7c\x3f\x27\x61\x00\x00\x2c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x39\x05\x7c\x3f\x7c\x3f\x00\x00\x00\x00\x7c\x3f\x39\x07\x00\x00\x19\x4e\x00\x00\x6e\x05\x00\x00\x60\x07\x95\x07\x00\x00\x00\x00\x8f\x05\x00\x00\xec\x03\x62\x07\x00\x00\x27\x61\x99\x07\xae\x07\x7c\x3f\x9f\x07\x00\x00\x76\x07\x00\x00\x00\x00\x00\x00\x6a\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7c\x3f\x00\x00\x63\x07\x7c\x3f\x00\x00\x00\x00\x00\x00\x00\x00\x4b\x07\x00\x00\x1f\x26\xda\x2e\x00\x00\x00\x00\x7c\x3f\x3c\x07\x00\x00\x00\x00\x5e\x07\x00\x00\xc7\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe1\x01\x00\x00\x00\x00\x00\x00\x7d\x01\x00\x00\x00\x00\x6f\x2f\x00\x00\x00\x00\x00\x00\x00\x00\x0b\x03\x00\x00\x3e\x00\x64\x07\x00\x00\x5c\x2b\x66\x07\x00\x00\x0b\x03\x00\x00\x3e\x00\x65\x07\x00\x00\xbf\x38\x68\x07\x00\x00\x00\x00\x00\x00\x04\x30\x99\x30\x2e\x31\x00\x00\x00\x00\xa4\x4d\xde\x27\xf9\x4b\x00\x00\x00\x00\x7c\x3f\x00\x00\x00\x00\x7f\x07\x00\x00\x6b\x07\x67\x07\x00\x00\x00\x00\x00\x00\x00\x00\x7c\x3f\x00\x00\x7c\x3f\x00\x00\x31\x5e\x00\x00\x00\x00\x00\x00\xa1\x05\x00\x00\xc0\x07\x91\x07\x92\x07\xc3\x07\xab\x05\x00\x00\x00\x00\xab\x05\x00\x00\xda\x00\xda\x00\x00\x00\x71\x07\x7b\x07\x00\x00\x00\x00\x77\x07\x00\x00\x00\x00\x92\x01\x00\x00\x00\x00\x00\x00\x6d\x07\x00\x00\x00\x00\xd6\x35\x00\x00\x00\x00\xc9\x07\x9e\x07\x2e\x31\x00\x00\x00\x00\x2e\x31\x00\x00\x00\x00\xbe\x07\x64\x1d\xf1\x2b\xf1\x2b\x2e\x31\x00\x00\x83\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa3\x07\x84\x07\xac\x07\x00\x00\xaf\x07\x00\x00\xa6\x07\x00\x00\xed\x44\x27\x61\x00\x00\x00\x00\xf1\x07\x00\x00\xb2\x01\xf1\x07\xae\x05\x9a\x07\xed\x44\xe2\x07\xf6\x07\x00\x00\x00\x00\x2e\x31\x00\x00\xf9\x1d\xf9\x1d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x8e\x1e\x8e\x1e\x00\x00\x00\x00\x00\x00\xe3\x07\x87\x61\x00\x00\xed\x44\xba\x07\x7c\x3f\x00\x00\x00\x00\xc7\x60\x00\x00\x00\x00\xb7\x05\xa9\x07\xf3\x60\x00\x00\xa4\x4d\xf2\x0c\x00\x00\x00\x00\xa2\x07\x00\x00\x8b\x07\x00\x00\x00\x00\x58\x04\x00\x00\xba\x05\xa7\x07\x9c\x07\x00\x00\xa4\x07\x00\x00\x00\x00\x00\x00\x00\x00\x58\x04\xe8\x01\x8b\x03\xed\x07\x00\x00\xba\x05\xa5\x07\x00\x00\xab\x07\x00\x00\xab\x07\x00\x00\x00\x00\x00\x00\xb3\x07\xb5\x07\xbb\x07\x00\x00\x00\x00\x00\x00\x00\x00\x8f\x4a\x91\x49\x00\x00\x00\x00\x12\x08\x00\x00\x00\x00\x2e\x31\xde\x07\x00\x00\x6b\x36\x1f\x26\x1f\x26\x00\x00\x00\x00\x7c\x3f\xe0\x07\x00\x00\xdb\x07\x00\x00\x03\x06\x00\x00\x26\x08\x00\x00\x36\x01\x00\x00\x00\x00\x00\x00\x26\x08\xb9\x02\x00\x00\x87\x61\x00\x00\x00\x00\x3e\x01\x00\x00\x17\x08\x00\x37\x7d\x3e\xd9\x02\x00\x00\x00\x00\x32\x08\x00\x00\xed\x44\x10\x04\x10\x04\x00\x00\xa2\x02\x09\x08\x00\x00\x00\x00\x00\x00\x00\x00\xfa\x3e\x00\x00\xdc\x07\xe7\x07\x00\x00\xf5\x07\x00\x00\x36\x08\x00\x00\x00\x00\x7c\x3f\x00\x00\x00\x00\x00\x00\x00\x00\x2e\x31\x2e\x31\x2e\x31\x00\x00\x00\x00\x00\x00\x00\x00\x4a\x08\xde\x27\xa4\x4d\x00\x00\x00\x00\x00\x00\x56\x01\x00\x00\x18\x08\x58\x04\xeb\x38\xf7\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xda\x00\xe9\x07\xee\x07\x80\x39\x7a\x04\x58\x04\x00\x00\x00\x00\x00\x00\x2e\x31\x00\x00\x00\x00\x29\x08\x00\x00\x00\x00\xed\x44\x00\x00\xea\x07\xf7\x07\x00\x00\x00\x00\x00\x00\x3e\x00\xfc\x07\xbb\x02\x00\x08\x0c\x08\x00\x00\x00\x00\x00\x00\x23\x1f\x00\x00\xa3\x04\x78\x43\xed\x44\x8d\x0d\xed\x44\x00\x00\x00\x00\x00\x00\xb8\x1f\x78\x43\x00\x00\x00\x00\x24\x08\x00\x00\xfe\x3f\x7b\x40\x87\x61\xf8\x40\x00\x00\x5a\x01\x12\x03\xf3\x60\xf8\x40\x00\x00\x6b\x08\x00\x00\x05\x08\x01\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3e\x00\x0f\x08\x00\x00\x00\x00\x8f\x4a\x00\x00\x22\x00\x58\x04\x06\x08\x16\x08\x00\x00\x00\x00\x00\x00\x87\x61\x00\x00\x60\x01\x00\x00\x3e\x00\x6d\x03\x13\x08\xf5\x43\x00\x00\x00\x00\x2c\x08\xf8\x40\xa8\x04\x00\x00\x00\x00\xf8\x40\x7a\x41\x00\x00\xed\x44\x00\x00\x2f\x08\x10\x04\x00\x00\x00\x00\xfc\x41\x00\x00\x00\x00\x2e\x31\x00\x00\xca\x04\x14\x08\x00\x00\x58\x04\x00\x00\x58\x04\x00\x00\xed\x02\x00\x00\x7b\x08\xa8\x02\x00\x00\x68\x00\x67\x08\x1d\x08\x00\x00\x00\x00\x00\x00\xfc\x41\x00\x00\x30\x08\x46\x1c\x7a\x3c\x00\x00\x00\x00\x53\x61\x00\x00\x00\x00\x0e\x05\x00\x00\x00\x00\x72\x44\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x21\x08\x65\x49\x00\x00\x23\x08\x65\x49\x00\x00\x77\x08\x89\x08\x64\x3a\x87\x61\x00\x00\x82\x08\x07\x06\x43\x34\x58\x04\x00\x00\x58\x04\x58\x04\x00\x00\x58\x04\x00\x00\x00\x00\x00\x00\x28\x08\x57\x08\x00\x00\x58\x04\x00\x00\x07\x06\x00\x00\x00\x00\x8c\x08\x37\x08\x00\x00\x00\x00\x00\x00\x00\x00\x2d\x08\x58\x04\x00\x00\x00\x00\x00\x00\x00\x00"# - -happyGotoOffsets :: HappyAddr -happyGotoOffsets = HappyA# "\x5b\x04\x92\x08\x78\x08\x4b\x52\xcc\x01\xeb\x55\x19\x55\xdc\x04\x93\x52\x01\x00\xec\x0d\x95\x01\x80\x03\xf6\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\x25\x05\x00\x00\x00\x00\x3d\x02\x00\x00\x00\x00\x79\x07\x7c\x07\x40\x02\x00\x00\x5d\x05\x78\x05\xd2\x13\xc2\x10\x00\x00\x00\x00\x00\x00\x00\x00\x19\x08\x00\x00\x23\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\x3c\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1d\x03\x4b\x04\x00\x00\x00\x00\x00\x01\x24\x0e\x4b\x08\xf4\x07\x72\x02\x04\x0f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc3\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\x85\x03\x7a\x07\x6f\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x49\x08\x00\x00\x31\x56\xb7\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\x77\x56\xfd\x53\x73\x05\xf0\x62\xc2\x07\x01\x63\x00\x00\xf5\x61\x6d\x62\x3a\x63\x73\x63\x84\x63\xd4\x4d\x75\x4c\x5f\x4d\xbd\x63\x04\x07\xc4\x07\xc6\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbd\x56\x03\x61\x58\x0e\xdf\x07\x03\x57\xf1\x64\xd0\x04\x74\x08\x00\x00\x00\x00\x49\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbd\x05\x43\x01\x77\x05\xed\x03\x7b\x05\x9c\x05\x1c\x04\x97\x0c\x73\x02\xea\x4c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x54\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x52\x01\xa8\x05\x00\x00\x00\x00\x16\x06\x6c\x08\x00\x00\xa4\x01\x2e\x08\xa4\xff\x15\x06\x45\x01\xb4\xff\x6b\x02\x00\x00\x00\x00\x00\x00\x84\x08\x00\x00\x88\x07\x00\x00\x91\x00\x00\x00\x89\x07\xa1\x00\x00\x00\xb6\x02\xa0\x08\x00\x00\x00\x00\x8e\x07\xaa\x08\x9b\x08\x00\x00\xf6\x63\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x07\x64\xca\x02\x10\x03\x00\x00\x00\x00\x4c\x08\x00\x00\x00\x00\x00\x00\x4f\x08\x00\x00\x00\x00\x0b\x06\x00\x00\xab\xff\x00\x00\x3f\xff\xad\x03\x00\x00\x4d\x08\x51\x08\x00\x00\x00\x00\x3d\x08\x00\x00\x00\x00\x38\x03\x75\x12\xa4\x03\xec\x09\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x54\x09\x4e\x0c\xb9\x12\x31\x08\x00\x00\x00\x00\x43\x04\x00\x00\xec\x4b\x00\x00\x00\x00\xf1\x0a\x6f\x04\x7c\x08\x52\x07\x00\x00\x00\x00\x54\x0a\x00\x00\x59\xff\x00\x00\x00\x00\x14\x61\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x43\x4e\x21\x4f\x00\x00\x6d\x62\x45\x03\x00\x00\x00\x00\x9f\x04\x00\x00\x4e\x08\x77\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xcb\x07\x00\x00\x8e\x04\x00\x00\x6f\x08\xe0\x04\xff\x09\x00\x00\xc2\xff\x00\x00\x00\x00\x00\x00\x57\x03\xa0\x03\x9f\xff\x04\x0b\xf0\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc4\x00\x57\x05\x00\x00\x00\x00\x00\x00\x00\x00\xe1\xff\xfd\xff\x00\x00\xab\x0a\x00\x00\x00\x00\xdb\x52\x23\x53\x00\x00\x00\x00\x00\x00\x85\x03\x11\x08\x59\xff\x00\x00\x00\x00\x00\x00\x43\x4e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x64\x00\x00\x06\x62\x00\x00\xb1\x07\xb8\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x27\x08\x57\xff\x00\x00\x00\x00\x6a\x53\xf7\x05\x00\x00\x79\x64\x49\x57\xb0\x03\xd4\x02\x00\x00\x5e\x04\x00\x00\x06\x11\x8f\x57\xd5\x57\x1b\x58\x61\x58\x00\x00\x00\x00\x00\x00\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\x0c\x07\x08\x8d\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\xe7\x02\x00\x00\xed\x05\x00\x00\x00\x00\x00\x00\x00\x00\x67\x01\x00\x00\x00\x00\x2d\x02\xa0\x02\x19\x11\xfe\x05\x00\x00\x16\x14\x00\x00\xe5\x06\x00\x00\x5d\x11\x70\x11\xf8\x06\xb4\x11\x79\x0e\x00\x00\x00\x00\x00\x00\x00\x00\x18\x00\xc1\x07\x00\x00\xac\x02\xd5\x08\xdb\x08\x00\x00\xd3\x08\x75\x08\x76\x08\xd7\x08\x00\x00\x00\x00\xcb\x08\x00\x00\x00\x00\x00\x00\x00\x00\xfa\x08\x00\x00\xf9\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\xc7\x11\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x54\x01\x00\x00\x0b\x12\x27\x02\x00\x00\xb5\x0c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe9\x0c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x50\x0d\x84\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd3\x07\x25\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa7\x58\xed\x58\x00\x00\x00\x00\x00\x00\x0a\x47\xc3\x46\x00\x00\xee\x45\xa4\x45\x33\x59\x00\x00\x90\x4f\x00\x00\x79\x59\xbb\x51\xff\x4f\x00\x00\x60\xff\x00\x00\x00\x00\x00\x00\xb2\x4e\x00\x00\x00\x00\x7e\x62\xda\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x66\x02\xdd\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\xd6\x02\x00\x00\x00\x00\x00\x00\xe5\x07\x00\x00\x00\x00\x52\x01\x00\x00\x00\x00\x00\x00\xec\x07\x00\x00\x00\x00\x00\x00\x00\x00\x9f\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\x55\x07\x2a\x09\x00\x00\x00\x00\x87\x05\x99\x03\x00\x00\x00\x00\x00\x00\x62\x05\x00\x00\xab\x0a\x00\x00\x00\x00\xd4\x03\x00\x00\xec\x4b\x6e\x50\x00\x00\xdd\xff\x0a\x01\x00\x00\x00\x00\x00\x00\x2f\x4c\x00\x00\x00\x00\xd6\xff\x00\x00\xbf\x59\xb1\x53\xcc\x12\x9c\x08\xe6\x04\xb4\x08\x00\x00\x00\x00\x00\x00\x00\x00\xd6\x08\x00\x00\x00\x00\x00\x00\x00\x00\xac\x08\x6d\x05\x97\x05\xc2\x08\x00\x00\x00\x00\xe5\x01\x8c\x0e\xa7\x09\x3e\x04\x8e\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf6\xff\x86\x02\xfb\x07\x48\x0b\x00\x00\xc3\xff\xd1\xff\x5f\x55\xa5\x55\xa3\x08\x00\x00\xa6\x08\x00\x00\xaf\x08\x00\x00\xa4\x08\x00\x00\x00\x00\xbc\x00\x42\x06\x00\x00\x00\x00\x8e\x00\x00\x00\x8a\x64\x1a\x08\x00\x00\x00\x00\x00\x00\xf4\x08\x00\x00\x07\x09\x00\x00\x0d\x09\x00\x00\x00\x00\xd3\x02\x00\x00\x04\x09\x00\x00\x32\x01\x00\x00\x24\x00\x00\x00\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\x7f\x61\xe4\xff\xcd\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x55\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc0\x0e\xeb\x08\x29\x0f\x94\x00\x00\x00\xe2\x08\x00\x00\x00\x00\x00\x00\x00\x00\xc7\x08\x43\x0a\x58\x0f\x00\x00\x00\x00\x7a\x0f\x00\x00\x00\x00\xaf\x02\x00\x00\xcc\x08\x00\x00\x00\x00\xc4\x08\x00\x00\x00\x00\x23\x06\x00\x00\xe5\xff\x00\x00\x00\x00\x33\x02\x9e\x08\xc5\x05\xc1\x0f\xee\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\x00\x00\x00\x00\x56\x0a\x00\x00\x00\x00\x9a\x0a\x00\x00\x00\x00\x00\x00\x00\x00\x11\x06\x00\x00\x65\x06\x05\x5a\x00\x00\x00\x00\x5b\x0b\x20\x05\x00\x00\x00\x00\x1c\x09\x00\x00\x45\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\x4b\x5a\x00\x00\x00\x00\x00\x00\x00\x00\xa2\x04\x00\x00\x1c\x08\x00\x00\x00\x00\x37\x46\x00\x00\x00\x00\xc2\x05\x00\x00\x1e\x08\x00\x00\x00\x00\x50\x47\x00\x00\x00\x00\x00\x00\x00\x00\x91\x5a\xd3\x54\xd7\x5a\x00\x00\x00\x00\x5e\x00\xdd\x50\x9a\x01\x00\x00\x00\x00\x97\x0d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x07\x10\x00\x00\x2a\x10\x00\x00\x19\x00\x00\x00\x00\x00\x00\x00\x39\x09\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2e\x09\x00\x00\x00\x00\x2f\x09\x00\x00\x99\x06\xcf\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\x8a\x08\x00\x00\x00\x00\x7f\x47\x00\x00\x00\x00\xd9\x08\x6e\x08\x1d\x5b\x00\x00\x00\x00\x80\x46\x00\x00\x00\x00\x00\x00\x00\x00\x02\x52\x8c\x54\x63\x5b\x00\x00\x00\x00\x00\x00\x00\x00\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\x03\x63\x02\x00\x00\x00\x00\x9d\x08\x00\x00\xc8\xff\x06\x06\x00\x00\x00\x00\x10\x13\xa9\x08\x3a\x06\x00\x00\x00\x00\xa9\x5b\x00\x00\x21\x04\x6a\x04\x00\x00\xb5\x08\x84\x06\x00\x00\x00\x00\x00\x00\x00\x00\xd3\xff\xe1\x02\x00\x00\x00\x00\x00\x00\x09\x09\xbe\xff\x00\x00\x23\x13\x00\x00\x9f\x0b\x00\x00\x00\x00\xd8\xff\x00\x00\x00\x00\x00\x00\x00\x00\xeb\xff\x00\x00\xab\x02\xab\x0a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x33\x08\x00\x00\x45\x09\x00\x00\x00\x00\x00\x00\x3c\x09\x00\x00\x00\x00\x00\x00\x00\x00\x35\x08\x66\x04\x50\x03\xd1\x05\x00\x00\x4e\x09\x3d\x09\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x13\x02\x1e\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x50\x00\x44\x00\x00\x00\x00\x00\x34\x09\x00\x00\x00\x00\xef\x5b\x00\x00\x00\x00\x00\x00\xaa\x05\x1c\x06\x00\x00\x00\x00\xb2\x0b\x00\x00\x00\x00\x00\x00\x00\x00\x21\x09\x00\x00\x1f\x09\x00\x00\x48\x08\x00\x00\x00\x00\x00\x00\x23\x09\x00\x00\x00\x00\xaf\x02\x00\x00\x00\x00\x50\x08\x00\x00\x25\x09\x90\x61\x63\x06\x00\x00\x00\x00\x00\x00\x4b\x06\x00\x00\x62\x12\x58\x01\xa2\x01\x00\x00\x79\xff\x31\x09\x00\x00\x00\x00\x00\x00\x00\x00\xf0\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x86\x06\x00\x00\x00\x00\xad\x0a\x00\x00\x00\x00\x00\x00\x00\x00\x35\x5c\x7b\x5c\xc1\x5c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4c\x51\x0f\x04\x00\x00\x00\x00\x00\x00\x58\x08\x00\x00\x4d\x09\x53\x08\x0e\x00\x00\x00\x00\x00\x58\x02\xa6\x02\x00\x00\x00\x00\x00\x00\x00\x00\x76\x09\x7e\x09\x00\x00\x14\x00\x77\x09\x60\x08\x00\x00\x00\x00\x00\x00\x07\x5d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x63\x08\x00\x00\x08\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x61\x05\x00\x00\x37\x09\xba\x06\x67\x13\xab\x0a\x7a\x13\x00\x00\x00\x00\x00\x00\xef\x04\x0c\x07\x00\x00\x00\x00\x35\x09\x00\x00\x48\x02\xa7\x02\xc1\xff\x5e\x10\x00\x00\x66\x08\x00\x00\xf9\xff\x1e\x12\x00\x00\x5f\x09\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x68\x08\x00\x00\x00\x00\x00\x00\x48\x00\x00\x00\x00\x07\x69\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc7\x02\x00\x00\x70\x08\x00\x00\x7e\x08\x00\x00\x00\x00\xb0\x07\x00\x00\x00\x00\x3e\x09\xf6\x0b\x3f\x09\x00\x00\x00\x00\x71\x10\xb8\x0d\x00\x00\xbe\x13\x00\x00\x00\x00\xe7\x01\x00\x00\x00\x00\x0f\x09\x00\x00\x00\x00\x4d\x5d\x00\x00\x80\x09\x7a\x09\x00\x00\xff\xff\x00\x00\xf5\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x82\x09\x00\x00\x00\x00\x00\x00\x09\x0c\x00\x00\x00\x00\x00\x00\xab\x08\x00\x00\x00\x00\x7d\xff\x00\x00\x00\x00\x03\x00\x00\x00\x00\x00\x27\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2e\x00\x00\x00\x00\x00\x3a\x00\x00\x00\xff\x08\x4e\x06\x00\x00\xc0\xff\x00\x00\x00\x00\x94\x09\x08\x00\x80\x08\x00\x00\x02\x00\x81\x08\x00\x00\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x83\x08\x00\x00\x99\x09\x00\x00\x00\x00\x5a\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x85\x08\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\x8b\xfd\x00\x00\x00\x00\xbf\xff\xc0\xff\x00\x00\xf2\xff\x18\xfd\x14\xfd\x11\xfd\x01\xfd\xff\xfc\x00\xfd\x0d\xfd\xfe\xfc\xfd\xfc\xfc\xfc\x0f\xfd\x0e\xfd\x10\xfd\x0c\xfd\x0b\xfd\xfb\xfc\xfa\xfc\xf9\xfc\xf8\xfc\xf7\xfc\xf6\xfc\xf5\xfc\xf4\xfc\xf3\xfc\xf2\xfc\xf0\xfc\xf1\xfc\x00\x00\x12\xfd\x13\xfd\x8f\xff\x00\x00\xb1\xff\x00\x00\x00\x00\x8f\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x98\xfe\x00\x00\x93\xfe\x91\xfe\x8c\xfe\x8b\xfe\x87\xfe\x88\xfe\x71\xfe\x70\xfe\x00\x00\x7e\xfe\x4c\xfd\x82\xfe\x46\xfd\x3d\xfd\x40\xfd\x39\xfd\x7d\xfe\x81\xfe\x21\xfd\x1e\xfd\x67\xfe\x5c\xfe\x1c\xfd\x1b\xfd\x1d\xfd\x00\x00\x00\x00\x36\xfd\x35\xfd\x00\x00\x00\x00\x7c\xfe\x34\xfd\x3f\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1f\xfd\x3c\xfd\x37\xfd\x38\xfd\x3e\xfd\x3a\xfd\x3b\xfd\x75\xfd\x69\xfe\x68\xfe\x6a\xfe\x00\x00\x15\xfe\x14\xfe\x00\x00\xf1\xff\x64\xfd\x55\xfd\x63\xfd\xef\xff\xf0\xff\x25\xfd\x09\xfd\x0a\xfd\x05\xfd\x02\xfd\x62\xfd\xed\xfc\x51\xfd\xea\xfc\xe7\xfc\xed\xff\x04\xfd\xee\xfc\xef\xfc\x00\x00\x00\x00\x00\x00\x00\x00\xeb\xfc\x03\xfd\xe8\xfc\xec\xfc\x06\xfd\xe9\xfc\xd2\xfd\x86\xfd\x0e\xfe\x0c\xfe\x00\x00\x07\xfe\xff\xfd\xf0\xfd\xed\xfd\xde\xfd\xdd\xfd\x00\x00\x00\x00\x8c\xfd\x89\xfd\xea\xfd\xe9\xfd\xeb\xfd\xec\xfd\xe8\xfd\x0d\xfe\xdf\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x93\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x74\xfd\xe6\xfc\xe5\xfc\xe7\xfd\xe6\xfd\xe2\xfc\xe1\xfc\xe4\xfc\xe3\xfc\xe0\xfc\xdf\xfc\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd8\xfd\x7c\xff\x23\xfe\x00\x00\x00\x00\x00\x00\x14\xfd\x7a\xff\x79\xff\x78\xff\x00\x00\x00\x00\x19\xfe\x00\x00\x19\xfe\x19\xfe\x00\x00\x72\xfd\x00\x00\x00\x00\x98\xfd\x00\x00\x00\x00\x00\x00\x6e\xff\x6d\xff\x6c\xff\x6b\xff\x11\xff\x00\x00\x6a\xff\x69\xff\x2e\xfe\x63\xff\x62\xff\x30\xfe\x61\xff\x00\x00\x28\xff\x00\x00\x46\xff\x4f\xff\x27\xff\x00\x00\x00\x00\x00\x00\xd6\xfe\xbe\xfe\xc3\xfe\x00\x00\x00\x00\x8a\xfd\x00\x00\x89\xff\x00\x00\x00\x00\x00\x00\x8f\xff\xc1\xff\x00\x00\x8f\xff\x00\x00\x8c\xff\xbc\xff\xdc\xfc\xdb\xfc\x00\x00\xbc\xff\x87\xff\x00\x00\x00\x00\x67\xfd\x5e\xfd\x68\xfd\x1a\xfd\x60\xfd\x00\x00\x00\x00\x00\x00\x00\x00\xc4\xfe\x00\x00\x6a\xfd\x00\x00\xbf\xfe\x00\x00\x00\x00\xd7\xfe\xd4\xfe\x00\x00\x5d\xfd\x00\x00\x00\x00\x00\x00\x67\xff\x00\x00\x00\x00\x00\x00\x00\x00\x91\xfe\x4c\xfd\x26\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x47\xff\x00\x00\x48\xff\x4a\xff\x49\xff\x00\x00\x62\xfe\x00\x00\x56\xfe\x00\x00\x18\xff\x00\x00\x2b\xfd\x00\x00\x2a\xfd\x2c\xfd\x00\x00\x00\x00\x11\xff\x00\x00\x00\x00\xc3\xfd\x0e\xfe\x00\x00\x00\x00\x00\x00\x28\xfd\x00\x00\x27\xfd\x29\xfd\x23\xfd\x07\xfd\x00\x00\x08\xfd\x51\xfd\x00\x00\x00\x00\xd5\xfc\x04\xfd\x00\x00\x59\xfd\xd9\xfc\x00\x00\x5b\xfd\xa5\xfe\x00\x00\x00\x00\x73\xfd\x71\xfd\x6f\xfd\x6e\xfd\x6b\xfd\x00\x00\x00\x00\x00\x00\x18\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5d\xfd\xde\xfe\x00\x00\xe1\xfe\xe1\xfe\x00\x00\x00\x00\x00\x00\x7b\xff\xd9\xfd\x4f\xfd\xda\xfd\x00\x00\x00\x00\x00\x00\xcb\xfd\xec\xfd\x00\x00\x00\x00\x73\xff\x73\xff\x00\x00\x00\x00\x00\x00\xf2\xfd\x8d\xfd\x8d\xfd\xf3\xfd\xdb\xfd\xdc\xfd\x00\x00\xc9\xfd\x00\x00\x00\x00\x07\xfd\x08\xfd\x00\x00\x57\xfd\x00\x00\xb7\xfd\x00\x00\xb6\xfd\x54\xfd\xfb\xfd\xfc\xfd\xfd\xfd\x08\xfe\x95\xfd\x93\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xfe\x88\xfd\x00\x00\x85\xfd\x05\xfe\x00\x00\xf5\xfd\x9c\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x83\xfd\x02\xfe\x00\x00\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\xcc\xfd\x6f\xfe\x66\xfd\x65\xfd\x80\xfe\x7f\xfe\x6c\xfe\x2e\xfd\x62\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x61\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x76\xfe\x00\x00\x40\xfd\x00\x00\x00\x00\x78\xfe\x00\x00\x47\xfd\x00\x00\x00\x00\x3e\xfe\x3c\xfe\x9f\xfe\x00\x00\x7a\xfe\x00\x00\x7b\xfe\x9b\xfe\x9c\xfe\x00\x00\x5c\xfe\x5b\xfe\x58\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x86\xfe\x00\x00\x84\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x96\xfe\x89\xfe\x00\x00\xe8\xff\x00\x00\x00\x00\xae\xff\x8c\xff\xbc\xff\xbc\xff\xad\xff\xa8\xff\x00\x00\x00\x00\xa8\xff\xac\xff\xaa\xff\xab\xff\x90\xff\xec\xff\xdd\xfc\xde\xfc\xe9\xff\x00\x00\xd5\xff\xdc\xff\xd9\xff\xdb\xff\xda\xff\xdd\xff\xeb\xff\x4f\xfe\x97\xfe\x95\xfe\x8d\xfe\x8e\xfe\x90\xfe\x00\x00\x85\xfe\x8a\xfe\x83\xfe\x94\xfe\x00\x00\x00\x00\x5d\xfe\x99\xfe\x9a\xfe\x00\x00\x00\x00\x79\xfe\x00\x00\x00\x00\x73\xfe\x00\x00\x48\xfd\x4b\xfd\xda\xfc\x45\xfd\x72\xfe\x00\x00\xd6\xfc\x49\xfd\x4a\xfd\x74\xfe\x75\xfe\x00\x00\x00\x00\x20\xfd\x3f\xfd\x00\x00\x00\x00\x36\xfd\x35\xfd\x7c\xfe\x34\xfd\x37\xfd\x38\xfd\x3b\xfd\x61\xfe\x00\x00\x63\xfe\xee\xff\x58\xfd\x61\xfd\x16\xfd\x56\xfd\x50\xfd\x24\xfd\x0f\xfe\x10\xfe\x11\xfe\x12\xfe\x13\xfe\x01\xfe\x00\x00\x84\xfd\x81\xfd\x7e\xfd\x00\x00\x14\xfd\x80\xfd\xee\xfd\x15\xfd\x87\xfd\xfe\xfd\x00\x00\x00\x00\x00\x00\xa3\xfd\xa1\xfd\x9d\xfd\x9a\xfd\x00\x00\x06\xfe\x00\x00\x00\x00\x04\xfe\x03\xfe\xf7\xfd\x93\xfd\x00\x00\xf8\xfd\x00\x00\x00\x00\x00\x00\x94\xfd\x00\x00\xe0\xfd\xb5\xfd\x00\x00\x00\x00\x17\xfd\xb9\xfd\xbe\xfd\xe1\xfd\xbf\xfd\xb8\xfd\xbd\xfd\xe2\xfd\x00\x00\x00\x00\x8e\xfd\x00\x00\xd7\xfd\xd4\xfd\xd5\xfd\xc4\xfd\xc5\xfd\x00\x00\x00\x00\xd3\xfd\xd6\xfd\x4d\xfd\x00\x00\x4e\xfd\x24\xfe\x30\xfd\x76\xff\x31\xfd\x53\xfd\x2f\xfd\x00\x00\x26\xfe\xa1\xfe\x00\x00\x00\x00\x2d\xfe\xe2\xfe\xa7\xfe\x2c\xfe\xce\xfd\xcd\xfd\x00\x00\x77\xfd\xea\xfd\x00\x00\x00\x00\x00\x00\x00\x00\xfa\xfe\xfb\xfe\x20\xfe\x66\xfe\x00\x00\x00\x00\x00\x00\xd2\xfe\xd1\xfe\x00\x00\x00\x00\x1f\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1a\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xcf\xfd\xd7\xfc\x17\xfd\xc1\xfd\xe4\xfd\xe5\xfd\x00\x00\xe3\xfd\xc2\xfd\x00\x00\x00\x00\x23\xff\x00\x00\xa1\xfe\x0b\xfe\x0a\xfe\x00\x00\x09\xfe\x2f\xfe\xda\xfe\x28\xfe\x00\x00\x00\x00\x00\x00\xef\xfe\x51\xfe\x21\xff\x00\x00\x4b\xff\xa3\xfe\xa1\xfe\x4f\xff\x50\xff\x51\xff\x53\xff\x52\xff\xe5\xfe\x0e\xff\x00\x00\x1f\xff\x56\xff\x00\x00\x5c\xfe\x00\x00\x00\x00\x00\x00\x00\x00\xb1\xfe\xb0\xfe\xaf\xfe\xae\xfe\xad\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x05\xff\x02\xff\x00\x00\x00\x00\x00\x00\xcb\xfe\xd3\xfe\x00\x00\x64\xff\xd8\xfe\xbd\xfe\xb8\xfe\xbc\xfe\x66\xff\xc0\xfe\x00\x00\xc2\xfe\x65\xff\xc5\xfe\x33\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x8a\xff\x83\xff\x88\xff\xa8\xff\xb8\xff\xa8\xff\xb7\xff\xb4\xff\x70\xff\xb9\xff\x8e\xff\xb5\xff\xb6\xff\x00\x00\xa6\xff\x00\x00\x85\xff\x84\xff\xb7\xfe\xb5\xfe\x00\x00\x00\x00\xc6\xfe\x69\xfd\xc1\xfe\x00\x00\xb9\xfe\xd9\xfe\x00\x00\x00\x00\x00\x00\xc9\xfe\x07\xff\x08\xff\x00\x00\x00\xff\x01\xff\xfc\xfe\x00\x00\x04\xff\x00\x00\xb3\xfe\x00\x00\xab\xfe\xaa\xfe\xac\xfe\x00\x00\xb2\xfe\x59\xff\x5a\xff\x5f\xff\x00\x00\x00\x00\x45\xff\x00\x00\x00\x00\x0f\xff\x0d\xff\x0c\xff\x09\xff\x0a\xff\x57\xff\x00\x00\x00\x00\x00\x00\x68\xff\x5b\xff\x00\x00\x55\xfe\x53\xfe\x00\x00\x60\xff\x00\x00\x19\xff\x00\x00\xda\xfe\x2a\xfe\x29\xfe\x00\x00\xcb\xfc\x23\xff\x00\x00\x14\xff\x5c\xfe\x4c\xfe\x3a\xfe\x00\x00\x41\xfe\x12\xff\x00\x00\xc0\xfd\xd0\xfd\xbc\xfd\xd8\xfc\x26\xfd\x22\xfd\x5a\xfd\xa4\xfe\x22\xfe\x70\xfd\x6d\xfd\x5f\xfd\x6c\xfd\x1e\xfe\x00\x00\x17\xfe\x00\x00\x00\x00\x1b\xfe\x21\xfe\x5c\xfd\xdd\xfe\x78\xfd\xe0\xfe\xe3\xfe\x00\x00\xdc\xfe\xdf\xfe\x00\x00\x00\x00\xc7\xfd\xc6\xfd\x75\xff\x92\xfd\x8f\xfd\x91\xfd\xc8\xfd\xca\xfd\xd1\xfd\xbb\xfd\xba\xfd\xc3\xfd\xaf\xfd\xb1\xfd\xae\xfd\xac\xfd\xa9\xfd\xa8\xfd\x00\x00\xb3\xfd\xb0\xfd\xfa\xfd\x97\xfd\x00\x00\xcd\xfc\x00\x00\xc8\xfc\xc1\xfc\x00\x00\x00\x00\xce\xfc\x00\x00\xd1\xfc\x00\x00\xca\xfc\xc4\xfc\x93\xfd\x00\x00\xd2\xfc\xf1\xfd\xf9\xfd\x00\x00\x00\x00\x00\x00\x9b\xfd\xf4\xfd\x00\x00\x00\x00\x00\x00\xef\xfd\x6d\xfe\x00\x00\x2d\xfd\x60\xfe\x5f\xfe\x5e\xfe\x00\x00\x00\x00\xa0\xfe\x3b\xfe\x3d\xfe\x19\xfd\x00\x00\x5a\xfe\x00\x00\x8f\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\xbd\xff\x00\x00\xe7\xff\x00\x00\x00\x00\xd4\xff\x00\x00\x00\x00\x6b\xfe\x77\xfe\x00\x00\x82\xfd\x7f\xfd\x7c\xfd\x7a\xfd\x99\xfd\xa2\xfd\x05\xfe\xd4\xfc\xc9\xfc\xc5\xfc\xd3\xfc\xc0\xfc\xda\xfe\x9e\xfd\x00\x00\xd0\xfc\xc7\xfc\xc2\xfc\xcf\xfc\xbf\xfc\xa7\xfd\xf6\xfc\x00\x00\x00\x00\xb4\xfd\x90\xfd\x74\xff\x91\xff\x77\xff\x25\xfe\x76\xfd\xe4\xfe\x79\xfd\x00\x00\x9e\xfe\x00\x00\x16\xfe\x00\x00\x13\xff\x47\xfe\x45\xfe\x00\x00\x5c\xfe\x22\xff\x5d\xff\x39\xfe\x37\xfe\x00\x00\x3a\xfe\x00\x00\x00\x00\x00\x00\x4c\xfe\x3a\xfe\xdb\xfe\x2b\xfe\x00\x00\xf0\xfe\xf3\xfe\xf3\xfe\x50\xfe\x51\xfe\x51\xfe\x20\xff\xa2\xfe\x10\xff\xe6\xfe\xe9\xfe\xe9\xfe\x0b\xff\x1d\xff\x1e\xff\x40\xff\x00\x00\x35\xff\x00\x00\x00\x00\x00\x00\xb4\xfe\x52\xfd\x00\x00\x03\xff\x06\xff\x00\x00\x00\x00\xc9\xfe\xc8\xfe\x00\x00\x00\x00\xd0\xfe\xce\xfe\x00\x00\xbb\xfe\x00\x00\xb6\xfe\x32\xfd\x00\x00\x86\xff\x00\x00\x00\x00\xa7\xff\xa2\xff\x9e\xff\x96\xff\x93\xff\x44\xfd\x94\xff\x00\x00\x00\x00\x00\x00\x00\x00\xa4\xff\x00\x00\x72\xff\x6f\xff\x8d\xff\x92\xff\x71\xff\xc2\xff\x8f\xff\x8f\xff\x00\x00\x00\x00\x00\x00\x9f\xff\x95\xff\xa0\xff\xa1\xff\x9c\xff\xa5\xff\xa9\xff\xc3\xff\x83\xff\xba\xfe\xcf\xfe\x00\x00\x00\x00\xca\xfe\xcc\xfe\xe1\xfe\xe1\xfe\xff\xfe\xa8\xfe\x00\x00\x00\x00\x44\xff\x00\x00\x5e\xff\x00\x00\xee\xfe\x2d\xff\xea\xfe\x00\x00\xed\xfe\x25\xff\x24\xff\x2d\xff\x00\x00\x54\xfe\x52\xfe\xf9\xfe\xf4\xfe\x00\x00\xf8\xfe\x2f\xff\x00\x00\x00\x00\x00\x00\x27\xfe\x55\xff\x3a\xfe\x15\xff\x00\x00\x49\xfe\x49\xfe\x5c\xff\x00\x00\x36\xfe\x33\xfe\x4c\xff\x4e\xff\x4d\xff\x00\x00\x38\xfe\x00\x00\x00\x00\x92\xfe\x40\xfe\x43\xfe\x41\xfe\x1c\xfe\x1d\xfe\x00\x00\xb2\xfd\xab\xfd\xaa\xfd\xad\xfd\x00\x00\x00\x00\x00\x00\xc3\xfc\x9f\xfd\xa0\xfd\xc6\xfc\x00\x00\x00\x00\x00\x00\x6e\xfe\x59\xfe\x57\xfe\x00\x00\xc8\xff\x89\xff\x00\x00\x00\x00\x00\x00\xb2\xff\x8f\xff\x8f\xff\xb3\xff\xaf\xff\xb0\xff\xcc\xff\xc9\xff\xd3\xff\xe6\xff\xf0\xfc\xbc\xff\x00\x00\xcb\xff\x7b\xfd\x7d\xfd\x00\x00\xa6\xfd\xa5\xfd\x00\x00\x9d\xfe\x46\xfe\x00\x00\x42\xfe\x65\xfe\x00\x00\x32\xfe\x34\xfe\x35\xfe\x00\x00\x4a\xfe\x00\x00\x00\x00\x00\x00\x16\xff\x54\xff\xf2\xfe\xf5\xfe\x31\xff\x1c\xff\x00\x00\x00\x00\x00\x00\x00\x00\x2e\xff\xf1\xfe\xe8\xfe\xeb\xfe\x00\x00\x2c\xff\xe7\xfe\x11\xff\x3f\xff\x37\xff\x37\xff\x00\x00\x00\x00\xa9\xfe\x00\x00\x00\x00\xc9\xfe\x00\x00\xd5\xfe\x81\xff\xa3\xff\x00\x00\x9b\xff\x99\xff\x98\xff\x97\xff\x43\xfd\x42\xfd\x41\xfd\x00\x00\x00\x00\xbb\xff\xba\xff\x00\x00\x9d\xff\x7f\xff\x00\x00\x00\x00\x00\x00\xfe\xfe\xfd\xfe\x36\xff\x43\xff\x41\xff\x00\x00\x38\xff\x00\x00\x00\x00\x00\x00\x00\x00\x2b\xff\xec\xfe\x21\xff\x00\x00\x1c\xff\x30\xff\x33\xff\x00\x00\x00\x00\xf6\xfe\x00\x00\x4e\xfe\x00\x00\x49\xfe\x4d\xfe\x31\xfe\x00\x00\x40\xfe\x44\xfe\x00\x00\xf6\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\xa4\xfd\x64\xfe\x4b\xfe\x00\x00\x17\xff\x00\x00\x7d\xfe\x00\x00\x1b\xff\x32\xff\x00\x00\xf7\xfe\x34\xff\x23\xff\x3c\xff\x3e\xff\x39\xff\x3b\xff\x3d\xff\x42\xff\xcd\xfe\xc7\xfe\x82\xff\x8b\xff\x80\xff\x00\x00\xa6\xff\x9a\xff\x00\x00\xa6\xff\x3a\xff\x4c\xfe\x3a\xfe\x7d\xfe\x00\x00\x48\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\x1a\xff\x2a\xff\x3a\xfe\x00\x00\x7e\xff\x7d\xff\x29\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\x62\x00\x49\x00\x06\x00\x49\x00\x37\x00\x4a\x00\x04\x00\x45\x00\x63\x00\x07\x00\x08\x00\x09\x00\x04\x00\x0b\x00\x86\x00\x0e\x00\x08\x00\x09\x00\x04\x00\x0b\x00\x39\x00\x3a\x00\x08\x00\x09\x00\xa1\x00\x0b\x00\x08\x00\x09\x00\x09\x00\x0b\x00\x0b\x00\x52\x00\x63\x00\x54\x00\x38\x00\x67\x00\x8b\x00\x09\x00\xd3\x00\x01\x00\xb5\x00\x12\x00\x7c\x00\x7d\x00\x55\x00\xd3\x00\x61\x00\x64\x00\x39\x00\x3a\x00\xe1\x00\x66\x00\x55\x00\x00\x00\x64\x00\x0b\x00\x00\x00\x6c\x00\x6d\x00\x4a\x00\x00\x00\x04\x01\x50\x00\x21\x00\x22\x00\x23\x00\x18\x00\x73\x00\x12\x00\x68\x00\x28\x00\x29\x00\x00\x00\x21\x00\x22\x00\x23\x00\x48\x00\x57\x00\x4b\x00\x50\x00\x28\x00\x29\x00\x55\x00\x33\x00\x00\x00\x21\x00\x22\x00\x23\x00\x7a\x00\x7b\x00\x00\x00\x6d\x00\x28\x00\x29\x00\x81\x00\x7a\x00\x7b\x00\x23\x00\x29\x01\x72\x00\x65\x00\x33\x00\x28\x00\x29\x00\x77\x00\x27\x00\x28\x00\x29\x00\x76\x00\x7a\x00\x7b\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x71\x00\x85\x00\x86\x00\xb5\x00\x82\x00\x48\x00\x50\x00\x64\x00\x2b\x01\x00\x00\x0b\x01\x0c\x01\x2d\x01\xaa\x00\x2f\x01\xb6\x00\xb7\x00\x81\x00\x6a\x00\x2d\x01\xbb\x00\xaa\x00\xba\x00\xbe\x00\x50\x00\xc0\x00\x17\x01\xc2\x00\x19\x01\x64\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\x64\x00\xca\x00\xcb\x00\xcc\x00\x74\x00\x24\x01\x67\x00\xff\x00\x00\x01\x67\x00\x02\x01\x03\x01\x1a\x01\x67\x00\x19\x00\x70\x00\x1e\x01\xaa\x00\xfa\x00\xfb\x00\x6a\x00\xd0\x00\x24\x01\xff\x00\x4c\x00\x67\x00\x02\x01\x03\x01\x81\x00\x1a\x01\x19\x00\x75\x00\x2b\x00\x1e\x01\x70\x00\xfd\x00\xfe\x00\x67\x00\x1e\x01\x24\x01\x02\x01\x03\x01\xf3\x00\xf4\x00\x24\x01\x1e\x01\x70\x00\x27\x01\x2b\x00\xd0\x00\x1a\x01\x24\x01\xfd\x00\xfe\x00\x1e\x01\x0b\x01\x0c\x01\x02\x01\x03\x01\x19\x01\x24\x01\x19\x01\x19\x01\x27\x01\x57\x00\x1b\x01\x76\x00\x1d\x01\x1e\x01\x1e\x01\x24\x01\x86\x00\x24\x01\x24\x01\x24\x01\x24\x01\x26\x01\x27\x01\x67\x00\x1a\x01\x12\x00\x1a\x01\x1b\x01\x1e\x01\x1d\x01\x1e\x01\x1a\x01\x70\x00\x04\x01\x24\x01\x1e\x01\x24\x01\x69\x00\x26\x01\x27\x01\x76\x00\x24\x01\x2a\x01\xfd\x00\xfe\x00\x10\x01\x11\x01\x1e\x01\x02\x01\x03\x01\x96\x00\x05\x01\x82\x00\x24\x01\x1e\x01\x10\x00\x7d\x00\x96\x00\x33\x00\x34\x00\x24\x01\x1a\x01\x82\x00\x22\x01\x23\x01\x1e\x01\x25\x01\x15\x01\x1e\x01\x48\x00\x29\x01\x24\x01\x21\x00\x1b\x01\x24\x01\x1d\x01\x1e\x01\x1f\x01\x2c\x01\x21\x01\x22\x01\x23\x01\x24\x01\x25\x01\x26\x01\x27\x01\x28\x01\x29\x01\x2c\x01\x24\x01\x09\x01\x2c\x01\x0b\x01\x0c\x01\x32\x00\x24\x01\x2c\x01\xa0\x00\xa1\x00\x00\x00\x09\x01\x24\x01\x0b\x01\x0c\x01\x7f\x00\x24\x01\x24\x01\x00\x00\x1b\x01\x70\x00\x1d\x01\x1e\x01\x09\x01\x4b\x00\x0b\x01\x0c\x01\x56\x00\x24\x01\x1b\x01\x59\x00\x1d\x01\x1e\x01\x09\x01\xf0\x00\x0b\x01\x0c\x01\x09\x01\x24\x01\x0b\x01\x0c\x01\x1b\x01\x00\x00\x1d\x01\x1e\x01\x09\x01\x00\x00\x0b\x01\x0c\x01\x4a\x00\x24\x01\x1b\x01\x00\x00\x1d\x01\x1e\x01\x1b\x01\x5a\x00\x1d\x01\x1e\x01\x76\x00\x24\x01\x37\x00\x48\x00\x1b\x01\x24\x01\x1d\x01\x1e\x01\x3d\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\x24\x01\x43\x00\x55\x00\x1a\x01\x50\x00\x49\x00\x1c\x01\x1e\x01\x1e\x01\x61\x00\x6b\x00\x74\x00\x50\x00\x24\x01\x24\x01\x4b\x00\x71\x00\x53\x00\x54\x00\x6b\x00\xfa\x00\xfb\x00\x77\x00\x8b\x00\x81\x00\xff\x00\x5c\x00\x5d\x00\x02\x01\x03\x01\x70\x00\x61\x00\x4b\x00\x6d\x00\x01\x00\x8d\x00\x66\x00\x71\x00\x4b\x00\x91\x00\x92\x00\x67\x00\x94\x00\x95\x00\x96\x00\x71\x00\x98\x00\x99\x00\x48\x00\x67\x00\x70\x00\x4a\x00\x1a\x01\x71\x00\x15\x00\x17\x01\x1e\x01\x19\x01\x70\x00\xaf\x00\xb0\x00\xb1\x00\x24\x01\x56\x00\x82\x00\x27\x01\xfa\x00\xfb\x00\x24\x01\x4b\x00\x71\x00\xff\x00\x5f\x00\x67\x00\x02\x01\x03\x01\x71\x00\x67\x00\x52\x00\x7e\x00\x7f\x00\x13\x00\x70\x00\x67\x00\xbe\x00\x50\x00\x70\x00\x50\x00\x70\x00\x50\x00\x4a\x00\x5f\x00\x70\x00\x0d\x01\x0e\x01\x76\x00\x77\x00\xcb\x00\x1a\x01\x7a\x00\x7b\x00\x87\x00\x1e\x01\x9f\x00\xa0\x00\xa1\x00\x4c\x00\x8b\x00\x24\x01\x2f\x00\x30\x00\x27\x01\x6b\x00\x6b\x00\x42\x00\x64\x00\xb6\x00\x66\x00\x71\x00\x71\x00\x71\x00\xbb\x00\x71\x00\x6b\x00\xbe\x00\x2d\x01\xc0\x00\x61\x00\xc2\x00\x71\x00\x4b\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\x77\x00\x50\x00\xcb\x00\xcc\x00\x7b\x00\xa8\x00\xa9\x00\x48\x00\x37\x00\xb0\x00\xb1\x00\x9f\x00\xa0\x00\xa1\x00\x4c\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\x51\x00\x43\x00\x65\x00\x07\x01\x08\x01\x48\x00\x0a\x01\x0b\x01\x0c\x01\x0d\x01\x0e\x01\x6d\x00\x1a\x01\xc3\x00\x6a\x00\x71\x00\x1e\x01\x53\x00\x54\x00\x17\x01\x18\x01\x19\x01\x24\x01\xf3\x00\xf4\x00\x75\x00\x5c\x00\x5d\x00\x49\x00\x79\x00\x19\x00\x61\x00\x24\x01\xfd\x00\xfe\x00\x8d\x00\x66\x00\x52\x00\x02\x01\x03\x01\x92\x00\x19\x00\x94\x00\x95\x00\x96\x00\x96\x00\x98\x00\x99\x00\x2b\x00\xfa\x00\xfb\x00\x0b\x00\xff\x00\x00\x01\xff\x00\x02\x01\x03\x01\x02\x01\x03\x01\x2b\x00\xa8\x00\xa9\x00\x1a\x01\x1b\x01\x82\x00\x1d\x01\x1e\x01\x1b\x00\x6a\x00\x17\x01\x6b\x00\x19\x01\x24\x01\x05\x01\x26\x01\x27\x01\x71\x00\x1e\x00\x2a\x01\x75\x00\x1e\x00\x1a\x01\x24\x01\x79\x00\xbe\x00\x1e\x01\x12\x01\xc3\x00\x14\x01\x15\x01\x2b\x00\x24\x01\x27\x01\x2b\x00\x27\x01\x61\x00\x1a\x01\xcb\x00\x64\x00\x1f\x01\x1e\x01\x21\x01\x22\x01\x23\x01\x1e\x00\x25\x01\x24\x01\x69\x00\x28\x01\x29\x01\x51\x00\x13\x00\x17\x01\x69\x00\x19\x01\x71\x00\xb6\x00\x2b\x00\x9f\x00\xa0\x00\xa1\x00\xbb\x00\xee\x00\xef\x00\xbe\x00\x24\x01\xc0\x00\x51\x00\xc2\x00\xa8\x00\xa9\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\x4d\x00\x4e\x00\xcb\x00\xcc\x00\x2f\x00\x30\x00\x31\x00\x6d\x00\x37\x00\xff\x00\x00\x01\x71\x00\x02\x01\x03\x01\x96\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\x65\x00\x43\x00\xc3\x00\x07\x01\x08\x01\x00\x00\x0a\x01\x0b\x01\x0c\x01\x0d\x01\x0e\x01\x70\x00\x07\x00\x1b\x01\x1c\x01\x1d\x01\x1e\x01\x53\x00\x54\x00\x17\x01\x18\x01\x19\x01\x24\x01\xf3\x00\xf4\x00\x4a\x00\x5c\x00\x5d\x00\x1e\x00\x18\x00\x27\x01\x61\x00\x24\x01\xfd\x00\xfe\x00\x1f\x00\x66\x00\x56\x00\x02\x01\x03\x01\x1a\x00\x2b\x00\x9f\x00\xa0\x00\xa1\x00\x8d\x00\x5f\x00\x54\x00\x2c\x00\x2d\x00\x92\x00\x56\x00\x94\x00\x95\x00\x96\x00\x5a\x00\x98\x00\x99\x00\x2c\x00\x2d\x00\x5f\x00\x6b\x00\x1a\x01\x1b\x01\x82\x00\x1d\x01\x1e\x01\x71\x00\x65\x00\x76\x00\x77\x00\x65\x00\x24\x01\x82\x00\x26\x01\x27\x01\x4d\x00\x4e\x00\x2a\x01\x70\x00\x4b\x00\x4c\x00\x70\x00\x76\x00\x17\x01\x50\x00\x19\x01\x52\x00\x53\x00\x2e\x00\x9f\x00\xa0\x00\xa1\x00\x69\x00\xbe\x00\xff\x00\x00\x01\x24\x01\x02\x01\x03\x01\x6a\x00\x71\x00\x3b\x00\x3c\x00\x63\x00\x69\x00\x65\x00\xcb\x00\x67\x00\x65\x00\x56\x00\x75\x00\x37\x00\x71\x00\x5a\x00\x79\x00\xb6\x00\x70\x00\x65\x00\x5f\x00\x70\x00\xbb\x00\x96\x00\x68\x00\xbe\x00\x6a\x00\xc0\x00\x6c\x00\xc2\x00\x70\x00\x96\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\x27\x01\x75\x00\xcb\x00\xcc\x00\x52\x00\x8d\x00\x54\x00\x76\x00\x3c\x00\x3d\x00\x92\x00\x7a\x00\x94\x00\x95\x00\x96\x00\x65\x00\x98\x00\x99\x00\x1a\x01\x61\x00\x96\x00\x17\x01\x1e\x01\x19\x01\x66\x00\x71\x00\x70\x00\x17\x01\x24\x01\x19\x01\x6c\x00\x6d\x00\x07\x01\x08\x01\x24\x01\x0a\x01\x0b\x01\x0c\x01\x0d\x01\x0e\x01\x24\x01\x6b\x00\xf3\x00\xf4\x00\x50\x00\x65\x00\x52\x00\x71\x00\x17\x01\x18\x01\x19\x01\x71\x00\xfd\x00\xfe\x00\xbe\x00\xfb\x00\x70\x00\x02\x01\x03\x01\xff\x00\x10\x00\x24\x01\x02\x01\x03\x01\x1a\x01\xfd\x00\xfe\x00\xcb\x00\x1e\x01\x01\x01\x02\x01\x03\x01\x65\x00\x42\x00\x24\x01\x17\x01\x75\x00\x19\x01\x0b\x01\x0c\x01\x79\x00\x1a\x01\x1b\x01\x70\x00\x1d\x01\x1e\x01\x1a\x01\x4e\x00\x24\x01\x6a\x00\x1e\x01\x24\x01\x19\x01\x26\x01\x27\x01\x37\x00\x24\x01\x2a\x01\x68\x00\x27\x01\x6a\x00\x14\x00\x6c\x00\x24\x01\xb6\x00\xb7\x00\x26\x01\x27\x01\x1b\x00\xbb\x00\x1d\x00\x75\x00\xbe\x00\x10\x00\xc0\x00\x79\x00\xc2\x00\x1e\x01\x81\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\x24\x01\xca\x00\xcb\x00\xcc\x00\x07\x01\x08\x01\x8d\x00\x0a\x01\x0b\x01\x0c\x01\x0d\x01\x0e\x01\x99\x00\x17\x01\x61\x00\x19\x01\x97\x00\x98\x00\x99\x00\x66\x00\x17\x01\x18\x01\x19\x01\xed\x00\xee\x00\xef\x00\x24\x01\x8d\x00\x17\x01\x70\x00\x19\x01\x1e\x01\x92\x00\x24\x01\x94\x00\x95\x00\x96\x00\x24\x01\x98\x00\x99\x00\x65\x00\x24\x01\xf3\x00\xf4\x00\x0c\x01\x37\x00\x68\x00\x0f\x01\x6a\x00\xbe\x00\x6c\x00\x70\x00\xfd\x00\xfe\x00\x19\x01\xbe\x00\x96\x00\x02\x01\x03\x01\x75\x00\x75\x00\x39\x00\xcb\x00\x79\x00\x79\x00\x24\x01\x4b\x00\x4c\x00\xcb\x00\x1b\x01\x1c\x01\x1d\x01\x1e\x01\x68\x00\x1e\x01\x6a\x00\xbe\x00\x6c\x00\x24\x01\x96\x00\x24\x01\x1a\x01\x1b\x01\x27\x01\x1d\x01\x1e\x01\x75\x00\x61\x00\x65\x00\xcb\x00\x79\x00\x24\x01\x66\x00\x26\x01\x27\x01\x22\x01\x23\x01\x2a\x01\x25\x01\xb6\x00\xb7\x00\x70\x00\x70\x00\x1b\x01\xbb\x00\x1d\x01\x1e\x01\xbe\x00\x64\x00\xc0\x00\x66\x00\xc2\x00\x24\x01\x1e\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\x48\x00\xca\x00\xcb\x00\xcc\x00\x07\x01\x08\x01\x4b\x00\x4c\x00\x0b\x01\x0c\x01\x07\x01\x08\x01\x71\x00\x0a\x01\x0b\x01\x0c\x01\x0d\x01\x0e\x01\x22\x01\x23\x01\x17\x01\x25\x01\x19\x01\x4b\x00\x4c\x00\x29\x01\x17\x01\x18\x01\x19\x01\x2d\x01\x4b\x00\x07\x01\x08\x01\x24\x01\x0a\x01\x0b\x01\x0c\x01\x0d\x01\x0e\x01\x24\x01\xf1\x00\xf2\x00\xf3\x00\xf4\x00\x4c\x00\xfd\x00\xfe\x00\x17\x01\x18\x01\x19\x01\x02\x01\x03\x01\xfd\x00\xfe\x00\xb6\x00\xb7\x00\x37\x00\x02\x01\x03\x01\xbb\x00\x24\x01\x64\x00\xbe\x00\x66\x00\xc0\x00\x1c\x01\xc2\x00\x1e\x01\x50\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\x24\x01\xca\x00\xcb\x00\xcc\x00\x48\x00\x13\x00\x14\x00\x4f\x00\x1a\x01\x1b\x01\x18\x00\x1d\x01\x1e\x01\x26\x01\x27\x01\x68\x00\x48\x00\x6a\x00\x24\x01\x6c\x00\x26\x01\x27\x01\x4c\x00\x70\x00\x2a\x01\x61\x00\x50\x00\x8d\x00\x75\x00\x10\x00\x66\x00\x91\x00\x68\x00\x69\x00\x94\x00\x95\x00\x96\x00\x48\x00\x98\x00\x99\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\x6d\x00\xfd\x00\xfe\x00\x48\x00\x71\x00\x01\x01\x02\x01\x03\x01\xfd\x00\xfe\x00\x28\x01\x29\x01\x37\x00\x02\x01\x03\x01\x2d\x01\xae\x00\x21\x01\x22\x01\x23\x01\x42\x00\x25\x01\x1e\x01\x08\x01\x28\x01\x29\x01\x0b\x01\x0c\x01\x24\x01\x2d\x01\x26\x01\x27\x01\xbe\x00\x3c\x00\x3d\x00\x4c\x00\x4f\x00\x1a\x01\x1b\x01\x50\x00\x1d\x01\x1e\x01\x26\x01\x27\x01\x6d\x00\xcb\x00\x55\x00\x24\x01\x71\x00\x26\x01\x27\x01\x81\x00\x4a\x00\x2a\x01\x61\x00\x1c\x01\x75\x00\x1e\x01\x52\x00\x66\x00\x79\x00\x68\x00\x69\x00\x24\x01\x56\x00\x29\x01\xb6\x00\xb7\x00\x5a\x00\x2d\x01\x64\x00\xbb\x00\x66\x00\x5f\x00\xbe\x00\x64\x00\xc0\x00\x66\x00\xc2\x00\x99\x00\x71\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\x50\x00\xca\x00\xcb\x00\xcc\x00\x4b\x00\x4c\x00\x1c\x01\x72\x00\x1e\x01\x4b\x00\x4c\x00\x76\x00\x77\x00\x99\x00\x24\x01\x7a\x00\x7b\x00\xb8\x00\xb9\x00\xba\x00\x07\x01\x08\x01\x6b\x00\x0a\x01\x0b\x01\x0c\x01\x0d\x01\x0e\x01\x3c\x00\x3d\x00\x1b\x01\xbe\x00\x1d\x01\x1e\x01\x6b\x00\x8e\x00\x17\x01\x18\x01\x19\x01\x24\x01\x6b\x00\x37\x00\xf3\x00\xf4\x00\xcb\x00\x43\x00\x44\x00\x45\x00\x46\x00\x24\x01\xbe\x00\x6b\x00\xfd\x00\xfe\x00\xb6\x00\xb7\x00\x6b\x00\x02\x01\x03\x01\xbb\x00\x37\x00\x48\x00\xbe\x00\xcb\x00\xc0\x00\x1c\x01\xc2\x00\x1e\x01\x4b\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\x24\x01\xca\x00\xcb\x00\xcc\x00\x1b\x01\x71\x00\x1d\x01\x1e\x01\x1a\x01\x1b\x01\x48\x00\x1d\x01\x1e\x01\x24\x01\x52\x00\x66\x00\x54\x00\x71\x00\x24\x01\x08\x01\x26\x01\x27\x01\x0b\x01\x0c\x01\x2a\x01\x4a\x00\x4b\x00\x0c\x00\x64\x00\x61\x00\x66\x00\x07\x01\x08\x01\x90\x00\x66\x00\x0b\x01\x0c\x01\x56\x00\x4b\x00\x4c\x00\x6c\x00\x5a\x00\xf3\x00\xf4\x00\x02\x00\x03\x00\x5f\x00\x17\x01\x69\x00\x19\x01\x07\x01\x08\x01\xfd\x00\xfe\x00\x0b\x01\x0c\x01\x8e\x00\x02\x01\x03\x01\x08\x01\x24\x01\x8e\x00\x0b\x01\x0c\x01\x8e\x00\x72\x00\x17\x01\x6d\x00\x19\x01\x76\x00\x77\x00\x02\x00\x03\x00\x7a\x00\x7b\x00\x6b\x00\xdd\x00\xde\x00\xdf\x00\x24\x01\xe1\x00\x1a\x01\x1b\x01\x69\x00\x1d\x01\x1e\x01\xa3\x00\xa4\x00\xa5\x00\x1d\x01\x1e\x01\x24\x01\x71\x00\x26\x01\x27\x01\x52\x00\x24\x01\x2a\x01\x26\x01\x27\x01\xbb\x00\x37\x00\x64\x00\xbe\x00\x66\x00\xc0\x00\x64\x00\xc2\x00\x66\x00\x48\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xb6\x00\xb7\x00\xcb\x00\xcc\x00\x1b\x01\xbb\x00\x1d\x01\x1e\x01\xbe\x00\x48\x00\xc0\x00\x4f\x00\xc2\x00\x24\x01\x0c\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\x70\x00\xca\x00\xcb\x00\xcc\x00\x1d\x01\x1e\x01\x4a\x00\x4b\x00\x4c\x00\x52\x00\x61\x00\x24\x01\x50\x00\x26\x01\x27\x01\x66\x00\x14\x00\x68\x00\x56\x00\x5e\x00\x5f\x00\x60\x00\x5a\x00\xf3\x00\xf4\x00\x50\x00\x64\x00\x5f\x00\x66\x00\x72\x00\x06\x01\x07\x01\x08\x01\xfd\x00\xfe\x00\x0b\x01\x0c\x01\x72\x00\x02\x01\x03\x01\x6b\x00\x37\x00\xf3\x00\xf4\x00\x71\x00\x72\x00\x72\x00\x17\x01\x6b\x00\x19\x01\x76\x00\x77\x00\xfd\x00\xfe\x00\x7a\x00\x7b\x00\x6b\x00\x02\x01\x03\x01\x64\x00\x24\x01\x66\x00\x1a\x01\x1b\x01\x72\x00\x1d\x01\x1e\x01\x1b\x01\x72\x00\x1d\x01\x1e\x01\x6d\x00\x24\x01\x59\x00\x26\x01\x27\x01\x24\x01\x64\x00\x2a\x01\x66\x00\x6d\x00\x1a\x01\x1b\x01\x61\x00\x1d\x01\x1e\x01\x6b\x00\x64\x00\x66\x00\x66\x00\x64\x00\x24\x01\x66\x00\x26\x01\x27\x01\xb6\x00\xb7\x00\x2a\x01\x70\x00\x64\x00\xbb\x00\x66\x00\x64\x00\xbe\x00\x66\x00\xc0\x00\x71\x00\xc2\x00\x04\x01\x65\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\x4a\x00\xca\x00\xcb\x00\xcc\x00\x71\x00\x72\x00\x10\x01\x11\x01\x52\x00\xbc\x00\xbd\x00\x8d\x00\x56\x00\xbc\x00\xbd\x00\x91\x00\x92\x00\x52\x00\x94\x00\x95\x00\x96\x00\x5f\x00\x98\x00\x99\x00\x22\x01\x23\x01\x70\x00\x25\x01\x21\x01\x22\x01\x23\x01\x29\x01\x25\x01\x6b\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x71\x00\x6a\x00\x37\x00\xf3\x00\xf4\x00\x76\x00\x77\x00\xbc\x00\xbd\x00\x7a\x00\x7b\x00\x46\x00\x47\x00\xfd\x00\xfe\x00\xb6\x00\xb7\x00\x0b\x00\x02\x01\x03\x01\xbb\x00\xbe\x00\x64\x00\xbe\x00\x66\x00\xc0\x00\x64\x00\xc2\x00\x66\x00\x32\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xcb\x00\xca\x00\xcb\x00\xcc\x00\xb2\x00\xb3\x00\xb4\x00\x18\x00\x1a\x01\x1b\x01\x61\x00\x1d\x01\x1e\x01\x4b\x00\x76\x00\x66\x00\x78\x00\x2d\x01\x24\x01\x2f\x01\x26\x01\x27\x01\x74\x00\x75\x00\x2a\x01\x70\x00\x06\x01\x07\x01\x08\x01\x2e\x01\x2f\x01\x0b\x01\x0c\x01\x71\x00\x72\x00\x4a\x00\x99\x00\x6b\x00\xab\x00\xac\x00\xad\x00\x37\x00\xf3\x00\xf4\x00\xdd\x00\xde\x00\xdf\x00\x56\x00\xe1\x00\x0d\x01\x0e\x01\x5a\x00\xfd\x00\xfe\x00\x10\x00\x11\x00\x5f\x00\x02\x01\x03\x01\x71\x00\x07\x01\x08\x01\x4e\x00\x0a\x01\x0b\x01\x0c\x01\x0d\x01\x0e\x01\x6b\x00\xb2\x00\xb3\x00\xb4\x00\x72\x00\xbe\x00\x71\x00\x6b\x00\x17\x01\x18\x01\x19\x01\x76\x00\x77\x00\x1a\x01\x1b\x01\x61\x00\x1d\x01\x1e\x01\xcb\x00\x6b\x00\x66\x00\x24\x01\x71\x00\x24\x01\x6b\x00\x26\x01\x27\x01\xb6\x00\xb7\x00\x2a\x01\x6b\x00\xdf\x00\xbb\x00\xe1\x00\x6b\x00\xbe\x00\x6b\x00\xc0\x00\x6b\x00\xc2\x00\x10\x00\x11\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\x69\x00\xca\x00\xcb\x00\xcc\x00\xfc\x00\x65\x00\xfe\x00\xb2\x00\xb3\x00\xb4\x00\x02\x01\x8d\x00\x71\x00\x21\x01\x22\x01\x23\x01\x92\x00\x25\x01\x94\x00\x95\x00\x96\x00\x4c\x00\x98\x00\x99\x00\xb2\x00\xb3\x00\xb4\x00\xb2\x00\xb3\x00\xb4\x00\xf2\x00\xf3\x00\x07\x01\x08\x01\x1a\x01\x4e\x00\x0b\x01\x0c\x01\x1e\x01\xb2\x00\xb3\x00\xb4\x00\xf3\x00\xf4\x00\x24\x01\x61\x00\x26\x01\x27\x01\x17\x01\x61\x00\x19\x01\x52\x00\xfd\x00\xfe\x00\xb6\x00\xb7\x00\x71\x00\x02\x01\x03\x01\xbb\x00\xbe\x00\x24\x01\xbe\x00\x16\x00\xc0\x00\x50\x00\xc2\x00\xa4\x00\xa5\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xcb\x00\xca\x00\xcb\x00\xcc\x00\xac\x00\xad\x00\x34\x00\x35\x00\x1a\x01\x1b\x01\x71\x00\x1d\x01\x1e\x01\x6b\x00\xfa\x00\xfb\x00\x65\x00\x71\x00\x24\x01\xff\x00\x26\x01\x27\x01\x02\x01\x03\x01\x2a\x01\x8d\x00\x4b\x00\x48\x00\x48\x00\x82\x00\x92\x00\x69\x00\x94\x00\x95\x00\x96\x00\x4b\x00\x98\x00\x99\x00\x6b\x00\x48\x00\x6b\x00\x48\x00\xf3\x00\xf4\x00\x4e\x00\x50\x00\x1a\x01\x18\x00\x72\x00\x72\x00\x1e\x01\x71\x00\xfd\x00\xfe\x00\x4b\x00\x6b\x00\x24\x01\x02\x01\x03\x01\x27\x01\x07\x01\x08\x01\x4b\x00\x0a\x01\x0b\x01\x0c\x01\x0d\x01\x0e\x01\x18\x00\x75\x00\x4c\x00\x4e\x00\x81\x00\x81\x00\xbe\x00\x48\x00\x17\x01\x18\x01\x19\x01\x48\x00\x99\x00\x1a\x01\x1b\x01\x15\x00\x1d\x01\x1e\x01\x6a\x00\xcb\x00\x4a\x00\x24\x01\x0b\x00\x24\x01\x18\x00\x26\x01\x27\x01\x70\x00\x52\x00\x2a\x01\x18\x00\x99\x00\x56\x00\x81\x00\x6b\x00\x48\x00\x5a\x00\x69\x00\x18\x00\x8d\x00\x4b\x00\x5f\x00\x65\x00\x71\x00\x92\x00\x72\x00\x94\x00\x95\x00\x96\x00\xbe\x00\x98\x00\x99\x00\x4b\x00\x4b\x00\x4b\x00\x5f\x00\x71\x00\x59\x00\x4c\x00\x18\x00\x72\x00\x50\x00\xcb\x00\x18\x00\x76\x00\x77\x00\x8d\x00\x07\x00\xbe\x00\x55\x00\x19\x00\x92\x00\x50\x00\x94\x00\x95\x00\x96\x00\x48\x00\x98\x00\x99\x00\x07\x01\x08\x01\xcb\x00\x0a\x01\x0b\x01\x0c\x01\x0d\x01\x0e\x01\x7e\x00\xbe\x00\x65\x00\x69\x00\x65\x00\x70\x00\x50\x00\x69\x00\x17\x01\x18\x01\x19\x01\x70\x00\x70\x00\x6b\x00\xcb\x00\x18\x00\x48\x00\x48\x00\x18\x00\x6b\x00\x70\x00\x24\x01\x8d\x00\x65\x00\x18\x00\x6b\x00\x91\x00\x92\x00\xbe\x00\x94\x00\x95\x00\x96\x00\x2b\x00\x98\x00\x99\x00\x07\x01\x08\x01\x50\x00\x4c\x00\x0b\x01\x0c\x01\xcb\x00\x70\x00\x48\x00\x71\x00\x50\x00\x48\x00\x07\x00\x5f\x00\x18\x00\x18\x00\x17\x01\x07\x00\x19\x01\x07\x01\x08\x01\xfd\x00\xfe\x00\x0b\x01\x0c\x01\x4b\x00\x02\x01\x03\x01\x5f\x00\x24\x01\x5a\x00\x69\x00\x81\x00\x71\x00\x6a\x00\x17\x01\xbe\x00\x19\x01\x6b\x00\x07\x01\x08\x01\x70\x00\x0a\x01\x0b\x01\x0c\x01\x0d\x01\x0e\x01\x70\x00\x24\x01\xcb\x00\x6b\x00\x1b\x01\x6b\x00\x1d\x01\x1e\x01\x17\x01\x18\x01\x19\x01\x6b\x00\x15\x00\x24\x01\x4b\x00\x26\x01\x27\x01\x4c\x00\x52\x00\x07\x01\x08\x01\x24\x01\x0a\x01\x0b\x01\x0c\x01\x0d\x01\x0e\x01\x10\x00\x4a\x00\x21\x00\x07\x00\x31\x00\x5f\x00\x55\x00\x8d\x00\x17\x01\x18\x01\x19\x01\x91\x00\x92\x00\x56\x00\x94\x00\x95\x00\x96\x00\x5a\x00\x98\x00\x99\x00\x55\x00\x24\x01\x5f\x00\xf8\x00\xf9\x00\x19\x00\xfb\x00\x39\x00\x08\x00\x6a\x00\xff\x00\x2c\x00\x68\x00\x02\x01\x03\x01\x07\x01\x08\x01\x71\x00\x0a\x01\x0b\x01\x0c\x01\x0d\x01\x0e\x01\x55\x00\x6b\x00\x76\x00\x77\x00\x65\x00\x42\x00\x7a\x00\x7b\x00\x17\x01\x18\x01\x19\x01\x70\x00\x02\x00\xbe\x00\x1a\x01\x6b\x00\x6b\x00\x71\x00\x1e\x01\x65\x00\x5f\x00\x24\x01\x4b\x00\x65\x00\x24\x01\x4b\x00\xcb\x00\x27\x01\x02\x00\x6a\x00\x18\x00\x50\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x6a\x00\x94\x00\x95\x00\x96\x00\x6a\x00\x98\x00\x99\x00\x6b\x00\x18\x00\x07\x00\x9d\x00\x9e\x00\x07\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x18\x00\x94\x00\x95\x00\x96\x00\x76\x00\x98\x00\x99\x00\x4a\x00\x6b\x00\x76\x00\x12\x00\x2c\x01\x2e\x00\x2d\x01\x2c\x01\xe7\x00\x36\x00\xe7\x00\x93\x00\xe7\x00\xcf\x00\x5b\x00\x44\x00\x83\x00\xbe\x00\x2f\x00\x2c\x01\x2c\x01\x16\x00\x07\x01\x08\x01\x2b\x01\x0a\x01\x0b\x01\x0c\x01\x0d\x01\x0e\x01\xcb\x00\x16\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xbe\x00\xfb\x00\x17\x01\x18\x01\x19\x01\xff\x00\x30\x00\x80\x00\x02\x01\x03\x01\x80\x00\x93\x00\x84\x00\xcb\x00\xa2\x00\x24\x01\x84\x00\x88\x00\x5b\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\xcd\x00\x94\x00\x95\x00\x96\x00\x31\x01\x98\x00\x99\x00\x1a\x01\x77\x00\xf3\x00\x30\x01\x1e\x01\xc3\x00\x16\x00\x2b\x01\x22\x01\x23\x01\x24\x01\x25\x01\x16\x00\x27\x01\x20\x00\x29\x01\x80\x00\x80\x00\x20\x00\x2d\x01\x2e\x00\xf3\x00\x07\x01\x08\x01\x03\x00\x0a\x01\x0b\x01\x0c\x01\x0d\x01\x0e\x01\x0a\x00\x31\x01\x2b\x01\xe1\x00\x6b\x00\x2b\x01\xbe\x00\x56\x00\x17\x01\x18\x01\x19\x01\x07\x01\x08\x01\x2b\x01\x0a\x01\x0b\x01\x0c\x01\x0d\x01\x0e\x01\xcb\x00\x2b\x01\x24\x01\x57\x00\x44\x00\x6f\x00\x79\x00\x77\x00\x17\x01\x18\x01\x19\x01\x2d\x01\x27\x01\x2f\x01\x75\x00\x81\x00\x32\x00\x20\x00\x0e\x01\x22\x01\x23\x01\x24\x01\x25\x01\x20\x00\x2a\x00\x28\x01\x29\x01\x31\x00\x65\x00\x48\x00\x2d\x01\x6e\x00\x6a\x00\x73\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\xf3\x00\x94\x00\x95\x00\x96\x00\x60\x00\x98\x00\x99\x00\xa7\x00\x2a\x00\x2b\x01\x0f\x00\x2b\x01\x1c\x00\x1c\x00\x73\x00\xc3\x00\x05\x01\xe1\x00\xa7\x00\xb4\x00\x07\x01\x08\x01\x4b\x00\x0a\x01\x0b\x01\x0c\x01\x0d\x01\x0e\x01\xa5\x00\x12\x01\x17\x00\x14\x01\x15\x01\x2c\x01\x24\x00\x2c\x01\x17\x01\x18\x01\x19\x01\x17\x00\x32\x00\x2a\x00\x1f\x01\xbe\x00\x21\x01\x22\x01\x23\x01\x4c\x00\x25\x01\x24\x01\x51\x00\x28\x01\x29\x01\x2b\x01\x51\x00\x50\x00\xcb\x00\x46\x00\x2d\x01\x89\x00\x8a\x00\x2b\x01\x2f\x00\x8d\x00\x8e\x00\x2c\x01\x90\x00\x91\x00\x92\x00\x2b\x01\x94\x00\x95\x00\x96\x00\x11\x00\x98\x00\x99\x00\x0c\x00\x9b\x00\x2c\x01\x16\x00\x2b\x01\x58\x00\x5b\x00\x2b\x01\x33\x00\x2b\x01\x56\x00\x2c\x01\x16\x00\x58\x00\x89\x00\x8a\x00\x20\x00\x2b\x01\x8d\x00\x8e\x00\xf3\x00\x90\x00\x91\x00\x92\x00\x20\x00\x94\x00\x95\x00\x96\x00\xa7\x00\x98\x00\x99\x00\x2b\x01\x9b\x00\x17\x00\x2c\x01\x2c\x01\xbe\x00\x2c\x01\x17\x00\x2c\x01\x07\x01\x08\x01\xff\xff\x0a\x01\x0b\x01\x0c\x01\x0d\x01\x0e\x01\xff\xff\xcb\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x17\x01\x18\x01\x19\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xbe\x00\xff\xff\x24\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2d\x01\xff\xff\xcb\x00\xff\xff\xff\xff\x89\x00\x8a\x00\x4a\x00\xff\xff\x8d\x00\x8e\x00\xf3\x00\x90\x00\x91\x00\x92\x00\x52\x00\x94\x00\x95\x00\x96\x00\x56\x00\x98\x00\x99\x00\xff\xff\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\xff\xff\x07\x01\x08\x01\xff\xff\x0a\x01\x0b\x01\x0c\x01\x0d\x01\x0e\x01\xff\xff\x6b\x00\xff\xff\xf3\x00\xff\xff\xff\xff\xff\xff\x71\x00\x17\x01\x18\x01\x19\x01\xff\xff\x76\x00\x77\x00\xff\xff\xff\xff\x7a\x00\x7b\x00\xff\xff\xbe\x00\xff\xff\x24\x01\xff\xff\x07\x01\x08\x01\xff\xff\x0a\x01\x0b\x01\x0c\x01\x0d\x01\x0e\x01\xff\xff\xcb\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xff\xff\xfb\x00\x17\x01\x18\x01\x19\x01\xff\x00\xff\xff\xff\xff\x02\x01\x03\x01\xff\xff\xff\xff\x89\x00\x8a\x00\xff\xff\x24\x01\x8d\x00\x8e\x00\xff\xff\x90\x00\x91\x00\x92\x00\xff\xff\x94\x00\x95\x00\x96\x00\xff\xff\x98\x00\x99\x00\xff\xff\xff\xff\x4a\x00\x1a\x01\xff\xff\xff\xff\xf3\x00\x1e\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x24\x01\x56\x00\xff\xff\x27\x01\xff\xff\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\xff\xff\x07\x01\x08\x01\xff\xff\x0a\x01\x0b\x01\x0c\x01\x0d\x01\x0e\x01\xff\xff\x6b\x00\xbe\x00\xff\xff\xff\xff\xff\xff\xff\xff\x71\x00\x17\x01\x18\x01\x19\x01\xff\xff\x76\x00\x77\x00\xff\xff\xcb\x00\x7a\x00\x7b\x00\xff\xff\x8a\x00\xff\xff\x24\x01\x8d\x00\x8e\x00\xff\xff\x90\x00\x91\x00\x92\x00\xff\xff\x94\x00\x95\x00\x96\x00\xff\xff\x98\x00\x99\x00\x9a\x00\xff\xff\xff\xff\x8a\x00\xff\xff\xff\xff\x8d\x00\x8e\x00\xff\xff\x90\x00\x91\x00\x92\x00\xff\xff\x94\x00\x95\x00\x96\x00\xff\xff\x98\x00\x99\x00\x9a\x00\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\xbe\x00\xff\xff\xff\xff\xff\xff\x07\x01\x08\x01\xff\xff\x0a\x01\x0b\x01\x0c\x01\x0d\x01\x0e\x01\xff\xff\xcb\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xbe\x00\x17\x01\x18\x01\x19\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xcb\x00\x24\x01\xff\xff\x8a\x00\xff\xff\xff\xff\x8d\x00\x8e\x00\xff\xff\x90\x00\x91\x00\x92\x00\xff\xff\x94\x00\x95\x00\x96\x00\xff\xff\x98\x00\x99\x00\x9a\x00\xff\xff\xf3\x00\x8a\x00\xff\xff\x8c\x00\x8d\x00\x8e\x00\xff\xff\x90\x00\x91\x00\x92\x00\xff\xff\x94\x00\x95\x00\x96\x00\xff\xff\x98\x00\x99\x00\xff\xff\xff\xff\xf3\x00\x07\x01\x08\x01\xff\xff\x0a\x01\x0b\x01\x0c\x01\x0d\x01\x0e\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xbe\x00\xff\xff\x17\x01\x18\x01\x19\x01\x07\x01\x08\x01\xff\xff\x0a\x01\x0b\x01\x0c\x01\x0d\x01\x0e\x01\xcb\x00\xff\xff\x24\x01\xff\xff\xff\xff\xff\xff\xbe\x00\xff\xff\x17\x01\x18\x01\x19\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xcb\x00\xff\xff\x24\x01\x8a\x00\xff\xff\x8c\x00\x8d\x00\x8e\x00\xff\xff\x90\x00\x91\x00\x92\x00\xff\xff\x94\x00\x95\x00\x96\x00\xff\xff\x98\x00\x99\x00\xff\xff\xff\xff\xf3\x00\x8a\x00\xff\xff\x8c\x00\x8d\x00\x8e\x00\xff\xff\x90\x00\x91\x00\x92\x00\xff\xff\x94\x00\x95\x00\x96\x00\xff\xff\x98\x00\x99\x00\xff\xff\xff\xff\xf3\x00\x07\x01\x08\x01\xff\xff\x0a\x01\x0b\x01\x0c\x01\x0d\x01\x0e\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xbe\x00\x05\x01\x17\x01\x18\x01\x19\x01\x07\x01\x08\x01\xff\xff\x0a\x01\x0b\x01\x0c\x01\x0d\x01\x0e\x01\xcb\x00\x12\x01\x24\x01\x14\x01\x15\x01\xff\xff\xbe\x00\xff\xff\x17\x01\x18\x01\x19\x01\xff\xff\xff\xff\xff\xff\x1f\x01\xff\xff\x21\x01\x22\x01\x23\x01\xcb\x00\x25\x01\x24\x01\x8a\x00\x28\x01\x29\x01\x8d\x00\x8e\x00\xff\xff\x90\x00\x91\x00\x92\x00\xff\xff\x94\x00\x95\x00\x96\x00\xff\xff\x98\x00\x99\x00\xff\xff\xff\xff\xf3\x00\x8a\x00\xff\xff\xff\xff\x8d\x00\x8e\x00\xff\xff\x90\x00\x91\x00\x92\x00\xff\xff\x94\x00\x95\x00\x96\x00\xff\xff\x98\x00\x99\x00\xff\xff\xff\xff\xf3\x00\x07\x01\x08\x01\xff\xff\x0a\x01\x0b\x01\x0c\x01\x0d\x01\x0e\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xbe\x00\x05\x01\x17\x01\x18\x01\x19\x01\x07\x01\x08\x01\xff\xff\x0a\x01\x0b\x01\x0c\x01\x0d\x01\x0e\x01\xcb\x00\x12\x01\x24\x01\x14\x01\x15\x01\xff\xff\xbe\x00\xff\xff\x17\x01\x18\x01\x19\x01\xff\xff\xff\xff\xff\xff\x1f\x01\xff\xff\x21\x01\x22\x01\x23\x01\xcb\x00\x25\x01\x24\x01\x8a\x00\x28\x01\x29\x01\x8d\x00\x8e\x00\xff\xff\x90\x00\x91\x00\x92\x00\xff\xff\x94\x00\x95\x00\x96\x00\xff\xff\x98\x00\x99\x00\xff\xff\xff\xff\xf3\x00\x8a\x00\xff\xff\xff\xff\x8d\x00\x8e\x00\xff\xff\x90\x00\x91\x00\x92\x00\xff\xff\x94\x00\x95\x00\x96\x00\xff\xff\x98\x00\x99\x00\xff\xff\xff\xff\xf3\x00\x07\x01\x08\x01\xff\xff\x0a\x01\x0b\x01\x0c\x01\x0d\x01\x0e\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xbe\x00\xff\xff\x17\x01\x18\x01\x19\x01\x07\x01\x08\x01\xff\xff\x0a\x01\x0b\x01\x0c\x01\x0d\x01\x0e\x01\xcb\x00\xff\xff\x24\x01\xff\xff\xff\xff\xff\xff\xbe\x00\xff\xff\x17\x01\x18\x01\x19\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xcb\x00\xff\xff\x24\x01\x8a\x00\xff\xff\xff\xff\x8d\x00\x8e\x00\xff\xff\x90\x00\x91\x00\x92\x00\xff\xff\x94\x00\x95\x00\x96\x00\xff\xff\x98\x00\x99\x00\xff\xff\xff\xff\xf3\x00\x8a\x00\xff\xff\xff\xff\x8d\x00\x8e\x00\xff\xff\x90\x00\x91\x00\x92\x00\xff\xff\x94\x00\x95\x00\x96\x00\xff\xff\x98\x00\x99\x00\xff\xff\xff\xff\xf3\x00\x07\x01\x08\x01\xff\xff\x0a\x01\x0b\x01\x0c\x01\x0d\x01\x0e\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xbe\x00\xff\xff\x17\x01\x18\x01\x19\x01\x07\x01\x08\x01\xff\xff\x0a\x01\x0b\x01\x0c\x01\x0d\x01\x0e\x01\xcb\x00\xff\xff\x24\x01\xff\xff\xff\xff\xff\xff\xbe\x00\xff\xff\x17\x01\x18\x01\x19\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xcb\x00\xff\xff\x24\x01\x8a\x00\xff\xff\xff\xff\x8d\x00\x8e\x00\xff\xff\x90\x00\x91\x00\x92\x00\xff\xff\x94\x00\x95\x00\x96\x00\xff\xff\x98\x00\x99\x00\xff\xff\xff\xff\xf3\x00\x8a\x00\xff\xff\xff\xff\x8d\x00\x8e\x00\xff\xff\x90\x00\x91\x00\x92\x00\xff\xff\x94\x00\x95\x00\x96\x00\xff\xff\x98\x00\x99\x00\xff\xff\xff\xff\xf3\x00\x07\x01\x08\x01\xff\xff\x0a\x01\x0b\x01\x0c\x01\x0d\x01\x0e\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xbe\x00\xff\xff\x17\x01\x18\x01\x19\x01\x07\x01\x08\x01\xff\xff\x0a\x01\x0b\x01\x0c\x01\x0d\x01\x0e\x01\xcb\x00\xff\xff\x24\x01\xff\xff\x4a\x00\x4b\x00\xbe\x00\xff\xff\x17\x01\x18\x01\x19\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\xff\xff\xff\xff\xcb\x00\x5a\x00\x24\x01\xff\xff\xff\xff\xff\xff\x5f\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\xff\xff\x94\x00\x95\x00\x96\x00\xff\xff\x98\x00\x99\x00\xff\xff\xf3\x00\x9c\x00\x9d\x00\xff\xff\x72\x00\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\xf3\x00\x07\x01\x08\x01\xff\xff\x0a\x01\x0b\x01\x0c\x01\x0d\x01\x0e\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xbe\x00\x17\x01\x18\x01\x19\x01\x07\x01\x08\x01\xff\xff\x0a\x01\x0b\x01\x0c\x01\x0d\x01\x0e\x01\xff\xff\xcb\x00\x24\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x17\x01\x18\x01\x19\x01\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\xff\xff\x94\x00\x95\x00\x96\x00\x24\x01\x98\x00\x99\x00\xff\xff\xff\xff\x9c\x00\x9d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4a\x00\xff\xff\x4c\x00\xff\xff\xff\xff\xf3\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x56\x00\x94\x00\x95\x00\x96\x00\x5a\x00\x98\x00\x99\x00\xff\xff\xff\xff\x5f\x00\x9d\x00\xff\xff\xbe\x00\x07\x01\x08\x01\xff\xff\x0a\x01\x0b\x01\x0c\x01\x0d\x01\x0e\x01\xff\xff\xff\xff\xff\xff\xff\xff\xcb\x00\xff\xff\xff\xff\x72\x00\x17\x01\x18\x01\x19\x01\x76\x00\x77\x00\xff\xff\xff\xff\x7a\x00\x7b\x00\xff\xff\xff\xff\xff\xff\xff\xff\x24\x01\xbe\x00\xff\xff\xff\xff\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\xff\xff\x94\x00\x95\x00\x96\x00\xcb\x00\x98\x00\x99\x00\xff\xff\xff\xff\xff\xff\x9d\x00\xff\xff\xff\xff\xf3\x00\xff\xff\xff\xff\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xff\xff\xfb\x00\xff\xff\xff\xff\xff\xff\xff\x00\xff\xff\xff\xff\x02\x01\x03\x01\xff\xff\xff\xff\x07\x01\x08\x01\xff\xff\x0a\x01\x0b\x01\x0c\x01\x0d\x01\x0e\x01\xff\xff\xff\xff\xbe\x00\xf3\x00\xff\xff\xff\xff\xff\xff\xff\xff\x17\x01\x18\x01\x19\x01\xff\xff\x1a\x01\xff\xff\xff\xff\xcb\x00\x1e\x01\xff\xff\xff\xff\xff\xff\xff\xff\x24\x01\x24\x01\x07\x01\x08\x01\x27\x01\x0a\x01\x0b\x01\x0c\x01\x0d\x01\x0e\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x17\x01\x18\x01\x19\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4a\x00\x4b\x00\x24\x01\xff\xff\xff\xff\xf3\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x56\x00\x94\x00\x95\x00\x96\x00\x5a\x00\x98\x00\x99\x00\xff\xff\xff\xff\x5f\x00\xff\xff\x9e\x00\xff\xff\x07\x01\x08\x01\xff\xff\x0a\x01\x0b\x01\x0c\x01\x0d\x01\x0e\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x72\x00\x17\x01\x18\x01\x19\x01\x76\x00\x77\x00\xff\xff\xff\xff\x7a\x00\x7b\x00\xff\xff\xff\xff\xff\xff\xff\xff\x24\x01\xbe\x00\xff\xff\xff\xff\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\xff\xff\x94\x00\x95\x00\x96\x00\xcb\x00\x98\x00\x99\x00\xff\xff\xff\xff\xff\xff\x9d\x00\xff\xff\xff\xff\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\xff\xff\x94\x00\x95\x00\x96\x00\xff\xff\x98\x00\x99\x00\xff\xff\xff\xff\xff\xff\x9d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xbe\x00\xf3\x00\xff\xff\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\xff\xff\x94\x00\x95\x00\x96\x00\xcb\x00\x98\x00\x99\x00\xff\xff\xff\xff\xff\xff\xbe\x00\xff\xff\x07\x01\x08\x01\xa1\x00\x0a\x01\x0b\x01\x0c\x01\x0d\x01\x0e\x01\xff\xff\xff\xff\xff\xff\xcb\x00\xff\xff\xff\xff\xff\xff\xff\xff\x17\x01\x18\x01\x19\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x24\x01\xff\xff\xbe\x00\xf3\x00\xff\xff\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\xff\xff\x94\x00\x95\x00\x96\x00\xcb\x00\x98\x00\x99\x00\xff\xff\xff\xff\xff\xff\xff\xff\xf3\x00\x07\x01\x08\x01\xff\xff\x0a\x01\x0b\x01\x0c\x01\x0d\x01\x0e\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x17\x01\x18\x01\x19\x01\x07\x01\x08\x01\xff\xff\x0a\x01\x0b\x01\x0c\x01\x0d\x01\x0e\x01\xff\xff\xff\xff\x24\x01\xff\xff\xbe\x00\xf3\x00\xff\xff\xff\xff\x17\x01\x18\x01\x19\x01\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\xcb\x00\x94\x00\x95\x00\x96\x00\x24\x01\x98\x00\x99\x00\xff\xff\x07\x01\x08\x01\xff\xff\x0a\x01\x0b\x01\x0c\x01\x0d\x01\x0e\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x17\x01\x18\x01\x19\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x24\x01\xff\xff\xff\xff\xf3\x00\xff\xff\xff\xff\xbe\x00\xff\xff\xff\xff\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\xff\xff\x94\x00\x95\x00\x96\x00\xcb\x00\x98\x00\x99\x00\xff\xff\x07\x01\x08\x01\xff\xff\x0a\x01\x0b\x01\x0c\x01\x0d\x01\x0e\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x17\x01\x18\x01\x19\x01\x8d\x00\x8e\x00\xff\xff\x90\x00\x91\x00\x92\x00\xff\xff\x94\x00\x95\x00\x96\x00\x24\x01\x98\x00\x99\x00\xff\xff\xff\xff\xff\xff\xbe\x00\xf3\x00\xff\xff\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\xa6\x00\x94\x00\x95\x00\x96\x00\xcb\x00\x98\x00\x99\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x07\x01\x08\x01\xff\xff\x0a\x01\x0b\x01\x0c\x01\x0d\x01\x0e\x01\xff\xff\xff\xff\xff\xff\xff\xff\xbe\x00\xff\xff\xff\xff\xff\xff\x17\x01\x18\x01\x19\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xcb\x00\xff\xff\xff\xff\xff\xff\x24\x01\xff\xff\xbe\x00\xf3\x00\xff\xff\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\xff\xff\x94\x00\x95\x00\x96\x00\xcb\x00\x98\x00\x99\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x07\x01\x08\x01\xff\xff\x0a\x01\x0b\x01\x0c\x01\x0d\x01\x0e\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf3\x00\xff\xff\xff\xff\x17\x01\x18\x01\x19\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x24\x01\xff\xff\xbe\x00\xf3\x00\x07\x01\x08\x01\xff\xff\x0a\x01\x0b\x01\x0c\x01\x0d\x01\x0e\x01\xff\xff\xff\xff\xff\xff\xcb\x00\xff\xff\xff\xff\xff\xff\xff\xff\x17\x01\x18\x01\x19\x01\x07\x01\x08\x01\xff\xff\x0a\x01\x0b\x01\x0c\x01\x0d\x01\x0e\x01\xff\xff\xff\xff\x24\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x17\x01\x18\x01\x19\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x24\x01\xff\xff\xff\xff\xf3\x00\xff\xff\xff\xff\x8d\x00\x8e\x00\xff\xff\x90\x00\x91\x00\x92\x00\xff\xff\x94\x00\x95\x00\x96\x00\xff\xff\x98\x00\x99\x00\xff\xff\xff\xff\xff\xff\xff\xff\x07\x01\x08\x01\xff\xff\x0a\x01\x0b\x01\x0c\x01\x0d\x01\x0e\x01\xa6\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x17\x01\x18\x01\x19\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x24\x01\x8d\x00\x8e\x00\xbe\x00\x90\x00\x91\x00\x92\x00\xff\xff\x94\x00\x95\x00\x96\x00\xff\xff\x98\x00\x99\x00\xff\xff\xff\xff\xcb\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xa6\x00\xff\xff\xfc\x00\xff\xff\xfe\x00\xff\xff\xff\xff\xff\xff\x02\x01\x8d\x00\x8e\x00\x05\x01\x90\x00\x91\x00\x92\x00\xff\xff\x94\x00\x95\x00\x96\x00\xff\xff\x98\x00\x99\x00\xff\xff\x11\x01\xbe\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf3\x00\xff\xff\x1a\x01\xff\xff\xa6\x00\xff\xff\x1e\x01\xcb\x00\xff\xff\xff\xff\x22\x01\x23\x01\x24\x01\x25\x01\x26\x01\x27\x01\x28\x01\x29\x01\xff\xff\xff\xff\x07\x01\x08\x01\xff\xff\x0a\x01\x0b\x01\x0c\x01\x0d\x01\x0e\x01\xbe\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x17\x01\x18\x01\x19\x01\xff\xff\xff\xff\xcb\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf3\x00\xff\xff\x24\x01\x8d\x00\x8e\x00\xff\xff\x90\x00\x91\x00\x92\x00\xff\xff\x94\x00\x95\x00\x96\x00\xff\xff\x98\x00\x99\x00\xff\xff\xff\xff\xff\xff\xff\xff\x07\x01\x08\x01\xff\xff\x0a\x01\x0b\x01\x0c\x01\x0d\x01\x0e\x01\xa6\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf3\x00\xff\xff\x17\x01\x18\x01\x19\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x24\x01\xff\xff\xff\xff\xbe\x00\xff\xff\x07\x01\x08\x01\xff\xff\x0a\x01\x0b\x01\x0c\x01\x0d\x01\x0e\x01\xff\xff\xff\xff\xff\xff\xcb\x00\xff\xff\xff\xff\xff\xff\xff\xff\x17\x01\x18\x01\x19\x01\x8d\x00\x8e\x00\xff\xff\x90\x00\x91\x00\x92\x00\xff\xff\x94\x00\x95\x00\x96\x00\x24\x01\x98\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\xa6\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf3\x00\xff\xff\xff\xff\x8d\x00\x8e\x00\xff\xff\x90\x00\x91\x00\x92\x00\xff\xff\x94\x00\x95\x00\x96\x00\xff\xff\x98\x00\x99\x00\xff\xff\xbe\x00\xff\xff\xff\xff\x07\x01\x08\x01\xff\xff\x0a\x01\x0b\x01\x0c\x01\x0d\x01\x0e\x01\xa6\x00\xff\xff\xcb\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x17\x01\x18\x01\x19\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x24\x01\xff\xff\xff\xff\xbe\x00\xff\xff\xff\xff\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\xff\xff\x94\x00\x95\x00\x96\x00\xcb\x00\x98\x00\x99\x00\xff\xff\xff\xff\xf3\x00\xff\xff\xff\xff\xff\xff\x8d\x00\x8e\x00\xff\xff\x90\x00\x91\x00\x92\x00\xff\xff\x94\x00\x95\x00\x96\x00\xff\xff\x98\x00\x99\x00\xff\xff\xff\xff\xff\xff\x07\x01\x08\x01\xff\xff\x0a\x01\x0b\x01\x0c\x01\x0d\x01\x0e\x01\xff\xff\xa6\x00\x4a\x00\xff\xff\xff\xff\xff\xff\xbe\x00\xf3\x00\x17\x01\x18\x01\x19\x01\xff\xff\xff\xff\xff\xff\x56\x00\xff\xff\xff\xff\xff\xff\x5a\x00\xcb\x00\xff\xff\x24\x01\xff\xff\x5f\x00\xff\xff\xbe\x00\xff\xff\x07\x01\x08\x01\xff\xff\x0a\x01\x0b\x01\x0c\x01\x0d\x01\x0e\x01\xff\xff\xff\xff\xff\xff\xcb\x00\xff\xff\xff\xff\xff\xff\x72\x00\x17\x01\x18\x01\x19\x01\x76\x00\x77\x00\xff\xff\xff\xff\x7a\x00\x7b\x00\xff\xff\xff\xff\xff\xff\xff\xff\x24\x01\x8d\x00\x8e\x00\xf3\x00\x90\x00\x91\x00\x92\x00\xff\xff\x94\x00\x95\x00\x96\x00\xff\xff\x98\x00\x99\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf3\x00\x07\x01\x08\x01\xff\xff\x0a\x01\x0b\x01\x0c\x01\x0d\x01\x0e\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x17\x01\x18\x01\x19\x01\x07\x01\x08\x01\xff\xff\x0a\x01\x0b\x01\x0c\x01\x0d\x01\x0e\x01\xbe\x00\xff\xff\x24\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x17\x01\x18\x01\x19\x01\xff\xff\xff\xff\xcb\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x8d\x00\x8e\x00\x24\x01\x90\x00\x91\x00\x92\x00\xff\xff\x94\x00\x95\x00\x96\x00\xff\xff\x98\x00\x99\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x8d\x00\x8e\x00\xff\xff\x90\x00\x91\x00\x92\x00\xff\xff\x94\x00\x95\x00\x96\x00\xff\xff\x98\x00\x99\x00\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\xbe\x00\xff\xff\xff\xff\xff\xff\xff\xff\x07\x01\x08\x01\xff\xff\x0a\x01\x0b\x01\x0c\x01\x0d\x01\x0e\x01\xcb\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xbe\x00\xff\xff\x17\x01\x18\x01\x19\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xcb\x00\xff\xff\x24\x01\xff\xff\xff\xff\xff\xff\x8d\x00\x8e\x00\xff\xff\x90\x00\x91\x00\x92\x00\xff\xff\x94\x00\x95\x00\x96\x00\xff\xff\x98\x00\x99\x00\xff\xff\xff\xff\xf3\x00\xff\xff\xff\xff\xff\xff\x8d\x00\x8e\x00\xff\xff\x90\x00\x91\x00\x92\x00\xff\xff\x94\x00\x95\x00\x96\x00\xff\xff\x98\x00\x99\x00\xff\xff\xff\xff\xf3\x00\x07\x01\x08\x01\xff\xff\x0a\x01\x0b\x01\x0c\x01\x0d\x01\x0e\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xbe\x00\xff\xff\x17\x01\x18\x01\x19\x01\x07\x01\x08\x01\xff\xff\x0a\x01\x0b\x01\x0c\x01\x0d\x01\x0e\x01\xcb\x00\xff\xff\x24\x01\xff\xff\xff\xff\xff\xff\xbe\x00\xff\xff\x17\x01\x18\x01\x19\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xcb\x00\xff\xff\x24\x01\xff\xff\xff\xff\xff\xff\x8d\x00\x8e\x00\xff\xff\x90\x00\x91\x00\x92\x00\xff\xff\x94\x00\x95\x00\x96\x00\xff\xff\x98\x00\x99\x00\xff\xff\xff\xff\xf3\x00\xff\xff\xff\xff\xff\xff\x8d\x00\x8e\x00\xff\xff\x90\x00\x91\x00\x92\x00\xff\xff\x94\x00\x95\x00\x96\x00\xff\xff\x98\x00\x99\x00\xff\xff\xff\xff\xf3\x00\x07\x01\x08\x01\xff\xff\x0a\x01\x0b\x01\x0c\x01\x0d\x01\x0e\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xbe\x00\xff\xff\x17\x01\x18\x01\x19\x01\x07\x01\x08\x01\xff\xff\x0a\x01\x0b\x01\x0c\x01\x0d\x01\x0e\x01\xcb\x00\xff\xff\x24\x01\xff\xff\xff\xff\xff\xff\xbe\x00\xff\xff\x17\x01\x18\x01\x19\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xcb\x00\xff\xff\x24\x01\xff\xff\xff\xff\xff\xff\x8d\x00\x8e\x00\xff\xff\x90\x00\x91\x00\x92\x00\xff\xff\x94\x00\x95\x00\x96\x00\xff\xff\x98\x00\x99\x00\xff\xff\xff\xff\xf3\x00\xff\xff\xff\xff\xff\xff\x8d\x00\x8e\x00\xff\xff\x90\x00\x91\x00\x92\x00\xff\xff\x94\x00\x95\x00\x96\x00\xff\xff\x98\x00\x99\x00\xff\xff\xff\xff\xf3\x00\x07\x01\x08\x01\xff\xff\x0a\x01\x0b\x01\x0c\x01\x0d\x01\x0e\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xbe\x00\xff\xff\x17\x01\x18\x01\x19\x01\x07\x01\x08\x01\xff\xff\x0a\x01\x0b\x01\x0c\x01\x0d\x01\x0e\x01\xcb\x00\xff\xff\x24\x01\xff\xff\xff\xff\xff\xff\xbe\x00\xff\xff\x17\x01\x18\x01\x19\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xcb\x00\xff\xff\x24\x01\xff\xff\xff\xff\xff\xff\x8d\x00\xff\xff\xff\xff\xff\xff\x91\x00\x92\x00\xff\xff\x94\x00\x95\x00\x96\x00\xff\xff\x98\x00\x99\x00\xff\xff\xff\xff\xf3\x00\xff\xff\xff\xff\xff\xff\x8d\x00\xff\xff\xff\xff\xff\xff\xff\xff\x92\x00\xff\xff\x94\x00\x95\x00\x96\x00\xff\xff\x98\x00\x99\x00\xff\xff\xff\xff\xf3\x00\x07\x01\x08\x01\xff\xff\x0a\x01\x0b\x01\x0c\x01\x0d\x01\x0e\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xbe\x00\xff\xff\x17\x01\x18\x01\x19\x01\x07\x01\x08\x01\xff\xff\x0a\x01\x0b\x01\x0c\x01\x0d\x01\x0e\x01\xcb\x00\xff\xff\x24\x01\xff\xff\xff\xff\xff\xff\xbe\x00\xff\xff\x17\x01\x18\x01\x19\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xcb\x00\xff\xff\x24\x01\xff\xff\xff\xff\xff\xff\x8d\x00\xff\xff\xff\xff\xff\xff\xff\xff\x92\x00\xff\xff\x94\x00\x95\x00\x96\x00\xff\xff\x98\x00\x99\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x8d\x00\xff\xff\xff\xff\xff\xff\xff\xff\x92\x00\xff\xff\x94\x00\x95\x00\x96\x00\xff\xff\x98\x00\x99\x00\xff\xff\xff\xff\xff\xff\x07\x01\x08\x01\xff\xff\x0a\x01\x0b\x01\x0c\x01\x0d\x01\x0e\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xbe\x00\xff\xff\x17\x01\x18\x01\x19\x01\x07\x01\x08\x01\xff\xff\x0a\x01\x0b\x01\x0c\x01\x0d\x01\x0e\x01\xcb\x00\xff\xff\x24\x01\xff\xff\xff\xff\xff\xff\xbe\x00\xff\xff\x17\x01\x18\x01\x19\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xcb\x00\xff\xff\x24\x01\xff\xff\xff\xff\xff\xff\x8d\x00\xff\xff\xff\xff\xff\xff\xff\xff\x92\x00\xff\xff\x94\x00\x95\x00\x96\x00\xff\xff\x98\x00\x99\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x8d\x00\xff\xff\xff\xff\xff\xff\xff\xff\x92\x00\xff\xff\x94\x00\x95\x00\x96\x00\xff\xff\x98\x00\x99\x00\xff\xff\xff\xff\xff\xff\x07\x01\x08\x01\xff\xff\x0a\x01\x0b\x01\x0c\x01\x0d\x01\x0e\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xbe\x00\xff\xff\x17\x01\x18\x01\x19\x01\x07\x01\x08\x01\xff\xff\x0a\x01\x0b\x01\x0c\x01\x0d\x01\x0e\x01\xcb\x00\xff\xff\x24\x01\xff\xff\xff\xff\xff\xff\xbe\x00\xff\xff\x17\x01\x18\x01\x19\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xcb\x00\xff\xff\x24\x01\xff\xff\xff\xff\xff\xff\x8d\x00\xff\xff\xff\xff\xff\xff\xff\xff\x92\x00\xff\xff\x94\x00\x95\x00\x96\x00\xff\xff\x98\x00\x99\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x8d\x00\xff\xff\xff\xff\xff\xff\xff\xff\x92\x00\xff\xff\x94\x00\x95\x00\x96\x00\xff\xff\x98\x00\x99\x00\xff\xff\xff\xff\xff\xff\x07\x01\x08\x01\xff\xff\x0a\x01\x0b\x01\x0c\x01\x0d\x01\x0e\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xbe\x00\xff\xff\x17\x01\x18\x01\x19\x01\x07\x01\x08\x01\xff\xff\x0a\x01\x0b\x01\x0c\x01\x0d\x01\x0e\x01\xcb\x00\xff\xff\x24\x01\xff\xff\xff\xff\xff\xff\xbe\x00\xff\xff\x17\x01\x18\x01\x19\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xcb\x00\xff\xff\x24\x01\xff\xff\xff\xff\xff\xff\x8d\x00\xff\xff\xff\xff\xff\xff\xff\xff\x92\x00\xff\xff\x94\x00\x95\x00\x96\x00\xff\xff\x98\x00\x99\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x8d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x95\x00\x96\x00\xff\xff\x98\x00\x99\x00\xff\xff\xff\xff\x07\x01\x08\x01\xff\xff\x0a\x01\x0b\x01\x0c\x01\x0d\x01\x0e\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xbe\x00\xff\xff\x17\x01\x18\x01\x19\x01\x07\x01\x08\x01\xff\xff\x0a\x01\x0b\x01\x0c\x01\x0d\x01\x0e\x01\xcb\x00\xff\xff\x24\x01\xff\xff\xff\xff\xff\xff\x8d\x00\xbe\x00\x17\x01\x18\x01\x19\x01\xff\xff\xff\xff\xff\xff\x95\x00\x96\x00\xff\xff\x98\x00\x99\x00\xff\xff\xcb\x00\x24\x01\xff\xff\xff\xff\xff\xff\xff\xff\x8d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x95\x00\x96\x00\xff\xff\x98\x00\x99\x00\xae\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xbe\x00\xff\xff\xff\xff\xff\xff\xff\xff\x07\x01\x08\x01\xff\xff\x0a\x01\x0b\x01\x0c\x01\x0d\x01\x0e\x01\xcb\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xbe\x00\x17\x01\x18\x01\x19\x01\xff\xff\x07\x01\x08\x01\xff\xff\x0a\x01\x0b\x01\x0c\x01\x0d\x01\x0e\x01\xcb\x00\x24\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x17\x01\x18\x01\x19\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x24\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\x07\x01\x08\x01\xff\xff\x0a\x01\x0b\x01\x0c\x01\x0d\x01\x0e\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x17\x01\x18\x01\x19\x01\xff\xff\x07\x01\x08\x01\xff\xff\x0a\x01\x0b\x01\x0c\x01\x0d\x01\x0e\x01\xff\xff\x24\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x17\x01\x18\x01\x19\x01\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\x24\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\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\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\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\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\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\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\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\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\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\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\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\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\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\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\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\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\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\xff\xff\x8f\x00\xff\xff\x91\x00\x92\x00\x93\x00\x94\x00\x95\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\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\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\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\xff\xff\x8f\x00\xff\xff\x91\x00\x92\x00\x93\x00\x94\x00\x95\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\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\x50\x00\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\x65\x00\xff\xff\x67\x00\x68\x00\xff\xff\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\xff\xff\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\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\x91\x00\x09\x00\x0a\x00\x94\x00\x95\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\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\xff\xff\x8f\x00\xff\xff\x91\x00\x92\x00\x93\x00\x94\x00\x95\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\xff\xff\x8f\x00\xff\xff\x91\x00\x92\x00\x93\x00\x94\x00\x95\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\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\xff\xff\x8f\x00\xff\xff\x91\x00\x92\x00\x93\x00\x94\x00\x95\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\xff\xff\x8f\x00\xff\xff\x91\x00\x92\x00\x93\x00\x94\x00\x95\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\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\xff\xff\x8f\x00\xff\xff\x91\x00\x92\x00\x93\x00\x94\x00\x95\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\xff\xff\x8f\x00\xff\xff\x91\x00\x92\x00\x93\x00\x94\x00\x95\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\x60\x00\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\xff\xff\x8f\x00\xff\xff\x91\x00\x92\x00\x93\x00\x94\x00\x95\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\xff\xff\x8f\x00\xff\xff\x91\x00\x92\x00\x93\x00\x94\x00\x95\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\xff\xff\x8f\x00\xff\xff\x91\x00\x92\x00\x93\x00\x94\x00\x95\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\xff\xff\x8f\x00\xff\xff\x91\x00\x92\x00\x93\x00\x94\x00\x95\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\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\xff\xff\x8f\x00\xff\xff\x91\x00\x92\x00\x93\x00\x94\x00\x95\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\xff\xff\x8f\x00\xff\xff\x91\x00\x92\x00\x93\x00\x94\x00\x95\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\xff\xff\x8f\x00\xff\xff\x91\x00\x92\x00\x93\x00\x94\x00\x95\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\xff\xff\x8f\x00\xff\xff\x91\x00\x92\x00\x93\x00\x94\x00\x95\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\xff\xff\x8f\x00\xff\xff\x91\x00\x92\x00\x93\x00\x94\x00\x95\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\xff\xff\x8f\x00\xff\xff\x91\x00\x92\x00\x93\x00\x94\x00\x95\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\xff\xff\x8f\x00\xff\xff\x91\x00\x92\x00\x93\x00\x94\x00\x95\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\xff\xff\x8f\x00\xff\xff\x91\x00\x92\x00\x93\x00\x94\x00\x95\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\xff\xff\x8f\x00\xff\xff\x91\x00\x92\x00\x93\x00\x94\x00\x95\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\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\xff\xff\x8f\x00\xff\xff\x91\x00\x92\x00\x93\x00\x94\x00\x95\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\x50\x00\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\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\xff\xff\x8f\x00\xff\xff\x91\x00\x92\x00\x93\x00\x94\x00\x95\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\xff\xff\x8f\x00\xff\xff\x91\x00\x92\x00\x93\x00\x94\x00\x95\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\xff\xff\x8f\x00\xff\xff\x91\x00\x92\x00\x93\x00\x94\x00\x95\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\xff\xff\x8f\x00\xff\xff\x91\x00\x92\x00\x93\x00\x94\x00\x95\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\xff\xff\x8f\x00\xff\xff\x91\x00\x92\x00\x93\x00\x94\x00\x95\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\xff\xff\x8f\x00\xff\xff\x91\x00\x92\x00\x93\x00\x94\x00\x95\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\xff\xff\x8f\x00\xff\xff\x91\x00\x92\x00\x93\x00\x94\x00\x95\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\xff\xff\x8f\x00\xff\xff\x91\x00\x92\x00\x93\x00\x94\x00\x95\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\xff\xff\x8f\x00\xff\xff\x91\x00\x92\x00\x93\x00\x94\x00\x95\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\xff\xff\x8f\x00\xff\xff\x91\x00\x92\x00\x93\x00\x94\x00\x95\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\xff\xff\x8f\x00\xff\xff\x91\x00\x92\x00\x93\x00\x94\x00\x95\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\xff\xff\x8f\x00\xff\xff\x91\x00\x92\x00\x93\x00\x94\x00\x95\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\xff\xff\x8f\x00\xff\xff\x91\x00\x92\x00\x93\x00\x94\x00\x95\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\xff\xff\x8f\x00\xff\xff\x91\x00\x92\x00\x93\x00\x94\x00\x95\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\xff\xff\x8f\x00\xff\xff\x91\x00\x92\x00\x93\x00\x94\x00\x95\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\xff\xff\x8f\x00\xff\xff\x91\x00\x92\x00\x93\x00\x94\x00\x95\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\x4e\x00\x4f\x00\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\xff\xff\x8f\x00\xff\xff\x91\x00\x92\x00\x93\x00\x94\x00\x95\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\xff\xff\x8f\x00\xff\xff\x91\x00\x92\x00\x93\x00\x94\x00\x95\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\xff\xff\x8f\x00\xff\xff\x91\x00\x92\x00\x93\x00\x94\x00\x95\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\xff\xff\x8f\x00\xff\xff\x91\x00\x92\x00\x93\x00\x94\x00\x95\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\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\xff\xff\x8f\x00\xff\xff\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\x0a\x00\x74\x00\x75\x00\x76\x00\xff\xff\xff\xff\xff\xff\x11\x00\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\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\xff\xff\x8f\x00\xff\xff\x91\x00\x92\x00\x93\x00\x94\x00\x95\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\xff\xff\x8f\x00\xff\xff\x91\x00\x92\x00\x93\x00\x94\x00\x95\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\xff\xff\x8f\x00\xff\xff\x91\x00\x92\x00\x93\x00\x94\x00\x95\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\xff\xff\x8f\x00\xff\xff\x91\x00\x92\x00\x93\x00\x94\x00\x95\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\xff\xff\x8f\x00\xff\xff\x91\x00\x92\x00\x93\x00\x94\x00\x95\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\xff\xff\x8f\x00\xff\xff\x91\x00\x92\x00\x93\x00\x94\x00\x95\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\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\xff\xff\x8f\x00\xff\xff\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\x0a\x00\x74\x00\x75\x00\xff\xff\xff\xff\xff\xff\xff\xff\x11\x00\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\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\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\xff\xff\x8f\x00\xff\xff\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\x0a\x00\x74\x00\x75\x00\xff\xff\xff\xff\xff\xff\xff\xff\x11\x00\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\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\xff\xff\x8f\x00\xff\xff\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x01\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\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\x81\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\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\xff\xff\x79\x00\x7a\x00\x7b\x00\x01\x00\x02\x00\xff\xff\xff\xff\x80\x00\x81\x00\x82\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\x91\x00\xff\xff\xff\xff\x94\x00\x95\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\xff\xff\x79\x00\x7a\x00\x7b\x00\xff\xff\xff\xff\x01\x00\x02\x00\x80\x00\x81\x00\x82\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\x91\x00\x15\x00\xff\xff\x94\x00\x95\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\x01\x00\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\xff\xff\x8f\x00\xff\xff\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x01\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\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\xff\xff\x79\x00\x7a\x00\x7b\x00\xff\xff\xff\xff\x7e\x00\xff\xff\x80\x00\x81\x00\x82\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\x91\x00\xff\xff\xff\xff\x94\x00\x95\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\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\xff\xff\x79\x00\x7a\x00\x7b\x00\xff\xff\xff\xff\x7e\x00\xff\xff\x80\x00\x81\x00\x82\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\x91\x00\xff\xff\xff\xff\x94\x00\x95\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\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\xff\xff\x79\x00\x7a\x00\x7b\x00\xff\xff\xff\xff\x7e\x00\xff\xff\x80\x00\x81\x00\x82\x00\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\x91\x00\x10\x00\xff\xff\x94\x00\x95\x00\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\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\xff\xff\x79\x00\x7a\x00\x7b\x00\xff\xff\xff\xff\x01\x00\x02\x00\x80\x00\x81\x00\x82\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\x91\x00\x15\x00\xff\xff\x94\x00\x95\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\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\xff\xff\x79\x00\x7a\x00\x7b\x00\xff\xff\xff\xff\x7e\x00\xff\xff\x80\x00\x81\x00\x82\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\x91\x00\xff\xff\xff\xff\x94\x00\x95\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\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\xff\xff\x79\x00\x7a\x00\x7b\x00\xff\xff\xff\xff\x7e\x00\xff\xff\x80\x00\x81\x00\x82\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\x91\x00\x10\x00\xff\xff\x94\x00\x95\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\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\xff\xff\x79\x00\x7a\x00\x7b\x00\xff\xff\xff\xff\x01\x00\x02\x00\x80\x00\x81\x00\x82\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\x91\x00\x15\x00\xff\xff\x94\x00\x95\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\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\xff\xff\x79\x00\x7a\x00\x7b\x00\xff\xff\xff\xff\x7e\x00\xff\xff\x80\x00\x81\x00\x82\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\x91\x00\xff\xff\xff\xff\x94\x00\x95\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\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\xff\xff\x79\x00\x7a\x00\x7b\x00\xff\xff\xff\xff\x7e\x00\xff\xff\x80\x00\x81\x00\x82\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\x91\x00\xff\xff\xff\xff\x94\x00\x95\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\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\xff\xff\x79\x00\x7a\x00\x7b\x00\xff\xff\xff\xff\x01\x00\x02\x00\x80\x00\x81\x00\x82\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\x91\x00\x15\x00\xff\xff\x94\x00\x95\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\xff\xff\x79\x00\x7a\x00\x7b\x00\xff\xff\xff\xff\x01\x00\x02\x00\x80\x00\x81\x00\x82\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\x91\x00\x15\x00\xff\xff\x94\x00\x95\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\xff\xff\x79\x00\x7a\x00\x7b\x00\xff\xff\xff\xff\x7e\x00\xff\xff\x80\x00\x81\x00\x82\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\x91\x00\xff\xff\xff\xff\x94\x00\x95\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\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\xff\xff\x79\x00\x7a\x00\x7b\x00\xff\xff\xff\xff\x7e\x00\xff\xff\x80\x00\x81\x00\x82\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\x91\x00\xff\xff\xff\xff\x94\x00\x95\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\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\xff\xff\x79\x00\x7a\x00\x7b\x00\xff\xff\xff\xff\x7e\x00\xff\xff\x80\x00\x81\x00\x82\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\x91\x00\xff\xff\xff\xff\x94\x00\x95\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\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\xff\xff\x79\x00\x7a\x00\x7b\x00\xff\xff\xff\xff\x01\x00\x02\x00\x80\x00\x81\x00\x82\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\x91\x00\x15\x00\xff\xff\x94\x00\x95\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\xff\xff\x79\x00\x7a\x00\x7b\x00\xff\xff\xff\xff\x01\x00\x02\x00\x80\x00\x81\x00\x82\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\x91\x00\x15\x00\xff\xff\x94\x00\x95\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\xff\xff\x79\x00\x7a\x00\x7b\x00\xff\xff\xff\xff\x01\x00\x02\x00\x80\x00\x81\x00\x82\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\x91\x00\x15\x00\xff\xff\x94\x00\x95\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\xff\xff\x79\x00\x7a\x00\x7b\x00\xff\xff\xff\xff\x01\x00\x02\x00\x80\x00\x81\x00\x82\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\x91\x00\x15\x00\xff\xff\x94\x00\x95\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\xff\xff\x79\x00\x7a\x00\x7b\x00\x01\x00\x02\x00\xff\xff\xff\xff\x80\x00\x81\x00\x82\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\x91\x00\xff\xff\xff\xff\x94\x00\x95\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\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\xff\xff\x79\x00\x7a\x00\x7b\x00\x01\x00\x02\x00\xff\xff\xff\xff\x80\x00\x81\x00\x82\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\x91\x00\xff\xff\xff\xff\x94\x00\x95\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\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\x57\x00\x58\x00\xff\xff\x5a\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\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\xff\xff\x73\x00\x74\x00\x75\x00\xff\xff\xff\xff\xff\xff\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\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x91\x00\xff\xff\xff\xff\x94\x00\x95\x00\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\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\xbe\x00\xbf\x00\xc0\x00\xff\xff\xc2\x00\x6a\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xff\xff\xff\xff\xcb\x00\xcc\x00\x74\x00\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\xe2\x00\xe3\x00\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\xff\xff\xf3\x00\xf4\x00\xff\xff\xff\xff\xff\xff\xff\xff\x74\x00\xff\xff\xff\xff\xff\xff\xfd\x00\xfe\x00\xff\xff\xff\xff\xff\xff\x02\x01\x03\x01\xff\xff\xff\xff\x81\x00\xff\xff\xbe\x00\xbf\x00\xc0\x00\xff\xff\xc2\x00\xff\xff\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xff\xff\xff\xff\xcb\x00\xcc\x00\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x01\xff\xff\x1d\x01\x1e\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x24\x01\xff\xff\x26\x01\x27\x01\xff\xff\xff\xff\x2a\x01\x2b\x01\xe2\x00\xe3\x00\xff\xff\xff\xff\xff\xff\xff\xff\x32\x01\xff\xff\xff\xff\x35\x01\xff\xff\x37\x01\xff\xff\x39\x01\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\xfd\x00\xfe\x00\xff\xff\xff\xff\xff\xff\x02\x01\x03\x01\xff\xff\xff\xff\xff\xff\xbe\x00\xbf\x00\xc0\x00\xff\xff\xc2\x00\xff\xff\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xff\xff\xff\xff\xcb\x00\xcc\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x01\xff\xff\x1d\x01\x1e\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x24\x01\xff\xff\x26\x01\x27\x01\xff\xff\xff\xff\x2a\x01\xe2\x00\xe3\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x32\x01\xff\xff\xff\xff\x35\x01\xff\xff\x37\x01\xff\xff\x39\x01\xff\xff\xff\xff\xf3\x00\xf4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfd\x00\xfe\x00\xff\xff\xff\xff\xff\xff\x02\x01\x03\x01\xff\xff\xff\xff\xff\xff\xbe\x00\xbf\x00\xc0\x00\xff\xff\xc2\x00\xff\xff\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xff\xff\xff\xff\xcb\x00\xcc\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x01\xff\xff\x1d\x01\x1e\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x24\x01\xff\xff\x26\x01\x27\x01\xff\xff\xff\xff\x2a\x01\xe2\x00\xe3\x00\x49\x00\x4a\x00\x4b\x00\xff\xff\xff\xff\x32\x01\xff\xff\x50\x00\x35\x01\x52\x00\x37\x01\xff\xff\x39\x01\x56\x00\xff\xff\xf3\x00\xf4\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\xff\xff\xff\xff\xfd\x00\xfe\x00\xff\xff\x65\x00\xbe\x00\x02\x01\x03\x01\x69\x00\xff\xff\x6b\x00\xff\xff\x6d\x00\xc6\x00\xc7\x00\xc8\x00\x71\x00\x72\x00\xcb\x00\xcc\x00\xff\xff\x76\x00\x77\x00\xff\xff\xff\xff\x7a\x00\x7b\x00\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x01\xff\xff\x1d\x01\x1e\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x24\x01\xff\xff\x26\x01\x27\x01\xe5\x00\xe6\x00\x2a\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x32\x01\xff\xff\xff\xff\xff\xff\xf3\x00\xf4\x00\xff\xff\x39\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfd\x00\xfe\x00\xff\xff\xff\xff\xff\xff\x02\x01\x03\x01\xff\xff\xbe\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc6\x00\xc7\x00\xc8\x00\xff\xff\xff\xff\xcb\x00\xcc\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x01\xff\xff\x1d\x01\x1e\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x24\x01\xff\xff\x26\x01\x27\x01\xff\xff\xff\xff\x2a\x01\x2b\x01\xe5\x00\xe6\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x34\x01\xff\xff\x36\x01\xff\xff\x38\x01\xff\xff\xf3\x00\xf4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfd\x00\xfe\x00\xff\xff\xff\xff\xff\xff\x02\x01\x03\x01\xbe\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc6\x00\xc7\x00\xc8\x00\xff\xff\xff\xff\xcb\x00\xcc\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x01\xff\xff\x1d\x01\x1e\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x24\x01\xff\xff\x26\x01\x27\x01\xff\xff\xff\xff\x2a\x01\xe5\x00\xe6\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xbe\x00\x34\x01\xff\xff\x36\x01\xff\xff\x38\x01\xf3\x00\xf4\x00\xc6\x00\xc7\x00\xc8\x00\xff\xff\xff\xff\xcb\x00\xcc\x00\xff\xff\xfd\x00\xfe\x00\xff\xff\xff\xff\xff\xff\x02\x01\x03\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\xe5\x00\xe6\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x01\xff\xff\x1d\x01\x1e\x01\xff\xff\xff\xff\xff\xff\xf3\x00\xf4\x00\x24\x01\xff\xff\x26\x01\x27\x01\xff\xff\xff\xff\x2a\x01\xff\xff\xfd\x00\xfe\x00\xff\xff\xff\xff\xff\xff\x02\x01\x03\x01\xff\xff\x34\x01\xff\xff\x36\x01\xff\xff\x38\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\x1b\x01\xff\xff\x1d\x01\x1e\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x24\x01\x15\x00\x26\x01\x27\x01\xff\xff\x19\x00\x2a\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\x38\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\xff\xff\xff\xff\x68\x00\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x02\x00\x72\x00\xff\xff\x74\x00\x75\x00\x76\x00\x77\x00\x09\x00\x79\x00\xff\xff\x7b\x00\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\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\x6a\x00\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x71\x00\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\x6a\x00\x02\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\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\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\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\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\xbe\x00\xff\xff\xff\xff\xc1\x00\xc2\x00\xff\xff\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\x56\x00\xff\xff\xcb\x00\xcc\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\xf3\x00\xf4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfd\x00\xfe\x00\xff\xff\xff\xff\xbe\x00\x02\x01\x03\x01\xc1\x00\xc2\x00\xff\xff\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xff\xff\xff\xff\xcb\x00\xcc\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x01\xff\xff\x1d\x01\x1e\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x24\x01\xff\xff\x26\x01\x27\x01\xff\xff\xff\xff\x2a\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x33\x01\xff\xff\xff\xff\xf3\x00\xf4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfd\x00\xfe\x00\xff\xff\xff\xff\xff\xff\x02\x01\x03\x01\xbe\x00\xbf\x00\xc0\x00\xff\xff\xc2\x00\xff\xff\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xff\xff\xcb\x00\xcc\x00\xff\xff\xff\xff\xff\xff\xff\xff\xd1\x00\xd2\x00\xff\xff\xff\xff\x1b\x01\xff\xff\x1d\x01\x1e\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x24\x01\xff\xff\x26\x01\x27\x01\xff\xff\xff\xff\x2a\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x33\x01\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\xfd\x00\xfe\x00\xff\xff\xff\xff\xff\xff\x02\x01\x03\x01\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\x13\x01\x14\x01\xff\xff\x16\x01\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x01\xff\xff\x1d\x01\x1e\x01\xff\xff\x20\x01\x21\x01\x22\x01\x23\x01\x24\x01\x25\x01\x26\x01\x27\x01\x28\x01\x29\x01\x2a\x01\xff\xff\xff\xff\x2d\x01\xff\xff\x2f\x01\xff\xff\x02\x00\x32\x01\xbe\x00\xbf\x00\xc0\x00\xff\xff\xc2\x00\x09\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xff\xff\xcb\x00\xcc\x00\xff\xff\xff\xff\x15\x00\xff\xff\xd1\x00\xd2\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\xf3\x00\xf4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfd\x00\xfe\x00\xff\xff\xff\xff\xff\xff\x02\x01\x03\x01\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\x13\x01\x14\x01\xff\xff\x16\x01\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x01\xff\xff\x1d\x01\x1e\x01\xff\xff\x20\x01\x21\x01\x22\x01\x23\x01\x24\x01\x25\x01\x26\x01\x27\x01\x28\x01\x29\x01\x2a\x01\xff\xff\xff\xff\x2d\x01\x74\x00\x2f\x01\xff\xff\x02\x00\x32\x01\xbe\x00\xbf\x00\xc0\x00\xff\xff\xc2\x00\x09\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xff\xff\xff\xff\xcb\x00\xcc\x00\xff\xff\xff\xff\x15\x00\xff\xff\xd1\x00\xd2\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\xf3\x00\xf4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfd\x00\xfe\x00\xff\xff\xff\xff\xff\xff\x02\x01\x03\x01\xff\xff\x05\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\x13\x01\x14\x01\xff\xff\x16\x01\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x01\xff\xff\x1d\x01\x1e\x01\xff\xff\x20\x01\x21\x01\xff\xff\x23\x01\x24\x01\x25\x01\x26\x01\x27\x01\x28\x01\x29\x01\x2a\x01\xff\xff\xff\xff\x2d\x01\x74\x00\x2f\x01\xff\xff\xff\xff\x32\x01\xbe\x00\xbf\x00\xc0\x00\xff\xff\xc2\x00\xff\xff\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xff\xff\xff\xff\xcb\x00\xcc\x00\xff\xff\xff\xff\xff\xff\xff\xff\xd1\x00\xff\xff\xff\xff\xff\xff\xd5\x00\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\xf3\x00\xf4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfd\x00\xfe\x00\xff\xff\xff\xff\xff\xff\x02\x01\x03\x01\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\x13\x01\x14\x01\xff\xff\x16\x01\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x01\xff\xff\x1d\x01\x1e\x01\xff\xff\x20\x01\x21\x01\xff\xff\x23\x01\x24\x01\x25\x01\x26\x01\x27\x01\x28\x01\x29\x01\x2a\x01\xff\xff\xff\xff\xbe\x00\xbf\x00\xc0\x00\xff\xff\xc2\x00\x32\x01\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xff\xff\xff\xff\xcb\x00\xcc\x00\xff\xff\xff\xff\xff\xff\xff\xff\xd1\x00\xff\xff\xff\xff\xd4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\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\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfd\x00\xfe\x00\xff\xff\xff\xff\xff\xff\x02\x01\x03\x01\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\x13\x01\x14\x01\xff\xff\x16\x01\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x01\xff\xff\x1d\x01\x1e\x01\xff\xff\x20\x01\x21\x01\xff\xff\x23\x01\x24\x01\x25\x01\x26\x01\x27\x01\x28\x01\x29\x01\x2a\x01\xff\xff\xff\xff\xbe\x00\xbf\x00\xc0\x00\xff\xff\xc2\x00\x32\x01\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xff\xff\xff\xff\xcb\x00\xcc\x00\xff\xff\xff\xff\xff\xff\xff\xff\xd1\x00\xff\xff\xff\xff\xd4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\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\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfd\x00\xfe\x00\xff\xff\xff\xff\xff\xff\x02\x01\x03\x01\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\x13\x01\x14\x01\xff\xff\x16\x01\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x01\xff\xff\x1d\x01\x1e\x01\xff\xff\x20\x01\x21\x01\xff\xff\x23\x01\x24\x01\x25\x01\x26\x01\x27\x01\x28\x01\x29\x01\x2a\x01\xff\xff\xff\xff\xbe\x00\xbf\x00\xc0\x00\xff\xff\xc2\x00\x32\x01\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xff\xff\xff\xff\xcb\x00\xcc\x00\xff\xff\xff\xff\xff\xff\xff\xff\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\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\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfd\x00\xfe\x00\xff\xff\xff\xff\xff\xff\x02\x01\x03\x01\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\x13\x01\x14\x01\xff\xff\x16\x01\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x01\xff\xff\x1d\x01\x1e\x01\xff\xff\x20\x01\x21\x01\xff\xff\x23\x01\x24\x01\x25\x01\x26\x01\x27\x01\x28\x01\x29\x01\x2a\x01\xff\xff\xff\xff\xbe\x00\xbf\x00\xc0\x00\xff\xff\xc2\x00\x32\x01\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xff\xff\xff\xff\xcb\x00\xcc\x00\xff\xff\xff\xff\xff\xff\xff\xff\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\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\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfd\x00\xfe\x00\xff\xff\xff\xff\xff\xff\x02\x01\x03\x01\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\x13\x01\x14\x01\xff\xff\x16\x01\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x01\xff\xff\x1d\x01\x1e\x01\xff\xff\x20\x01\x21\x01\xff\xff\x23\x01\x24\x01\x25\x01\x26\x01\x27\x01\x28\x01\x29\x01\x2a\x01\xff\xff\xff\xff\xbe\x00\xbf\x00\xc0\x00\xff\xff\xc2\x00\x32\x01\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xff\xff\xff\xff\xcb\x00\xcc\x00\xff\xff\xff\xff\xff\xff\xff\xff\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\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\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfd\x00\xfe\x00\xff\xff\xff\xff\xff\xff\x02\x01\x03\x01\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\x13\x01\x14\x01\xff\xff\x16\x01\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x01\xff\xff\x1d\x01\x1e\x01\xff\xff\x20\x01\x21\x01\xff\xff\x23\x01\x24\x01\x25\x01\x26\x01\x27\x01\x28\x01\x29\x01\x2a\x01\xff\xff\xff\xff\xbe\x00\xbf\x00\xc0\x00\xff\xff\xc2\x00\x32\x01\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xff\xff\xff\xff\xcb\x00\xcc\x00\xff\xff\xff\xff\xff\xff\xff\xff\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\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\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfd\x00\xfe\x00\xff\xff\xff\xff\xff\xff\x02\x01\x03\x01\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\x13\x01\x14\x01\xff\xff\x16\x01\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x01\xff\xff\x1d\x01\x1e\x01\xff\xff\x20\x01\x21\x01\xff\xff\x23\x01\x24\x01\x25\x01\x26\x01\x27\x01\x28\x01\x29\x01\x2a\x01\xff\xff\xff\xff\xbe\x00\xbf\x00\xc0\x00\xff\xff\xc2\x00\x32\x01\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xff\xff\xff\xff\xcb\x00\xcc\x00\xff\xff\xff\xff\xff\xff\xff\xff\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\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\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfd\x00\xfe\x00\xff\xff\xff\xff\xff\xff\x02\x01\x03\x01\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\x13\x01\x14\x01\xff\xff\x16\x01\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x01\xff\xff\x1d\x01\x1e\x01\xff\xff\x20\x01\x21\x01\xff\xff\x23\x01\x24\x01\x25\x01\x26\x01\x27\x01\x28\x01\x29\x01\x2a\x01\xff\xff\xff\xff\xbe\x00\xbf\x00\xc0\x00\xff\xff\xc2\x00\x32\x01\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xff\xff\xff\xff\xcb\x00\xcc\x00\xff\xff\xff\xff\xff\xff\xff\xff\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\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\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfd\x00\xfe\x00\xff\xff\xff\xff\xff\xff\x02\x01\x03\x01\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\x13\x01\x14\x01\xff\xff\x16\x01\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x01\xff\xff\x1d\x01\x1e\x01\xff\xff\x20\x01\x21\x01\xff\xff\x23\x01\x24\x01\x25\x01\x26\x01\x27\x01\x28\x01\x29\x01\x2a\x01\xff\xff\xff\xff\xbe\x00\xbf\x00\xc0\x00\xff\xff\xc2\x00\x32\x01\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xff\xff\xff\xff\xcb\x00\xcc\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xd7\x00\xd8\x00\xd9\x00\xda\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xe4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xec\x00\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\xfd\x00\xfe\x00\xff\xff\xff\xff\xff\xff\x02\x01\x03\x01\xff\xff\xbe\x00\xbf\x00\xc0\x00\xff\xff\xc2\x00\xff\xff\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xff\xff\xff\xff\xcb\x00\xcc\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x01\xff\xff\x1d\x01\x1e\x01\xd8\x00\xd9\x00\xda\x00\xff\xff\xff\xff\x24\x01\xff\xff\x26\x01\x27\x01\xff\xff\xff\xff\x2a\x01\xe4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x32\x01\xec\x00\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\xfd\x00\xfe\x00\xff\xff\xff\xff\xff\xff\x02\x01\x03\x01\xff\xff\xff\xff\xff\xff\xbe\x00\xbf\x00\xc0\x00\xff\xff\xc2\x00\xff\xff\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xff\xff\xff\xff\xcb\x00\xcc\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x01\xff\xff\x1d\x01\x1e\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x24\x01\xff\xff\x26\x01\x27\x01\xff\xff\xff\xff\x2a\x01\xff\xff\xff\xff\xe4\x00\xff\xff\xff\xff\xff\xff\xff\xff\x32\x01\xea\x00\xeb\x00\xec\x00\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\xfd\x00\xfe\x00\xff\xff\xff\xff\xff\xff\x02\x01\x03\x01\xff\xff\xff\xff\xbe\x00\xbf\x00\xc0\x00\xff\xff\xc2\x00\xff\xff\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xff\xff\xff\xff\xcb\x00\xcc\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x01\xff\xff\x1d\x01\x1e\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x24\x01\xff\xff\x26\x01\x27\x01\xff\xff\xff\xff\x2a\x01\xff\xff\xe4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xe9\x00\x32\x01\xeb\x00\xec\x00\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\xfd\x00\xfe\x00\xff\xff\xff\xff\xff\xff\x02\x01\x03\x01\xff\xff\xff\xff\xbe\x00\xbf\x00\xc0\x00\xff\xff\xc2\x00\xff\xff\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xff\xff\xff\xff\xcb\x00\xcc\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x01\xff\xff\x1d\x01\x1e\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x24\x01\xff\xff\x26\x01\x27\x01\xff\xff\xff\xff\x2a\x01\xff\xff\xe4\x00\xff\xff\xff\xff\xff\xff\xe8\x00\xff\xff\x32\x01\xeb\x00\xec\x00\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\xfd\x00\xfe\x00\xff\xff\xff\xff\xff\xff\x02\x01\x03\x01\xff\xff\xff\xff\xbe\x00\xbf\x00\xc0\x00\xff\xff\xc2\x00\xff\xff\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xff\xff\xff\xff\xcb\x00\xcc\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x01\xff\xff\x1d\x01\x1e\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x24\x01\xff\xff\x26\x01\x27\x01\xff\xff\xff\xff\x2a\x01\xff\xff\xe4\x00\xff\xff\xff\xff\xff\xff\xe8\x00\xff\xff\x32\x01\xeb\x00\xec\x00\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\xfd\x00\xfe\x00\xff\xff\xff\xff\xff\xff\x02\x01\x03\x01\xff\xff\xbe\x00\xbf\x00\xc0\x00\xff\xff\xc2\x00\xff\xff\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xff\xff\xff\xff\xcb\x00\xcc\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x01\xff\xff\x1d\x01\x1e\x01\xff\xff\xff\xff\xff\xff\xdb\x00\xdc\x00\x24\x01\xff\xff\x26\x01\x27\x01\xff\xff\xff\xff\x2a\x01\xe4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x32\x01\xec\x00\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\xfd\x00\xfe\x00\xff\xff\xff\xff\xff\xff\x02\x01\x03\x01\xff\xff\xbe\x00\xbf\x00\xc0\x00\xff\xff\xc2\x00\xff\xff\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xff\xff\xff\xff\xcb\x00\xcc\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x01\xff\xff\x1d\x01\x1e\x01\xff\xff\xff\xff\xff\xff\xdb\x00\xdc\x00\x24\x01\xff\xff\x26\x01\x27\x01\xff\xff\xff\xff\x2a\x01\xe4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x32\x01\xec\x00\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\xfd\x00\xfe\x00\xff\xff\xff\xff\xff\xff\x02\x01\x03\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xbe\x00\xbf\x00\xc0\x00\xff\xff\xc2\x00\xff\xff\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xff\xff\xff\xff\xcb\x00\xcc\x00\xff\xff\xff\xff\x1b\x01\xff\xff\x1d\x01\x1e\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x24\x01\xff\xff\x26\x01\x27\x01\xff\xff\xff\xff\x2a\x01\xdf\x00\xe0\x00\xe1\x00\xff\xff\xff\xff\xff\xff\xff\xff\x32\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\xf3\x00\xf4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfd\x00\xfe\x00\xff\xff\xff\xff\xff\xff\x02\x01\x03\x01\xff\xff\xff\xff\xbe\x00\xbf\x00\xc0\x00\xff\xff\xc2\x00\xff\xff\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xff\xff\xff\xff\xcb\x00\xcc\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x01\xff\xff\x1d\x01\x1e\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x24\x01\xff\xff\x26\x01\x27\x01\xff\xff\xff\xff\x2a\x01\xff\xff\xe4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x32\x01\xeb\x00\xec\x00\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\xfd\x00\xfe\x00\xff\xff\xff\xff\xff\xff\x02\x01\x03\x01\xff\xff\xbe\x00\xbf\x00\xc0\x00\xff\xff\xc2\x00\xff\xff\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xff\xff\xff\xff\xcb\x00\xcc\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x01\xff\xff\x1d\x01\x1e\x01\xff\xff\xff\xff\xda\x00\xff\xff\xff\xff\x24\x01\xff\xff\x26\x01\x27\x01\xff\xff\xff\xff\x2a\x01\xe4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x32\x01\xec\x00\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\xfd\x00\xfe\x00\xff\xff\xff\xff\xff\xff\x02\x01\x03\x01\xff\xff\xbe\x00\xbf\x00\xc0\x00\xff\xff\xc2\x00\xff\xff\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xff\xff\xff\xff\xcb\x00\xcc\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x01\xff\xff\x1d\x01\x1e\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x24\x01\xff\xff\x26\x01\x27\x01\xff\xff\xff\xff\x2a\x01\xe4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x32\x01\xec\x00\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\xfd\x00\xfe\x00\xff\xff\xff\xff\xff\xff\x02\x01\x03\x01\xbe\x00\xbf\x00\xc0\x00\xff\xff\xc2\x00\xff\xff\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xff\xff\xff\xff\xcb\x00\xcc\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x01\xff\xff\x1d\x01\x1e\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x24\x01\xff\xff\x26\x01\x27\x01\xe2\x00\xff\xff\x2a\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x32\x01\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\xfd\x00\xfe\x00\xff\xff\xff\xff\xff\xff\x02\x01\x03\x01\xbe\x00\xbf\x00\xc0\x00\xff\xff\xc2\x00\xff\xff\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xff\xff\xff\xff\xcb\x00\xcc\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x01\xff\xff\x1d\x01\x1e\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x24\x01\xff\xff\x26\x01\x27\x01\xe2\x00\xff\xff\x2a\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x32\x01\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\xfd\x00\xfe\x00\xff\xff\xff\xff\xff\xff\x02\x01\x03\x01\xbe\x00\xbf\x00\xc0\x00\xff\xff\xc2\x00\xff\xff\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xff\xff\xff\xff\xcb\x00\xcc\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x01\xff\xff\x1d\x01\x1e\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x24\x01\xff\xff\x26\x01\x27\x01\xe2\x00\xff\xff\x2a\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x32\x01\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\xfd\x00\xfe\x00\xff\xff\xff\xff\xff\xff\x02\x01\x03\x01\xbe\x00\xbf\x00\xc0\x00\xff\xff\xc2\x00\xff\xff\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xff\xff\xff\xff\xcb\x00\xcc\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x01\xff\xff\x1d\x01\x1e\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x24\x01\xff\xff\x26\x01\x27\x01\xff\xff\xff\xff\x2a\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x32\x01\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\xfd\x00\xfe\x00\xff\xff\xff\xff\xff\xff\x02\x01\x03\x01\xbe\x00\xbf\x00\xc0\x00\xff\xff\xc2\x00\xff\xff\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xff\xff\xff\xff\xcb\x00\xcc\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x01\xff\xff\x1d\x01\x1e\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x24\x01\xff\xff\x26\x01\x27\x01\xff\xff\xff\xff\x2a\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x32\x01\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\xfd\x00\xfe\x00\xff\xff\xff\xff\xff\xff\x02\x01\x03\x01\xbe\x00\xbf\x00\xc0\x00\xff\xff\xc2\x00\xff\xff\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xff\xff\xff\xff\xcb\x00\xcc\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x01\xff\xff\x1d\x01\x1e\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x24\x01\xff\xff\x26\x01\x27\x01\xff\xff\xff\xff\x2a\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x32\x01\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\xfd\x00\xfe\x00\xff\xff\xff\xff\xff\xff\x02\x01\x03\x01\xbe\x00\xbf\x00\xc0\x00\xff\xff\xc2\x00\xff\xff\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xff\xff\xff\xff\xcb\x00\xcc\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x01\xff\xff\x1d\x01\x1e\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x24\x01\xff\xff\x26\x01\x27\x01\xff\xff\xff\xff\x2a\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x32\x01\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\xfd\x00\xfe\x00\xff\xff\xff\xff\xff\xff\x02\x01\x03\x01\xbe\x00\xbf\x00\xc0\x00\xff\xff\xc2\x00\xff\xff\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xff\xff\xff\xff\xcb\x00\xcc\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x01\xff\xff\x1d\x01\x1e\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x24\x01\xff\xff\x26\x01\x27\x01\xff\xff\xff\xff\x2a\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x32\x01\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\xfd\x00\xfe\x00\xff\xff\xff\xff\xff\xff\x02\x01\x03\x01\xbe\x00\xbf\x00\xc0\x00\xff\xff\xc2\x00\xff\xff\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xff\xff\xff\xff\xcb\x00\xcc\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x01\xff\xff\x1d\x01\x1e\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x24\x01\xff\xff\x26\x01\x27\x01\xff\xff\xff\xff\x2a\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x32\x01\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\xfd\x00\xfe\x00\xff\xff\xff\xff\xff\xff\x02\x01\x03\x01\xbe\x00\xbf\x00\xc0\x00\xff\xff\xc2\x00\xff\xff\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xff\xff\xff\xff\xcb\x00\xcc\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x01\xff\xff\x1d\x01\x1e\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x24\x01\xff\xff\x26\x01\x27\x01\xff\xff\xff\xff\x2a\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x32\x01\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\xfd\x00\xfe\x00\xff\xff\xff\xff\xff\xff\x02\x01\x03\x01\xbe\x00\xbf\x00\xc0\x00\xff\xff\xc2\x00\xff\xff\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xff\xff\xff\xff\xcb\x00\xcc\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x01\xff\xff\x1d\x01\x1e\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x24\x01\xff\xff\x26\x01\x27\x01\xff\xff\xff\xff\x2a\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x32\x01\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\xfd\x00\xfe\x00\xff\xff\xff\xff\xff\xff\x02\x01\x03\x01\xbe\x00\xbf\x00\xc0\x00\xff\xff\xc2\x00\xff\xff\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xff\xff\xff\xff\xcb\x00\xcc\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x01\xff\xff\x1d\x01\x1e\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x24\x01\xff\xff\x26\x01\x27\x01\xff\xff\xff\xff\x2a\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x32\x01\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\xfd\x00\xfe\x00\xff\xff\xff\xff\xff\xff\x02\x01\x03\x01\xbe\x00\xbf\x00\xc0\x00\xff\xff\xc2\x00\xff\xff\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xff\xff\xff\xff\xcb\x00\xcc\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x01\xff\xff\x1d\x01\x1e\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x24\x01\xff\xff\x26\x01\x27\x01\xff\xff\xff\xff\x2a\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x32\x01\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\xfd\x00\xfe\x00\xff\xff\xff\xff\xff\xff\x02\x01\x03\x01\xbe\x00\xbf\x00\xc0\x00\xff\xff\xc2\x00\xff\xff\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xff\xff\xff\xff\xcb\x00\xcc\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x01\xff\xff\x1d\x01\x1e\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x24\x01\xff\xff\x26\x01\x27\x01\xff\xff\xff\xff\x2a\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x32\x01\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\xfd\x00\xfe\x00\xff\xff\xff\xff\xff\xff\x02\x01\x03\x01\xbe\x00\xbf\x00\xc0\x00\xff\xff\xc2\x00\xff\xff\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xff\xff\xff\xff\xcb\x00\xcc\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x01\xff\xff\x1d\x01\x1e\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x24\x01\xff\xff\x26\x01\x27\x01\xff\xff\xff\xff\x2a\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x32\x01\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\xfd\x00\xfe\x00\xff\xff\xff\xff\xff\xff\x02\x01\x03\x01\xbe\x00\xbf\x00\xc0\x00\xff\xff\xc2\x00\xff\xff\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xff\xff\xff\xff\xcb\x00\xcc\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x01\xff\xff\x1d\x01\x1e\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x24\x01\xff\xff\x26\x01\x27\x01\xff\xff\xff\xff\x2a\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x32\x01\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\xfd\x00\xfe\x00\xff\xff\xff\xff\xff\xff\x02\x01\x03\x01\xbe\x00\xbf\x00\xc0\x00\xff\xff\xc2\x00\xff\xff\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xff\xff\xff\xff\xcb\x00\xcc\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x01\xff\xff\x1d\x01\x1e\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x24\x01\xff\xff\x26\x01\x27\x01\xff\xff\xff\xff\x2a\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x32\x01\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\xfd\x00\xfe\x00\xff\xff\xff\xff\xff\xff\x02\x01\x03\x01\xbe\x00\xbf\x00\xc0\x00\xff\xff\xc2\x00\xff\xff\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xff\xff\xff\xff\xcb\x00\xcc\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x01\xff\xff\x1d\x01\x1e\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x24\x01\xff\xff\x26\x01\x27\x01\xff\xff\xff\xff\x2a\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x32\x01\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\xfd\x00\xfe\x00\xff\xff\xff\xff\xff\xff\x02\x01\x03\x01\xbe\x00\xbf\x00\xc0\x00\xff\xff\xc2\x00\xff\xff\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xff\xff\xff\xff\xcb\x00\xcc\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x01\xff\xff\x1d\x01\x1e\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x24\x01\xff\xff\x26\x01\x27\x01\xff\xff\xff\xff\x2a\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x32\x01\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\xfd\x00\xfe\x00\xff\xff\xff\xff\xff\xff\x02\x01\x03\x01\xbe\x00\xbf\x00\xc0\x00\xff\xff\xc2\x00\xff\xff\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xff\xff\xff\xff\xcb\x00\xcc\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x01\xff\xff\x1d\x01\x1e\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x24\x01\xff\xff\x26\x01\x27\x01\xff\xff\xff\xff\x2a\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x32\x01\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\xfd\x00\xfe\x00\xff\xff\xff\xff\xff\xff\x02\x01\x03\x01\xbe\x00\xbf\x00\xc0\x00\xff\xff\xc2\x00\xff\xff\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xff\xff\xff\xff\xcb\x00\xcc\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x01\xff\xff\x1d\x01\x1e\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x24\x01\xff\xff\x26\x01\x27\x01\xff\xff\xff\xff\x2a\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x32\x01\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\xfd\x00\xfe\x00\xff\xff\xff\xff\xff\xff\x02\x01\x03\x01\xbe\x00\xbf\x00\xc0\x00\xff\xff\xc2\x00\xff\xff\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xff\xff\xff\xff\xcb\x00\xcc\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x01\xff\xff\x1d\x01\x1e\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x24\x01\xff\xff\x26\x01\x27\x01\xff\xff\xff\xff\x2a\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x32\x01\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\xfd\x00\xfe\x00\xff\xff\xff\xff\xff\xff\x02\x01\x03\x01\xbe\x00\xbf\x00\xc0\x00\xff\xff\xc2\x00\xff\xff\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xff\xff\xff\xff\xcb\x00\xcc\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x01\xff\xff\x1d\x01\x1e\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x24\x01\xff\xff\x26\x01\x27\x01\xff\xff\xff\xff\x2a\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x32\x01\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\xfd\x00\xfe\x00\xff\xff\xff\xff\xff\xff\x02\x01\x03\x01\xbe\x00\xbf\x00\xc0\x00\xff\xff\xc2\x00\xff\xff\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xff\xff\xff\xff\xcb\x00\xcc\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x01\xff\xff\x1d\x01\x1e\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x24\x01\xff\xff\x26\x01\x27\x01\xff\xff\xff\xff\x2a\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x32\x01\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\xfd\x00\xfe\x00\xff\xff\xff\xff\xff\xff\x02\x01\x03\x01\xbe\x00\xbf\x00\xc0\x00\xff\xff\xc2\x00\xff\xff\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xff\xff\xff\xff\xcb\x00\xcc\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x01\xff\xff\x1d\x01\x1e\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x24\x01\xff\xff\x26\x01\x27\x01\xff\xff\xff\xff\x2a\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x32\x01\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\xfd\x00\xfe\x00\xff\xff\xff\xff\xff\xff\x02\x01\x03\x01\xbe\x00\xbf\x00\xc0\x00\xff\xff\xc2\x00\xff\xff\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xff\xff\xff\xff\xcb\x00\xcc\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x01\xff\xff\x1d\x01\x1e\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x24\x01\xff\xff\x26\x01\x27\x01\xff\xff\xff\xff\x2a\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x32\x01\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\xfd\x00\xfe\x00\xff\xff\xff\xff\xff\xff\x02\x01\x03\x01\xbe\x00\xbf\x00\xc0\x00\xff\xff\xc2\x00\xff\xff\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xff\xff\xff\xff\xcb\x00\xcc\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x01\xff\xff\x1d\x01\x1e\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x24\x01\xff\xff\x26\x01\x27\x01\xff\xff\xff\xff\x2a\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x32\x01\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\xfd\x00\xfe\x00\xff\xff\xff\xff\xff\xff\x02\x01\x03\x01\xbe\x00\xbf\x00\xc0\x00\xff\xff\xc2\x00\xff\xff\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xff\xff\xff\xff\xcb\x00\xcc\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x01\xff\xff\x1d\x01\x1e\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x24\x01\xff\xff\x26\x01\x27\x01\xff\xff\xff\xff\x2a\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x32\x01\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\xfd\x00\xfe\x00\xff\xff\xff\xff\xff\xff\x02\x01\x03\x01\xbe\x00\xbf\x00\xc0\x00\xff\xff\xc2\x00\xff\xff\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xff\xff\xff\xff\xcb\x00\xcc\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x01\xff\xff\x1d\x01\x1e\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x24\x01\xff\xff\x26\x01\x27\x01\xff\xff\xff\xff\x2a\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x32\x01\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\xfd\x00\xfe\x00\xff\xff\xff\xff\xff\xff\x02\x01\x03\x01\xbe\x00\xbf\x00\xc0\x00\xff\xff\xc2\x00\xff\xff\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xff\xff\xff\xff\xcb\x00\xcc\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x01\xff\xff\x1d\x01\x1e\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x24\x01\xff\xff\x26\x01\x27\x01\xff\xff\xff\xff\x2a\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x32\x01\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\xfd\x00\xfe\x00\xff\xff\xff\xff\xff\xff\x02\x01\x03\x01\xbe\x00\xbf\x00\xc0\x00\xff\xff\xc2\x00\xff\xff\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xff\xff\xff\xff\xcb\x00\xcc\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x01\xff\xff\x1d\x01\x1e\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x24\x01\xff\xff\x26\x01\x27\x01\xff\xff\xff\xff\x2a\x01\xff\xff\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x32\x01\x09\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf3\x00\xf4\x00\xff\xff\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\xfd\x00\xfe\x00\x1b\x00\x1c\x00\x1d\x00\x02\x01\x03\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\x1b\x01\x02\x00\x1d\x01\x1e\x01\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\x24\x01\xff\xff\x26\x01\x27\x01\xff\xff\xff\xff\x2a\x01\xff\xff\x12\x00\xff\xff\xff\xff\x15\x00\xff\xff\x17\x00\x32\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\xbe\x00\xff\xff\xc0\x00\xff\xff\xc2\x00\xff\xff\x74\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xff\xff\xff\xff\xcb\x00\xcc\x00\xff\xff\xff\xff\xbe\x00\xff\xff\xc0\x00\xff\xff\xc2\x00\xff\xff\xff\xff\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xff\xff\xff\xff\xcb\x00\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\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\x74\x00\xff\xff\xff\xff\xff\xff\xff\xff\xfd\x00\xfe\x00\xff\xff\xff\xff\xff\xff\x02\x01\x03\x01\xf3\x00\xf4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfd\x00\xfe\x00\xff\xff\xff\xff\xff\xff\x02\x01\x03\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x01\xff\xff\x1d\x01\x1e\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x24\x01\xff\xff\x26\x01\x27\x01\xff\xff\xff\xff\x2a\x01\xff\xff\x1b\x01\xff\xff\x1d\x01\x1e\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x24\x01\xff\xff\x26\x01\x27\x01\xff\xff\xbe\x00\x2a\x01\xc0\x00\xff\xff\xc2\x00\xff\xff\xff\xff\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xff\xff\xff\xff\xcb\x00\xcc\x00\xff\xff\xff\xff\xbe\x00\xff\xff\xc0\x00\xff\xff\xc2\x00\xff\xff\xff\xff\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xff\xff\xff\xff\xcb\x00\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\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\xfd\x00\xfe\x00\xff\xff\xff\xff\xff\xff\x02\x01\x03\x01\xf3\x00\xf4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfd\x00\xfe\x00\xff\xff\xff\xff\xff\xff\x02\x01\x03\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x01\xff\xff\x1d\x01\x1e\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x24\x01\xff\xff\x26\x01\x27\x01\xff\xff\xff\xff\x2a\x01\xff\xff\x1b\x01\xff\xff\x1d\x01\x1e\x01\xff\xff\xff\xff\xff\xff\xff\xff\xbe\x00\x24\x01\xff\xff\x26\x01\x27\x01\xff\xff\xff\xff\x2a\x01\xc6\x00\xc7\x00\xc8\x00\xff\xff\xff\xff\xcb\x00\xcc\x00\xff\xff\xff\xff\xbe\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc6\x00\xc7\x00\xc8\x00\xff\xff\xff\xff\xcb\x00\xcc\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xe5\x00\xe6\x00\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\xe5\x00\xe6\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfd\x00\xfe\x00\xff\xff\xff\xff\xff\xff\x02\x01\x03\x01\xf3\x00\xf4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfd\x00\xfe\x00\xff\xff\xff\xff\xff\xff\x02\x01\x03\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x01\xff\xff\x1d\x01\x1e\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x24\x01\xff\xff\x26\x01\x27\x01\xff\xff\xff\xff\x2a\x01\xff\xff\x1b\x01\xff\xff\x1d\x01\x1e\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x24\x01\xbe\x00\x26\x01\x27\x01\xff\xff\xff\xff\x2a\x01\xff\xff\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xff\xff\xff\xff\xcb\x00\xcc\x00\xff\xff\xff\xff\xbe\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc6\x00\xc7\x00\xc8\x00\xff\xff\xff\xff\xcb\x00\xcc\x00\xff\xff\xce\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\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\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfd\x00\xfe\x00\xff\xff\xff\xff\xff\xff\x02\x01\x03\x01\xf3\x00\xf4\x00\xff\xff\xff\xff\xbe\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfd\x00\xfe\x00\xc6\x00\xc7\x00\xc8\x00\x02\x01\x03\x01\xcb\x00\xcc\x00\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x01\xff\xff\x1d\x01\x1e\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x24\x01\xff\xff\x26\x01\x27\x01\xff\xff\xff\xff\x2a\x01\xff\xff\x1b\x01\xff\xff\x1d\x01\x1e\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x24\x01\xff\xff\x26\x01\x27\x01\xff\xff\xff\xff\x2a\x01\xff\xff\xf3\x00\xf4\x00\xff\xff\xff\xff\xbe\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfd\x00\xfe\x00\xc6\x00\xc7\x00\xc8\x00\x02\x01\x03\x01\xcb\x00\xcc\x00\xff\xff\xff\xff\xbe\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc6\x00\xc7\x00\xc8\x00\xff\xff\xff\xff\xcb\x00\xcc\x00\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x01\xff\xff\x1d\x01\x1e\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x24\x01\xff\xff\x26\x01\x27\x01\xff\xff\xff\xff\x2a\x01\xff\xff\xf3\x00\xf4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfd\x00\xfe\x00\xff\xff\xff\xff\xff\xff\x02\x01\x03\x01\xf3\x00\xf4\x00\xff\xff\xff\xff\xbe\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfd\x00\xfe\x00\xc6\x00\xc7\x00\xc8\x00\x02\x01\x03\x01\xcb\x00\xcc\x00\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x01\xff\xff\x1d\x01\x1e\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x24\x01\xff\xff\x26\x01\x27\x01\xff\xff\xff\xff\x2a\x01\xff\xff\x1b\x01\xff\xff\x1d\x01\x1e\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x24\x01\xff\xff\x26\x01\x27\x01\xff\xff\xff\xff\x2a\x01\xff\xff\xf3\x00\xf4\x00\xff\xff\xff\xff\xbe\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfd\x00\xfe\x00\xc6\x00\xc7\x00\xc8\x00\x02\x01\x03\x01\xcb\x00\xcc\x00\xff\xff\xff\xff\xbe\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc6\x00\xc7\x00\xc8\x00\xff\xff\xff\xff\xcb\x00\xcc\x00\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x01\xff\xff\x1d\x01\x1e\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x24\x01\xff\xff\x26\x01\x27\x01\xff\xff\xff\xff\x2a\x01\xff\xff\xf3\x00\xf4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfd\x00\xfe\x00\xff\xff\xff\xff\xff\xff\x02\x01\x03\x01\xf3\x00\xf4\x00\xff\xff\xff\xff\xbe\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfd\x00\xfe\x00\xc6\x00\xc7\x00\xc8\x00\x02\x01\x03\x01\xcb\x00\xcc\x00\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x01\xff\xff\x1d\x01\x1e\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x24\x01\xff\xff\x26\x01\x27\x01\xff\xff\xff\xff\x2a\x01\xff\xff\x1b\x01\xff\xff\x1d\x01\x1e\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x24\x01\xff\xff\x26\x01\x27\x01\xff\xff\xff\xff\x2a\x01\xff\xff\xf3\x00\xf4\x00\xff\xff\xff\xff\xbe\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfd\x00\xfe\x00\xc6\x00\xc7\x00\xc8\x00\x02\x01\x03\x01\xcb\x00\xcc\x00\xff\xff\xff\xff\xbe\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc6\x00\xc7\x00\xc8\x00\xff\xff\xff\xff\xcb\x00\xcc\x00\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x01\xff\xff\x1d\x01\x1e\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x24\x01\xff\xff\x26\x01\x27\x01\xff\xff\xff\xff\x2a\x01\xff\xff\xf3\x00\xf4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfd\x00\xfe\x00\xff\xff\xff\xff\xff\xff\x02\x01\x03\x01\xf3\x00\xf4\x00\xff\xff\xff\xff\xbe\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfd\x00\xfe\x00\xc6\x00\xc7\x00\xc8\x00\x02\x01\x03\x01\xcb\x00\xcc\x00\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x01\xff\xff\x1d\x01\x1e\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x24\x01\xff\xff\x26\x01\x27\x01\xff\xff\xff\xff\x2a\x01\xff\xff\x1b\x01\xff\xff\x1d\x01\x1e\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x24\x01\xff\xff\x26\x01\x27\x01\xff\xff\xff\xff\x2a\x01\xff\xff\xf3\x00\xf4\x00\xff\xff\xff\xff\xbe\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfd\x00\xfe\x00\xc6\x00\xc7\x00\xc8\x00\x02\x01\x03\x01\xcb\x00\xcc\x00\xff\xff\xff\xff\xbe\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc6\x00\xc7\x00\xc8\x00\xff\xff\xff\xff\xcb\x00\xcc\x00\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x01\xff\xff\x1d\x01\x1e\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x24\x01\xff\xff\x26\x01\x27\x01\xff\xff\xff\xff\x2a\x01\xff\xff\xf3\x00\xf4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfd\x00\xfe\x00\xff\xff\xff\xff\xff\xff\x02\x01\x03\x01\xf3\x00\xf4\x00\xff\xff\xff\xff\xbe\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfd\x00\xfe\x00\xff\xff\xff\xff\xc8\x00\x02\x01\x03\x01\xcb\x00\xcc\x00\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x01\xff\xff\x1d\x01\x1e\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x24\x01\xff\xff\x26\x01\x27\x01\xff\xff\xff\xff\x2a\x01\xff\xff\x1b\x01\xff\xff\x1d\x01\x1e\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x24\x01\xbe\x00\x26\x01\x27\x01\xff\xff\xff\xff\x2a\x01\xff\xff\xf3\x00\xf4\x00\xff\xff\xc8\x00\xff\xff\xff\xff\xcb\x00\xcc\x00\xff\xff\xff\xff\xfd\x00\xfe\x00\xff\xff\xff\xff\xff\xff\x02\x01\x03\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\x1b\x01\xff\xff\x1d\x01\x1e\x01\xff\xff\xff\xff\xf3\x00\xf4\x00\xff\xff\x24\x01\xff\xff\x26\x01\x27\x01\xff\xff\xff\xff\x2a\x01\xfd\x00\xfe\x00\xff\xff\xff\xff\xff\xff\x02\x01\x03\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\x1b\x01\xff\xff\x1d\x01\x1e\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x24\x01\xff\xff\x26\x01\x27\x01\xff\xff\xff\xff\x2a\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\x70\x00\x3c\x05\x3d\x05\x3f\x05\x40\x05\x22\x01\x7b\x04\x73\x05\x7a\x05\xca\x00\x18\x05\x75\x05\x9a\x04\x01\x03\x76\x05\xcb\x04\x17\x02\xca\x04\x18\x02\x48\x03\x71\x05\xcb\x04\x17\x02\x37\x05\x18\x02\x91\x02\x92\x02\xcb\x04\x17\x02\x49\x05\x18\x02\x16\x02\x17\x02\x17\x02\x18\x02\xe4\x03\x7f\x04\x3d\x03\x80\x04\x9a\x02\xb1\x02\xa3\x02\x5e\x05\x86\x02\x55\x03\xde\x04\x05\x01\x18\x01\x19\x01\x6d\x03\x9b\x03\xe9\x00\x3b\x03\x91\x02\x92\x02\x6d\x02\xcb\x00\x1e\x04\x14\x02\x77\x04\xff\x00\x14\x02\x81\x04\x87\x04\x81\x00\x14\x02\xfe\x02\x3c\x02\x4d\x04\x4e\x04\x4f\x04\x68\x03\x65\x03\x31\x00\x0d\x03\x50\x04\x51\x04\x14\x02\x60\x05\x4e\x04\x4f\x04\xbe\x02\xba\x02\xf6\x02\xb3\x01\x50\x04\x51\x04\x63\x05\x01\x01\x14\x02\x7d\x05\x4e\x04\x4f\x04\x3e\x04\x3f\x04\xff\xff\x3d\x02\x50\x04\x51\x04\x0e\x03\x73\x04\x3f\x04\x02\x05\x9e\x02\x00\x03\xbe\x03\x32\x00\x50\x04\x51\x04\x8c\x00\x5f\x05\x06\x05\x51\x04\xbb\x02\x14\x05\x3f\x04\x03\x05\x04\x05\x05\x05\x06\x05\x51\x04\xf7\x02\x41\x03\x42\x03\x9b\x04\xbc\x02\x72\x03\xe0\x02\x06\x01\x6e\x02\x14\x02\x9c\x04\x48\x00\x87\x02\x6e\x03\x88\x02\xa5\x02\x83\x04\xbf\x02\x5f\x05\x87\x02\xec\x00\x1f\x04\x66\x03\x8f\x00\xb3\x01\xa7\x02\xf0\x01\x92\x00\x4d\x00\x36\x00\x94\x00\x95\x00\x96\x00\x97\x00\x33\x00\xa8\x02\xa9\x02\xaa\x02\x56\x03\x4e\x00\x15\x02\x23\x01\x24\x01\x15\x02\x73\x00\x11\x01\x43\x03\x15\x02\x0b\x01\x16\x02\x13\x01\x64\x05\x1a\x01\x1b\x01\x17\x03\x94\x02\x11\x00\x10\x01\x6b\x05\x15\x02\x73\x00\x11\x01\x73\x03\xe6\x01\x06\x01\x64\x00\x07\x01\x13\x01\x96\x03\xb2\x02\x72\x00\x15\x02\x25\x01\x11\x00\x73\x00\x74\x00\x9e\x00\x9f\x00\x11\x00\x02\x03\x8c\x03\x14\x01\x07\x01\x93\x02\x12\x01\x11\x00\xa0\x00\x72\x00\x13\x01\x9c\x04\x48\x00\x73\x00\x74\x00\x7c\x04\x11\x00\x7c\x04\x19\x05\x14\x01\xba\x02\xb3\x02\x6c\x05\x0f\x00\x10\x00\x02\x03\x4e\x00\x38\x04\x4e\x00\x4e\x00\x11\x00\x11\x00\x7c\x00\x7d\x00\x15\x02\x3c\x03\xbf\x04\xce\x00\xa1\x00\x13\x01\x0f\x00\xcf\x00\x3c\x03\x8a\x03\x9b\x02\x11\x00\x13\x01\x11\x00\x45\x04\x7c\x00\x7d\x00\xbb\x02\x11\x00\xa2\x00\x71\x00\x72\x00\x9c\x02\x9d\x02\x40\x04\x73\x00\x74\x00\xff\xff\x75\x00\x37\x03\x11\x00\x40\x04\x25\xff\x2f\x03\xff\xff\xc0\x04\xc1\x04\x11\x00\x43\x03\x46\x04\xcf\x01\x7a\x00\x13\x01\x7b\x00\x76\x00\x40\x04\x13\x03\x9e\x02\x11\x00\x3f\x01\x0e\x00\x11\x00\x0f\x00\x10\x00\x77\x00\x3e\x05\x78\x00\x79\x00\x7a\x00\x11\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x41\x05\x19\x02\x52\x04\x41\x05\x53\x04\x48\x00\x04\x02\x19\x02\x3e\x05\x30\x04\xef\x01\x14\x02\x52\x04\x19\x02\x53\x04\x48\x00\x31\x03\x19\x02\x19\x02\x14\x02\x54\x04\x14\x03\x0f\x00\x10\x00\x52\x04\xff\x01\x53\x04\x48\x00\xd5\x03\x11\x00\x54\x04\xd6\x03\x0f\x00\x10\x00\x52\x04\xec\x03\x53\x04\x48\x00\x52\x04\x11\x00\x53\x04\x48\x00\x54\x04\x14\x02\x0f\x00\x10\x00\x52\x04\x14\x02\x53\x04\x48\x00\x81\x00\x11\x00\x54\x04\x14\x02\x0f\x00\x10\x00\x54\x04\x69\x03\x0f\x00\x10\x00\xd7\x03\x11\x00\xca\x00\x0f\x03\x54\x04\x11\x00\x0f\x00\x10\x00\x5b\x04\x5c\x04\xe1\x00\xe2\x00\xe3\x00\x11\x00\xe4\x00\xfe\x01\x43\x03\x5d\x01\x80\x02\xed\x03\x13\x01\x65\x02\xd0\x02\x60\x01\xa9\x01\x81\x02\x11\x00\x11\x00\x58\xff\x61\x01\xe5\x00\xe6\x00\xd1\x02\x1a\x01\x1b\x01\x8c\x00\xe2\x01\xaa\x01\x10\x01\xe7\x00\xe8\x00\x73\x00\x11\x01\x10\x03\xe9\x00\x32\x02\x98\x02\x33\x00\x36\x00\xcb\x00\x61\x01\x90\x03\x6a\x03\x6b\x03\x15\x02\x3c\x00\x3d\x00\x3e\x00\x82\x02\x3f\x00\x40\x00\x0a\x03\x15\x02\xf2\x04\x57\x00\x12\x01\x58\xff\x34\x00\xf0\x01\x13\x01\x4d\x00\xe8\x04\xe3\x01\xe4\x01\xe5\x01\x11\x00\x58\x00\xea\x00\x14\x01\x1e\x01\x1b\x01\x4e\x00\xf4\x01\x33\x02\x10\x01\x5c\x00\x15\x02\x73\x00\x11\x01\x33\x02\x15\x02\x2d\x02\x1c\x01\x1d\x01\x9e\x04\xca\x04\x15\x02\x41\x00\x5d\x01\x8c\x03\x41\x02\x0b\x03\x01\x04\x81\x00\x2e\x02\x55\x05\x98\x02\x4a\x00\x65\x00\x66\x00\x42\x00\x12\x01\x68\x00\x69\x00\x42\x01\x13\x01\xed\x01\xee\x01\xef\x01\xb8\x04\xe2\x01\x11\x00\x9f\x04\xa0\x04\x14\x01\xcf\x02\x52\x02\x2a\x01\x78\x01\xeb\x00\x79\x01\x61\x01\x38\x02\x42\x02\xec\x00\x02\x04\x60\x01\x8f\x00\xdd\x01\xed\x00\xb9\x04\x92\x00\x61\x01\xd0\x03\x94\x00\x95\x00\x96\x00\x97\x00\x8c\x00\x5d\x01\x98\x00\x99\x00\x8f\x00\xe2\x04\xe0\x04\xed\x01\xca\x00\xcd\x03\xe5\x01\x2b\x02\xee\x01\xef\x01\x05\x03\xe0\x00\xe1\x00\xe2\x00\xe3\x00\x06\x03\xe4\x00\xd1\x03\x44\x00\x45\x00\xec\x01\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x8a\x02\xe6\x01\xe1\x04\xa1\x04\x61\x01\x13\x01\xe5\x00\xe6\x00\x4b\x00\x4c\x00\x4d\x00\x11\x00\x9e\x00\x9f\x00\x64\x00\xe7\x00\xe8\x00\x03\x04\x67\x00\x0c\x05\xe9\x00\x4e\x00\xa0\x00\x72\x00\x36\x00\xcb\x00\xd3\x02\x73\x00\x74\x00\x2b\x01\x0b\x05\x2c\x01\x3d\x00\x3e\x00\xff\xff\x3f\x00\x40\x00\x07\x01\x1e\x01\x1b\x01\x29\x01\x74\x01\x24\x01\x10\x01\x73\x00\x11\x01\x73\x00\x11\x01\x07\x01\xdf\x04\xe0\x04\xce\x00\xa1\x00\xea\x00\x0f\x00\xcf\x00\x2a\x01\xf0\x02\xf0\x01\x3a\x02\x4d\x00\x11\x00\x43\x01\x7c\x00\x7d\x00\x3b\x02\x09\x02\xa2\x00\x64\x00\x05\x02\x12\x01\x4e\x00\x67\x00\x41\x00\x13\x01\x44\x01\xe1\x04\x45\x01\x46\x01\x06\x02\x11\x00\x14\x01\x06\x02\x14\x01\xb8\x01\xe6\x01\x42\x00\xb9\x01\x77\x00\x13\x01\x78\x00\x79\x00\x7a\x00\xc7\x04\x7b\x00\x11\x00\x34\x02\x7e\x00\x7f\x00\x96\xfd\x3a\x01\xf0\x01\x9f\x01\x4d\x00\x35\x02\xeb\x00\x06\x02\x4c\x03\xee\x01\xef\x01\xec\x00\xea\x03\x5f\x02\x8f\x00\x4e\x00\xed\x00\xb7\x01\x92\x00\x46\x05\xe0\x04\x94\x00\x95\x00\x96\x00\x97\x00\x1d\x05\x1b\x05\x98\x00\x99\x00\x3b\x01\x3c\x01\x3d\x01\x9a\x01\xca\x00\x74\x01\x87\x03\x61\x01\x73\x00\x11\x01\xff\xff\x93\x03\xe1\x00\xe2\x00\xe3\x00\x1e\x02\xe4\x00\xe1\x04\x44\x00\x2d\x01\x91\xfe\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x16\x02\x91\xfe\x60\x02\x61\x02\x0f\x00\x62\x02\xe5\x00\xe6\x00\x4b\x00\x4c\x00\x4d\x00\x11\x00\x9e\x00\x9f\x00\x57\x00\xe7\x00\xe8\x00\xc6\x04\x91\xfe\x14\x01\xe9\x00\x4e\x00\xa0\x00\x72\x00\x0e\x02\xcb\x00\x58\x00\x73\x00\x74\x00\x1f\x03\x06\x02\x1c\x04\xee\x01\xef\x01\x36\x00\x5c\x00\xb6\x01\x0f\x02\x10\x02\xf2\x02\x83\x00\x2c\x01\x3d\x00\x3e\x00\x84\x00\x3f\x00\x40\x00\x20\x03\x21\x03\x85\x00\x37\x02\xce\x00\xa1\x00\xea\x00\x0f\x00\xcf\x00\x38\x02\x95\x03\x65\x00\x66\x00\x8b\x03\x11\x00\x7d\x01\x7c\x00\x7d\x00\x1a\x05\x1b\x05\xa2\x00\x96\x03\x91\xfe\x91\xfe\x8c\x03\x8b\x00\xf0\x01\x91\xfe\x4d\x00\xfb\x01\xfc\x01\x23\x03\xa2\x04\xee\x01\xef\x01\x47\x04\x41\x00\x74\x01\x2c\x05\x4e\x00\x73\x00\x11\x01\xa1\x04\x48\x04\x24\x03\x25\x03\xfd\x01\x6d\x05\x91\xfe\x42\x00\x91\xfe\x89\x03\x83\x00\x64\x00\xca\x00\x6e\x05\x84\x00\x67\x00\xeb\x00\x91\xfe\xf1\x04\x85\x00\x8a\x03\xec\x00\xff\xff\x86\x00\x8f\x00\x27\x01\xed\x00\x88\x00\x92\x00\xf2\x04\xff\xff\x94\x00\x95\x00\x96\x00\x97\x00\x14\x01\x8a\x00\x98\x00\x99\x00\x7f\x04\x36\x00\x80\x04\x8b\x00\x0c\x02\x0d\x02\xf2\x02\x8e\x00\x2c\x01\x3d\x00\x3e\x00\xe7\x04\x3f\x00\x40\x00\xcb\x03\xe9\x00\x91\xfe\x2a\x02\x13\x01\x4d\x00\xcb\x00\x7a\x01\xe8\x04\xf0\x01\x11\x00\x4d\x00\x81\x04\x82\x04\x44\x00\x45\x00\x4e\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4e\x00\x70\x05\x9e\x00\x9f\x00\xb3\x01\xc9\x04\xf9\x03\x71\x05\x4b\x00\x4c\x00\x4d\x00\x1a\xfd\xa0\x00\x72\x00\x41\x00\x0f\x01\xca\x04\x73\x00\x74\x00\x10\x01\x4a\x01\x4e\x00\x73\x00\x11\x01\x36\x04\x62\x01\x72\x00\x42\x00\x13\x01\x63\x01\x73\x00\x74\x00\x16\x05\x4c\x01\x11\x00\xf0\x01\x0a\x01\x4d\x00\xd3\x01\x48\x00\x0b\x01\xce\x00\xa1\x00\x8c\x03\x0f\x00\xcf\x00\x12\x01\xf1\x02\x4e\x00\x3e\x01\x13\x01\x11\x00\xd4\x01\x7c\x00\x7d\x00\xca\x00\x11\x00\xa2\x00\x86\x00\x14\x01\x65\x01\x2d\x00\x88\x00\x4e\x00\xa5\x02\x83\x04\x7c\x00\x7d\x00\x2e\x00\xec\x00\x2f\x00\x8a\x00\x8f\x00\x24\xff\xa7\x02\x8d\x00\x92\x00\x40\x03\x22\x01\x94\x00\x95\x00\x96\x00\x97\x00\x11\x00\xa8\x02\xa9\x02\xaa\x02\x44\x00\x45\x00\xf4\x01\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\xea\x01\x29\x02\xe9\x00\x4d\x00\xf5\x01\xf6\x01\xf7\x01\xcb\x00\x4b\x00\x4c\x00\x4d\x00\x5d\x02\x5e\x02\x5f\x02\x4e\x00\x36\x00\x26\x04\xae\x02\x4d\x00\x72\x04\xf2\x02\x4e\x00\x2c\x01\x3d\x00\x3e\x00\x11\x00\x3f\x00\x40\x00\x54\x05\x4e\x00\x9e\x00\x9f\x00\x14\x03\xca\x00\x81\x01\x15\x03\x82\x01\x41\x00\x83\x01\x55\x05\xa0\x00\x72\x00\x57\x05\x41\x00\xff\xff\x73\x00\x74\x00\x64\x00\x0a\x01\x0f\x01\x42\x00\x67\x00\x0b\x01\x4e\x00\x70\x03\x71\x03\x42\x00\x60\x02\x61\x02\x0f\x00\x62\x02\x86\x00\x44\x02\x65\x01\x41\x00\x88\x00\x11\x00\xff\xff\x11\x00\xce\x00\xa1\x00\x3f\x03\x0f\x00\xcf\x00\x8a\x00\xe9\x00\x23\x03\x42\x00\x8d\x00\x11\x00\xcb\x00\x7c\x00\x7d\x00\x2e\x02\x7a\x00\xa2\x00\x7b\x00\xa5\x02\xa6\x02\x12\x02\xa4\x02\x0e\x00\xec\x00\x0f\x00\x10\x00\x8f\x00\x8e\x01\xa7\x02\x8f\x01\x92\x00\x11\x00\x1c\x03\x94\x00\x95\x00\x96\x00\x97\x00\x1a\x03\xa8\x02\xa9\x02\xaa\x02\x44\x00\x45\x00\x50\x03\x51\x03\x47\x00\x48\x00\x44\x00\x45\x00\x11\x03\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x2e\x02\x7a\x00\x4b\x00\x7b\x00\x4d\x00\x70\x03\x71\x03\xc0\x02\x4b\x00\x4c\x00\x4d\x00\xc6\x01\x01\x03\x44\x00\x45\x00\x4e\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4e\x00\xaf\x02\xac\x02\xad\x02\x9f\x00\xf5\x02\x66\x04\x72\x00\x4b\x00\x4c\x00\x4d\x00\x73\x00\x74\x00\xa0\x00\x72\x00\xa5\x02\xa6\x02\xca\x00\x73\x00\x74\x00\xec\x00\x4e\x00\x88\x01\x8f\x00\x89\x01\xa7\x02\xc9\x02\x92\x00\x65\x02\xe3\x02\x94\x00\x95\x00\x96\x00\x97\x00\x11\x00\xa8\x02\xa9\x02\xaa\x02\xed\x02\x01\x01\x02\x01\x8a\x04\xce\x00\xa1\x00\x03\x01\x0f\x00\xcf\x00\x7c\x00\x7d\x00\x05\xfe\xec\x02\x05\xfe\x11\x00\x05\xfe\x7c\x00\x7d\x00\xdf\x02\x71\x02\xa2\x00\xe9\x00\xe0\x02\x36\x00\x05\xfe\xe9\x02\xcb\x00\xa3\x04\x8b\x04\x91\x04\xa4\x04\xa5\x04\x3e\x00\xeb\x02\x3f\x00\x40\x00\xab\x02\xac\x02\xad\x02\x9f\x00\x55\x02\x62\x01\x72\x00\xea\x02\x38\x02\x79\x03\x73\x00\x74\x00\xa0\x00\x72\x00\xc5\x01\x7f\x00\xca\x00\x73\x00\x74\x00\xc6\x01\xa6\x04\xc4\x01\x9a\x01\x7a\x00\x4c\x01\x7b\x00\x44\x02\xee\x02\xc5\x01\x7f\x00\x47\x00\x48\x00\x11\x00\xc6\x01\xc2\x01\x7d\x00\x41\x00\x0c\x02\x0d\x02\xa6\xfe\x8a\x04\xce\x00\xa1\x00\xa6\xfe\x0f\x00\xcf\x00\x7c\x00\x7d\x00\x3e\x02\x42\x00\xe1\x02\x11\x00\x38\x02\x7c\x00\x7d\x00\xd4\x02\x81\x00\xa2\x00\xe9\x00\x64\x02\x0a\x01\x65\x02\xd3\x02\xcb\x00\x0b\x01\x8b\x04\x8c\x04\x11\x00\x83\x00\xc0\x02\xa5\x02\x8d\x04\x84\x00\xc6\x01\x78\x01\xec\x00\x79\x01\x85\x00\x8f\x00\x7a\x02\xa7\x02\x7b\x02\x92\x00\xe8\x01\xc7\x02\x94\x00\x95\x00\x96\x00\x97\x00\xc3\x02\xa8\x02\xa9\x02\xaa\x02\x28\x05\x29\x05\x74\x03\x49\x01\x65\x02\x28\x05\x4f\x05\x8b\x00\x8c\x00\x5c\x02\x11\x00\x8e\x00\x8f\x00\xdb\x02\xdc\x02\xdd\x02\x44\x00\x45\x00\xce\x02\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x0c\x02\x0d\x02\x72\x01\x41\x00\x0f\x00\x10\x00\x54\x02\x90\x02\x4b\x00\x4c\x00\x4d\x00\x11\x00\xcc\x02\xca\x00\x9e\x00\x9f\x00\x42\x00\x34\x01\x35\x01\x36\x01\x37\x01\x4e\x00\x41\x00\x05\xfd\xa0\x00\x72\x00\xa5\x02\x8d\x04\x53\x02\x73\x00\x74\x00\xec\x00\xca\x00\xc4\x02\x8f\x00\x42\x00\xa7\x02\xd0\x04\x92\x00\x65\x02\xc6\x02\x94\x00\x95\x00\x96\x00\x97\x00\x11\x00\xa8\x02\xa9\x02\xaa\x02\x6c\x01\xc2\x02\x0f\x00\x10\x00\xce\x00\xa1\x00\xb5\x02\x0f\x00\xcf\x00\x11\x00\x7f\x04\xcb\x00\x80\x04\xb1\x02\x11\x00\x49\x03\x7c\x00\x7d\x00\x47\x00\x48\x00\xa2\x00\x81\x00\x7b\x01\x72\x02\x77\x02\xe9\x00\x78\x02\x44\x00\x45\x00\x97\x02\xcb\x00\x47\x00\x48\x00\x83\x00\x70\x03\x71\x03\x21\x05\x84\x00\x9e\x00\x9f\x00\x04\x02\x02\x02\x85\x00\x4b\x00\xe2\x01\x4d\x00\x44\x00\x45\x00\xa0\x00\x72\x00\x47\x00\x48\x00\x96\x02\x73\x00\x74\x00\x67\x04\x4e\x00\x91\x02\x47\x00\x48\x00\x8f\x02\x49\x01\x4b\x00\x86\x02\x4d\x00\x8b\x00\x8c\x00\x01\x02\x02\x02\x8e\x00\x8f\x00\x83\x02\xfd\x03\xf6\x03\xf7\x03\x4e\x00\xb1\x01\xce\x00\xa1\x00\x7f\x02\x0f\x00\xcf\x00\x5d\x03\x5e\x03\x5f\x03\xc1\x01\x10\x00\x11\x00\x7e\x02\x7c\x00\x7d\x00\x7c\x02\x11\x00\xa2\x00\xc2\x01\x7d\x00\xcc\x00\xca\x00\x7a\x02\x8f\x00\x7b\x02\xcd\x00\x2e\x04\x92\x00\x2f\x04\x75\x02\x94\x00\x95\x00\x96\x00\x97\x00\xa5\x02\x83\x04\x98\x00\x99\x00\xbc\x02\xec\x00\x0f\x00\x10\x00\x8f\x00\x74\x02\xa7\x02\x8a\x04\x92\x00\x11\x00\x72\x02\x94\x00\x95\x00\x96\x00\x97\x00\x71\x02\xa8\x02\xa9\x02\xaa\x02\xc7\x02\x10\x00\x81\x00\x48\x01\xa7\xfe\x73\x02\xe9\x00\x11\x00\xa7\xfe\xc2\x01\x7d\x00\xcb\x00\x69\x02\x29\x05\x83\x00\x51\x03\x52\x03\x53\x03\x84\x00\x9e\x00\x9f\x00\xb3\x01\x25\x04\x85\x00\x26\x04\x57\x02\x7d\x01\x7e\x01\x45\x00\xa0\x00\x72\x00\x47\x00\x48\x00\x56\x02\x73\x00\x74\x00\x54\x02\xca\x00\x9e\x00\x9f\x00\x75\x01\xad\x01\x49\x01\x7f\x01\x53\x02\x4d\x00\x8b\x00\x8c\x00\xa0\x00\x72\x00\x8e\x00\x8f\x00\x51\x02\x73\x00\x74\x00\x78\x01\x4e\x00\x79\x01\xce\x00\xa1\x00\x44\x02\x0f\x00\xcf\x00\xb7\x02\x43\x02\x0f\x00\x10\x00\x40\x02\x11\x00\x3f\x01\x7c\x00\x7d\x00\x11\x00\xe3\x03\xa2\x00\xe4\x03\x3f\x02\xce\x00\xa1\x00\xe9\x00\x0f\x00\xcf\x00\x36\x02\xc4\x04\xcb\x00\xc5\x04\x98\x04\x11\x00\x99\x04\x7c\x00\x7d\x00\xa5\x02\x8d\x04\xa2\x00\xfd\x04\x76\x04\xec\x00\x77\x04\x62\x04\x8f\x00\x63\x04\xa7\x02\x30\x02\x92\x00\x9b\x02\x31\x02\x94\x00\x95\x00\x96\x00\x97\x00\x57\x00\xa8\x02\xa9\x02\xaa\x02\x75\x01\x76\x01\x06\x04\x9d\x02\xdf\x01\x73\x01\x6e\x01\x36\x00\x58\x00\x70\x01\x6e\x01\x40\x01\x41\x01\x25\x02\x3c\x00\x3d\x00\x3e\x00\x5c\x00\x3f\x00\x40\x00\xcf\x01\x7a\x00\x12\x02\x7b\x00\xc4\x01\x9a\x01\x7a\x00\x9e\x02\x7b\x00\x9a\x02\xf9\x02\xfa\x02\xfb\x02\xfc\x02\xfd\x02\x61\x01\x28\x03\xca\x00\x9e\x00\x9f\x00\x65\x00\x66\x00\x6d\x01\x6e\x01\x68\x00\x69\x00\x37\x01\x38\x01\xa0\x00\x72\x00\xa5\x02\xa6\x02\xff\x00\x73\x00\x74\x00\xec\x00\x41\x00\xf8\x04\x8f\x00\xf9\x04\xa7\x02\x62\x04\x92\x00\x63\x04\x04\x02\x94\x00\x95\x00\x96\x00\x97\x00\x42\x00\xa8\x02\xa9\x02\xaa\x02\x16\x04\x17\x04\x18\x04\xd8\x03\xce\x00\xa1\x00\xe9\x00\x0f\x00\xcf\x00\xd2\x03\x06\x03\xcb\x00\x07\x03\xd8\x01\x11\x00\xd9\x01\x7c\x00\x7d\x00\x1f\x01\x20\x01\xa2\x00\xfc\x04\x7a\x03\x7e\x01\x45\x00\x75\x03\x76\x03\x47\x00\x48\x00\x75\x01\x20\x04\x81\x00\x27\x02\xcf\x03\x11\x04\x12\x04\x13\x04\xca\x00\x9e\x00\x9f\x00\xf5\x03\xf6\x03\xf7\x03\x83\x00\xb1\x01\x98\x02\x4a\x00\x84\x00\xa0\x00\x72\x00\xc1\x04\xbd\x04\x85\x00\x73\x00\x74\x00\xc5\x03\x44\x00\x45\x00\xe8\x04\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x60\x01\x99\x04\x17\x04\x18\x04\xc6\x03\x41\x00\x61\x01\xe7\xfc\x4b\x00\x4c\x00\x4d\x00\x8b\x00\x8c\x00\xce\x00\xa1\x00\xe9\x00\x0f\x00\xcf\x00\x42\x00\x04\xfd\xcb\x00\x4e\x00\x42\x02\x11\x00\xee\xfc\x7c\x00\x7d\x00\xa5\x02\xa6\x02\xa2\x00\xef\xfc\x69\x02\xec\x00\xb1\x01\x03\xfd\x8f\x00\xe8\xfc\xa7\x02\xe9\xfc\x92\x00\xbc\x04\xbd\x04\x94\x00\x95\x00\x96\x00\x97\x00\xc4\x03\xa8\x02\xa9\x02\xaa\x02\xc9\x01\xc3\x03\xca\x01\x93\x04\x17\x04\x18\x04\xcb\x01\x36\x00\xc2\x03\xc4\x01\x9a\x01\x7a\x00\xe9\x04\x7b\x00\x2c\x01\x3d\x00\x3e\x00\xc1\x03\x3f\x00\x40\x00\xe5\x04\x17\x04\x18\x04\x7b\x05\x17\x04\x18\x04\x0a\x04\x0b\x04\x44\x00\x45\x00\xce\x01\x25\x05\x47\x00\x48\x00\x13\x01\x80\x05\x17\x04\x18\x04\x9e\x00\x9f\x00\x11\x00\xc0\x03\x7c\x00\x7d\x00\x4b\x00\x15\xfd\x4d\x00\xbd\x03\xa0\x00\x72\x00\xa5\x02\x09\x04\xbc\x03\x73\x00\x74\x00\xec\x00\x41\x00\x4e\x00\x8f\x00\xbb\x03\xa7\x02\x3c\x02\x92\x00\x88\x04\x5f\x03\x94\x00\x95\x00\x96\x00\x97\x00\x42\x00\xa8\x02\xa9\x02\xaa\x02\xd7\x04\x13\x04\x5b\x05\x5c\x05\xce\x00\xa1\x00\x61\x01\x0f\x00\xcf\x00\x39\x02\x30\x03\x1b\x01\x92\x03\x91\x03\x11\x00\x10\x01\x7c\x00\x7d\x00\x73\x00\x11\x01\xa2\x00\x36\x00\x85\x03\x87\x03\x86\x03\x84\x03\xf2\x02\x83\x03\x2c\x01\x3d\x00\x3e\x00\x82\x03\x3f\x00\x40\x00\x80\x03\x81\x03\x7f\x03\x7c\x03\x9e\x00\x9f\x00\x20\x05\x5d\x01\x12\x01\x62\x03\x79\x03\x78\x03\x13\x01\x19\xfd\xa0\x00\x72\x00\x5d\x03\x5b\x03\x11\x00\x73\x00\x74\x00\x14\x01\x44\x00\x45\x00\x5a\x03\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x58\x03\x8a\x00\x4e\x03\x62\x05\x22\x01\x34\x03\x41\x00\x2d\x03\x4b\x00\x4c\x00\x4d\x00\x2c\x03\x25\x02\xce\x00\xa1\x00\x2b\x03\x0f\x00\xcf\x00\x28\x03\x42\x00\x81\x00\x4e\x00\xff\x00\x11\x00\x5b\x04\x7c\x00\x7d\x00\x06\x04\xa0\x02\xa2\x00\x4d\x04\x21\x02\x83\x00\x4c\x04\x4a\x04\x49\x04\x84\x00\x44\x04\x3e\x04\x36\x00\x38\x04\x85\x00\x3c\x04\x3b\x04\xf2\x02\x3a\x04\x2c\x01\x3d\x00\x3e\x00\x41\x00\x3f\x00\x40\x00\x0f\xfd\x0e\xfd\x10\xfd\x36\x04\x29\x04\xd4\x02\x23\x04\x68\x03\xa1\x02\x34\x04\x42\x00\x1c\x04\x8b\x00\x8c\x00\x36\x00\x1a\x04\x41\x00\x1e\x04\x15\x04\xf2\x02\x3c\x02\x2c\x01\x3d\x00\x3e\x00\x11\x04\x3f\x00\x40\x00\x44\x00\x45\x00\x42\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x6a\x00\x41\x00\xfa\x03\x0f\x04\xf2\x03\x06\x04\x41\x02\xe8\x03\x4b\x00\x4c\x00\x4d\x00\xfc\x03\xf4\x03\xe9\x03\x42\x00\xe1\x03\xe0\x03\xdf\x03\xde\x03\xbc\x04\x71\x02\x4e\x00\x36\x00\xbb\x04\x68\x03\xba\x04\x40\x01\x41\x01\x41\x00\x3c\x00\x3d\x00\x3e\x00\xb2\x04\x3f\x00\x40\x00\x44\x00\x45\x00\xb3\x01\x8d\x03\x47\x00\x48\x00\x42\x00\x5f\x04\xaa\x04\xab\x04\xa8\x04\xa9\x04\x1a\x04\x97\x04\x1c\x04\x7f\x04\x4b\x00\x1a\x04\x4d\x00\x44\x00\x45\x00\x90\x01\x72\x00\x47\x00\x48\x00\x7a\x04\x73\x00\x74\x00\x75\x04\x4e\x00\x51\x05\x71\x04\x70\x04\x6c\x04\x6b\x04\x4b\x00\x41\x00\x4d\x00\x6d\x04\x44\x00\x45\x00\x06\x04\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x5f\x04\x4e\x00\x42\x00\x0b\x05\x91\x01\x0a\x05\x0f\x00\x10\x00\x4b\x00\x4c\x00\x4d\x00\x09\x05\x2b\x03\x11\x00\x00\x05\x7c\x00\x7d\x00\xfb\x04\xfa\x04\x44\x00\x45\x00\x4e\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\xf4\x04\x64\x04\xef\x04\x1a\x04\x3d\x01\xda\x04\xd9\x04\x36\x00\x4b\x00\x4c\x00\x4d\x00\x6a\x03\x6b\x03\x83\x00\x3c\x00\x3d\x00\x3e\x00\x84\x00\x3f\x00\x40\x00\x8c\xfe\x4e\x00\x85\x00\x7d\x03\x69\x01\x15\x04\x6a\x01\x0f\x01\xd3\x04\x3b\x05\x10\x01\x34\x05\x39\x05\x73\x00\x11\x01\x44\x00\x45\x00\x31\x05\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x2b\x05\x30\x05\x8b\x00\x65\x04\x2c\x05\x4c\x01\x8e\x00\x66\x04\x4b\x00\x4c\x00\x4d\x00\x2e\x05\x13\x05\x41\x00\x12\x01\x11\x05\x5a\x05\x10\x05\x13\x01\x0e\x05\x59\x05\x4e\x00\x5d\x03\x53\x05\x11\x00\x48\x05\x42\x00\x14\x01\x6f\x05\x28\x03\x6a\x05\x67\x05\x36\x00\x37\x00\xd5\x01\x39\x00\x3a\x00\x3b\x00\x28\x03\x3c\x00\x3d\x00\x3e\x00\x62\x05\x3f\x00\x40\x00\x7f\x05\x1c\x04\x1a\x04\xd6\x01\xd7\x01\x1a\x04\x36\x00\x37\x00\x45\x02\x39\x00\x3a\x00\x3b\x00\x7a\x05\x3c\x00\x3d\x00\x3e\x00\x85\x05\x3f\x00\x40\x00\x84\x05\x80\x05\x87\x05\xff\x00\x08\x02\xfd\x00\xc3\x01\x07\x02\xab\x01\x7b\x01\x8f\x01\xf9\x01\x8c\x01\x86\x01\x4a\x01\x32\x01\x27\x01\x41\x00\x0d\x01\x0c\x01\x08\x01\x1e\x03\x44\x00\x45\x00\x1d\x03\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x42\x00\x1c\x03\xbf\x02\x67\x01\x68\x01\x69\x01\x41\x00\x6a\x01\x4b\x00\x4c\x00\x4d\x00\x10\x01\x1a\x03\x11\x03\x73\x00\x11\x01\x0b\x03\xf9\x01\xfd\x02\x42\x00\xe1\x02\x4e\x00\xf7\x02\xc4\x02\xd5\x02\x36\x00\x37\x00\xdb\x01\x39\x00\x3a\x00\x3b\x00\x8a\x02\x3c\x00\x3d\x00\x3e\x00\x78\x02\x3f\x00\x40\x00\x12\x01\xb8\x02\x43\x00\x75\x02\x13\x01\x6f\x02\x0d\x02\x12\x02\x2e\x02\x7a\x00\x11\x00\x7b\x00\x0a\x02\x14\x01\xdc\x03\xc0\x02\xdb\x03\xda\x03\xd9\x03\xc6\x01\x23\x03\x43\x00\x44\x00\x45\x00\xd8\x03\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\xd3\x03\xbe\x03\x96\x03\x6d\x02\x60\x03\x92\x03\x41\x00\x5b\x03\x4b\x00\x4c\x00\x4d\x00\x44\x00\x45\x00\x8e\x03\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x42\x00\x8d\x03\x4e\x00\x4e\x03\x58\x03\x56\x03\x37\x03\x35\x03\x4b\x00\x4c\x00\x4d\x00\xd8\x01\x3f\x03\xd9\x01\x34\x03\x32\x03\x29\x03\x28\x03\x2d\x03\x2e\x02\x7a\x00\x4e\x00\x7b\x00\x26\x03\x5d\x04\xc5\x01\x7f\x00\x4a\x04\x3c\x04\x32\x04\xc6\x01\x2c\x04\x23\x04\x21\x04\x36\x00\x37\x00\xdb\x01\x39\x00\x3a\x00\x3b\x00\x43\x00\x3c\x00\x3d\x00\x3e\x00\x2f\x04\x3f\x00\x40\x00\x1a\x04\x04\x04\xfc\x03\xe1\x03\xf4\x03\xc5\x04\xc2\x04\xb4\x04\xb6\x04\x43\x01\x6d\x02\x94\x04\xa1\x04\x44\x00\x45\x00\x7d\x04\x46\x00\x47\x00\x48\x00\xdc\x01\x4a\x00\x89\x04\x44\x01\x6d\x04\x45\x01\x46\x01\x6e\x04\x69\x04\x68\x04\x4b\x00\x4c\x00\x4d\x00\x60\x04\x01\x05\x5f\x04\x77\x00\x41\x00\x78\x00\x79\x00\x7a\x00\xf6\x04\x7b\x00\x4e\x00\xf5\x04\x7e\x00\x7f\x00\xf4\x04\xf2\x04\xed\x04\x42\x00\xdd\x04\xdd\x01\xda\x04\xe6\x02\xef\x04\xce\x04\x36\x00\x37\x00\xcd\x04\xe7\x02\x3a\x00\x3b\x00\xcf\x04\x3c\x00\x3d\x00\x3e\x00\x3b\x05\x3f\x00\x40\x00\x39\x05\xdb\x04\x35\x05\x36\x05\x2e\x05\x26\x05\x1f\x05\x16\x05\x11\x05\x0e\x05\x50\x05\x5a\x05\x43\x05\x4d\x05\xda\x04\xe6\x02\x42\x05\x56\x05\x36\x00\x37\x00\x43\x00\xe7\x02\x3a\x00\x3b\x00\x68\x05\x3c\x00\x3d\x00\x3e\x00\x7c\x05\x3f\x00\x40\x00\x55\x05\x45\x05\x78\x05\x74\x05\x72\x05\x41\x00\x82\x05\x81\x05\x85\x05\x44\x00\x45\x00\x00\x00\x46\x00\x47\x00\x48\x00\xdc\x01\x4a\x00\x00\x00\x42\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x65\x05\x4c\x00\x4d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x41\x00\x00\x00\x4e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xdd\x01\x00\x00\x42\x00\x00\x00\x00\x00\xe5\x02\xe6\x02\x81\x00\x00\x00\x36\x00\x37\x00\x43\x00\xe7\x02\x3a\x00\x3b\x00\xc8\x01\x3c\x00\x3d\x00\x3e\x00\x83\x00\x3f\x00\x40\x00\x00\x00\x84\x00\x00\x00\x00\x00\x00\x00\x00\x00\x85\x00\x00\x00\x00\x00\x44\x00\x45\x00\x00\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x00\x00\x60\x01\x00\x00\x43\x00\x00\x00\x00\x00\x00\x00\x61\x01\x4b\x00\x4c\x00\x4d\x00\x00\x00\x8b\x00\x8c\x00\x00\x00\x00\x00\x8e\x00\x8f\x00\x00\x00\x41\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\x42\x00\x7c\x03\x67\x01\x68\x01\x69\x01\x00\x00\x6a\x01\x4b\x00\x4c\x00\x4d\x00\x10\x01\x00\x00\x00\x00\x73\x00\x11\x01\x00\x00\x00\x00\x4a\x03\xe6\x02\x00\x00\x4e\x00\x36\x00\x37\x00\x00\x00\xe7\x02\x3a\x00\x3b\x00\x00\x00\x3c\x00\x3d\x00\x3e\x00\x00\x00\x3f\x00\x40\x00\x00\x00\x00\x00\x81\x00\x12\x01\x00\x00\x00\x00\x43\x00\x13\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x83\x00\x00\x00\x14\x01\x00\x00\x84\x00\x00\x00\x00\x00\x00\x00\x00\x00\x85\x00\x00\x00\x00\x00\x44\x00\x45\x00\x00\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x00\x00\x60\x01\x41\x00\x00\x00\x00\x00\x00\x00\x00\x00\x61\x01\x4b\x00\x4c\x00\x4d\x00\x00\x00\x8b\x00\x8c\x00\x00\x00\x42\x00\x8e\x00\x8f\x00\x00\x00\xb5\x02\x00\x00\x4e\x00\x36\x00\x37\x00\x00\x00\xa2\x02\x3a\x00\x3b\x00\x00\x00\x3c\x00\x3d\x00\x3e\x00\x00\x00\x3f\x00\x40\x00\xed\x02\x00\x00\x00\x00\xb5\x02\x00\x00\x00\x00\x36\x00\x37\x00\x00\x00\xa2\x02\x3a\x00\x3b\x00\x00\x00\x3c\x00\x3d\x00\x3e\x00\x00\x00\x3f\x00\x40\x00\xb6\x02\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\x41\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\x42\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x41\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\x42\x00\x4e\x00\x00\x00\xb5\x02\x00\x00\x00\x00\x36\x00\x37\x00\x00\x00\xa2\x02\x3a\x00\x3b\x00\x00\x00\x3c\x00\x3d\x00\x3e\x00\x00\x00\x3f\x00\x40\x00\x2b\x04\x00\x00\x43\x00\x0c\x04\x00\x00\x0f\x04\x36\x00\x37\x00\x00\x00\xa2\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\x0c\x04\x00\x00\x0d\x04\x36\x00\x37\x00\x00\x00\xa2\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\x0c\x04\x00\x00\xd6\x04\x36\x00\x37\x00\x00\x00\xa2\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\x43\x01\x4b\x00\x4c\x00\x4d\x00\x44\x00\x45\x00\x00\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x42\x00\xd1\x02\x4e\x00\x45\x01\x46\x01\x00\x00\x41\x00\x00\x00\x4b\x00\x4c\x00\x4d\x00\x00\x00\x00\x00\x00\x00\x77\x00\x00\x00\x78\x00\x79\x00\x7a\x00\x42\x00\x7b\x00\x4e\x00\xa1\x02\x7e\x00\x7f\x00\x36\x00\x37\x00\x00\x00\xd6\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\xa1\x02\x00\x00\x00\x00\x36\x00\x37\x00\x00\x00\xa2\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\x43\x01\x4b\x00\x4c\x00\x4d\x00\x44\x00\x45\x00\x00\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x42\x00\x44\x01\x4e\x00\x45\x01\x46\x01\x00\x00\x41\x00\x00\x00\x4b\x00\x4c\x00\x4d\x00\x00\x00\x00\x00\x00\x00\x77\x00\x00\x00\x78\x00\x79\x00\x7a\x00\x42\x00\x7b\x00\x4e\x00\x3e\x03\x7e\x00\x7f\x00\x36\x00\x37\x00\x00\x00\xa2\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\x07\x04\x00\x00\x00\x00\x36\x00\x37\x00\x00\x00\xa2\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\x78\x04\x00\x00\x00\x00\x36\x00\x37\x00\x00\x00\xa2\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\xfb\x04\x00\x00\x00\x00\x36\x00\x37\x00\x00\x00\xa2\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\x4f\x05\x00\x00\x00\x00\x36\x00\x37\x00\x00\x00\xa2\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\x67\x05\x00\x00\x00\x00\x36\x00\x37\x00\x00\x00\xa2\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\x81\x00\x48\x01\x41\x00\x00\x00\x4b\x00\x4c\x00\x4d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x83\x00\x00\x00\x00\x00\x42\x00\x84\x00\x4e\x00\x00\x00\x00\x00\x00\x00\x85\x00\x36\x00\x37\x00\x4d\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\xe4\x02\x4f\x02\x00\x00\x49\x01\x00\x00\x00\x00\x00\x00\x8b\x00\x8c\x00\x00\x00\x00\x00\x8e\x00\x8f\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\x4d\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\x4e\x02\x4f\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x81\x00\x00\x00\x72\x04\x00\x00\x00\x00\x43\x00\x36\x00\x37\x00\x4d\x02\x39\x00\x3a\x00\x3b\x00\x83\x00\x3c\x00\x3d\x00\x3e\x00\x84\x00\x3f\x00\x40\x00\x00\x00\x00\x00\x85\x00\xca\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\x49\x01\x4b\x00\x4c\x00\x4d\x00\x8b\x00\x8c\x00\x00\x00\x00\x00\x8e\x00\x8f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4e\x00\x41\x00\x00\x00\x00\x00\x36\x00\x37\x00\x4d\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\xc9\x03\x00\x00\x00\x00\x43\x00\x00\x00\x00\x00\x65\x01\x66\x01\x67\x01\x68\x01\x69\x01\x00\x00\x6a\x01\x00\x00\x00\x00\x00\x00\x10\x01\x00\x00\x00\x00\x73\x00\x11\x01\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\x12\x01\x00\x00\x00\x00\x42\x00\x13\x01\x00\x00\x00\x00\x00\x00\x00\x00\x4e\x00\x11\x00\x44\x00\x45\x00\x14\x01\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\x81\x00\x24\x05\x4e\x00\x00\x00\x00\x00\x43\x00\x36\x00\x37\x00\xc7\x03\x39\x00\x3a\x00\x3b\x00\x83\x00\x3c\x00\x3d\x00\x3e\x00\x84\x00\x3f\x00\x40\x00\x00\x00\x00\x00\x85\x00\x00\x00\xc8\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\x49\x01\x4b\x00\x4c\x00\x4d\x00\x8b\x00\x8c\x00\x00\x00\x00\x00\x8e\x00\x8f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4e\x00\x41\x00\x00\x00\x00\x00\x36\x00\x37\x00\x4d\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\xc6\x03\x00\x00\x00\x00\x36\x00\x37\x00\x4d\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\xe9\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\x34\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\x49\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\xe0\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\x4a\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\x89\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\x1e\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\x4b\x03\x39\x00\x3a\x00\x3b\x00\x1f\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\x34\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\x1e\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\x31\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\x1e\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\x2a\x04\x00\x00\xc9\x01\x00\x00\xca\x01\x00\x00\x00\x00\x00\x00\xcb\x01\x36\x00\x37\x00\xcc\x01\x1e\x02\x3a\x00\x3b\x00\x00\x00\x3c\x00\x3d\x00\x3e\x00\x00\x00\x3f\x00\x40\x00\x00\x00\xcd\x01\x41\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x43\x00\x00\x00\xce\x01\x00\x00\x29\x04\x00\x00\x13\x01\x42\x00\x00\x00\x00\x00\xcf\x01\x7a\x00\x11\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\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\x1e\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\x15\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\x1e\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\xe6\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\x1e\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\xe5\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\x17\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\x1e\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\x4c\x05\x81\x00\x00\x00\x00\x00\x00\x00\x41\x00\x43\x00\x4b\x00\x4c\x00\x4d\x00\x00\x00\x00\x00\x00\x00\x83\x00\x00\x00\x00\x00\x00\x00\x84\x00\x42\x00\x00\x00\x4e\x00\x00\x00\x85\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\x49\x01\x4b\x00\x4c\x00\x4d\x00\x8b\x00\x8c\x00\x00\x00\x00\x00\x8e\x00\x8f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4e\x00\x36\x00\x37\x00\x43\x00\xff\x01\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\x5b\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\x28\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\x23\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\x22\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\x20\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\xd2\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\xcc\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\x13\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\xe3\x04\xe4\x04\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\x00\x00\x00\x00\x00\x00\x00\x00\xf0\x02\x00\x00\x2c\x01\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\x00\x00\xe3\x02\x00\x00\x2c\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\x62\x03\x00\x00\x2c\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\x95\x04\x00\x00\x2c\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\x7a\x04\x00\x00\x2c\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\x24\x05\x00\x00\x2c\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\x22\x05\x00\x00\x2c\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\x48\x05\x00\x00\x2c\x01\x3d\x00\x3e\x00\x00\x00\x3f\x00\x40\x00\x00\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\x00\x02\x3e\x00\x00\x00\x3f\x00\x40\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\x36\x00\x41\x00\x4b\x00\x4c\x00\x4d\x00\x00\x00\x00\x00\x00\x00\x31\x05\x3e\x00\x00\x00\x3f\x00\x40\x00\x00\x00\x42\x00\x4e\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\x26\x02\x3e\x00\x00\x00\x3f\x00\x40\x00\x32\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\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\x00\x00\x41\x00\x4b\x00\x4c\x00\x4d\x00\x00\x00\x44\x00\x45\x00\x00\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x42\x00\x4e\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\x00\x00\x00\x00\x00\x00\x00\x00\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4b\x00\x4c\x00\x4d\x00\x00\x00\x44\x00\x45\x00\x00\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x00\x00\x4e\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\xf6\xfc\xf6\xfc\xf6\xfc\xf6\xfc\x00\x00\x00\x00\x4e\x00\xf6\xfc\xf6\xfc\xf6\xfc\xf6\xfc\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf6\xfc\xf6\xfc\x00\x00\x00\x00\xf6\xfc\xf6\xfc\xf6\xfc\x00\x00\xf6\xfc\xf6\xfc\x00\x00\xf6\xfc\xf6\xfc\xf6\xfc\xf6\xfc\xf6\xfc\xf6\xfc\xf6\xfc\xf6\xfc\xf6\xfc\xf6\xfc\xf6\xfc\xf6\xfc\xf6\xfc\xf6\xfc\x00\x00\xf6\xfc\xf6\xfc\xf6\xfc\x00\x00\x00\x00\xf6\xfc\xf6\xfc\xf6\xfc\xf6\xfc\xf6\xfc\xf6\xfc\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf6\xfc\xf6\xfc\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf6\xfc\xf6\xfc\xf6\xfc\xf6\xfc\xf6\xfc\xf6\xfc\x00\x00\x00\x00\xf6\xfc\xf6\xfc\xf6\xfc\xf6\xfc\xf6\xfc\xf6\xfc\xf6\xfc\xf6\xfc\xf6\xfc\xf6\xfc\xf6\xfc\xf6\xfc\xf6\xfc\xf6\xfc\xf6\xfc\xf6\xfc\x00\x00\xf6\xfc\xf6\xfc\xf6\xfc\xf6\xfc\xf6\xfc\x00\x00\xf6\xfc\xf6\xfc\xf6\xfc\xf6\xfc\xf6\xfc\xf6\xfc\xf6\xfc\xf6\xfc\xf6\xfc\xf6\xfc\xf6\xfc\xf6\xfc\xf6\xfc\xf6\xfc\xf6\xfc\xf6\xfc\xf6\xfc\xf6\xfc\xf6\xfc\xf6\xfc\xf6\xfc\xf6\xfc\xf6\xfc\xf6\xfc\xf6\xfc\xf6\xfc\xf6\xfc\xf6\xfc\xf6\xfc\xf6\xfc\xf6\xfc\xf6\xfc\xf6\xfc\xf6\xfc\xf6\xfc\xf6\xfc\xf6\xfc\xf6\xfc\xf6\xfc\xf6\xfc\xf6\xfc\xf6\xfc\xf6\xfc\xf6\xfc\xf6\xfc\xf6\xfc\xf6\xfc\xf6\xfc\xea\xfd\xea\xfd\xea\xfd\xea\xfd\x00\x00\x00\x00\x00\x00\xea\xfd\xea\xfd\xea\xfd\xea\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xea\xfd\xea\xfd\x00\x00\x00\x00\xea\xfd\xea\xfd\xea\xfd\x00\x00\xea\xfd\xea\xfd\x00\x00\xea\xfd\xea\xfd\xea\xfd\xea\xfd\xea\xfd\xea\xfd\xea\xfd\xea\xfd\xea\xfd\xea\xfd\xea\xfd\xea\xfd\xea\xfd\xea\xfd\x00\x00\xea\xfd\xea\xfd\xea\xfd\x00\x00\x00\x00\xea\xfd\xea\xfd\xea\xfd\xea\xfd\xea\xfd\xea\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xea\xfd\xea\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xea\xfd\xea\xfd\xea\xfd\xea\xfd\xea\xfd\xea\xfd\x00\x00\x00\x00\xea\xfd\xea\xfd\xea\xfd\xea\xfd\x00\x00\xea\xfd\xea\xfd\xea\xfd\xea\xfd\xea\xfd\xea\xfd\xea\xfd\xea\xfd\xea\xfd\xea\xfd\xea\xfd\x00\x00\xea\xfd\xea\xfd\xea\xfd\xea\xfd\xea\xfd\x00\x00\xea\xfd\xea\xfd\xea\xfd\xea\xfd\xea\xfd\xea\xfd\xea\xfd\xea\xfd\xea\xfd\xea\xfd\xea\xfd\xea\xfd\xea\xfd\xea\xfd\xea\xfd\xea\xfd\xea\xfd\xea\xfd\xea\xfd\xea\xfd\xea\xfd\xea\xfd\xea\xfd\xea\xfd\xea\xfd\xea\xfd\xea\xfd\xea\xfd\xea\xfd\xea\xfd\xea\xfd\xea\xfd\xea\xfd\xea\xfd\xea\xfd\xea\xfd\xea\xfd\xea\xfd\xea\xfd\xea\xfd\xea\xfd\xea\xfd\xea\xfd\xea\xfd\xea\xfd\xea\xfd\xea\xfd\xea\xfd\xd8\xfd\xd8\xfd\x13\x00\xd8\xfd\x00\x00\x00\x00\x00\x00\xd8\xfd\xd8\xfd\x14\x00\xd8\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd8\xfd\xd8\xfd\x00\x00\x00\x00\xd8\xfd\x15\x00\xd8\xfd\x00\x00\xd8\xfd\xd8\xfd\x00\x00\x17\x00\x18\x00\x19\x00\x52\x00\x53\x00\x54\x00\xd8\xfd\xd8\xfd\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xd8\xfd\x00\x00\x24\x00\xd8\xfd\xd8\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\xd8\xfd\xd8\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd8\xfd\xd8\xfd\xd8\xfd\xd8\xfd\xd8\xfd\xd8\xfd\x00\x00\x00\x00\xd8\xfd\xd8\xfd\xd8\xfd\xd8\xfd\x00\x00\xd8\xfd\xd8\xfd\xd8\xfd\xd8\xfd\xd8\xfd\xd8\xfd\xd8\xfd\xd8\xfd\xd8\xfd\xd8\xfd\xd8\xfd\x00\x00\xd8\xfd\xd8\xfd\xd8\xfd\xd8\xfd\xd8\xfd\x00\x00\xd8\xfd\x81\x01\xd8\xfd\x82\x01\xd8\xfd\x83\x01\xd8\xfd\xd8\xfd\xd8\xfd\xd8\xfd\xd8\xfd\xd8\xfd\xd8\xfd\x63\x00\x64\x00\xd8\xfd\xd8\xfd\xd8\xfd\x67\x00\xd8\xfd\xd8\xfd\xd8\xfd\xd8\xfd\xd8\xfd\xd8\xfd\xd8\xfd\xd8\xfd\xd8\xfd\xd8\xfd\xd8\xfd\xd8\xfd\xd8\xfd\xd8\xfd\xd8\xfd\xd8\xfd\xd8\xfd\xd8\xfd\xd8\xfd\xd8\xfd\xd8\xfd\xd8\xfd\xd8\xfd\xd8\xfd\xd8\xfd\xd8\xfd\xd8\xfd\xd8\xfd\xd8\xfd\x8b\xfe\x50\x00\x13\x00\x8b\xfe\x00\x00\x00\x00\x00\x00\x8b\xfe\x8b\xfe\x14\x00\x8b\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x8b\xfe\x8b\xfe\x00\x00\x00\x00\x8b\xfe\x15\x00\x8b\xfe\x00\x00\x8b\xfe\x8b\xfe\x00\x00\x17\x00\x18\x00\x19\x00\x52\x00\x53\x00\x54\x00\x8b\xfe\x8b\xfe\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x8b\xfe\x00\x00\x24\x00\x8b\xfe\x8b\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\x8b\xfe\x8b\xfe\x57\x00\x8b\xfe\x8b\xfe\x8b\xfe\x00\x00\x00\x00\x8b\xfe\x8b\xfe\x8b\xfe\x8b\xfe\x00\x00\x8b\xfe\x58\x00\x59\x00\x5a\x00\x8b\xfe\x5b\x00\x8b\xfe\x8b\xfe\x8b\xfe\x8b\xfe\x5c\x00\x00\x00\x00\x00\xf9\x01\x8b\xfe\x5d\x00\x8b\xfe\x00\x00\x8b\xfe\x5e\x00\x8b\xfe\x5f\x00\x8b\xfe\x60\x00\x8b\xfe\x8b\xfe\x8b\xfe\x8b\xfe\x8b\xfe\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x8b\xfe\x67\x00\x68\x00\x69\x00\x8b\xfe\x8b\xfe\x8b\xfe\x8b\xfe\x6b\x00\x6c\x00\x6d\x00\x8b\xfe\x8b\xfe\x8b\xfe\x8b\xfe\x8b\xfe\x8b\xfe\x8b\xfe\x8b\xfe\x8b\xfe\x8b\xfe\x8b\xfe\x8b\xfe\x8b\xfe\x8b\xfe\x6e\x00\x8b\xfe\x8b\xfe\x6f\x00\x70\x00\x8b\xfe\x40\xfd\x40\xfd\x40\xfd\x40\xfd\x00\x00\x00\x00\x00\x00\x40\xfd\x40\xfd\x40\xfd\x40\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\xfd\x40\xfd\x00\x00\x00\x00\x40\xfd\x40\xfd\x40\xfd\x00\x00\x40\xfd\x40\xfd\x00\x00\x40\xfd\x40\xfd\x40\xfd\x40\xfd\x40\xfd\x40\xfd\x40\xfd\x40\xfd\x40\xfd\x40\xfd\x40\xfd\x40\xfd\x40\xfd\x40\xfd\x00\x00\x40\xfd\x40\xfd\x40\xfd\x00\x00\x00\x00\x40\xfd\x40\xfd\x40\xfd\x40\xfd\x40\xfd\x40\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\xfd\x40\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\xfd\x40\xfd\x40\xfd\x40\xfd\x40\xfd\x40\xfd\x00\x00\x00\x00\x40\xfd\x40\xfd\x40\xfd\x40\xfd\x00\x00\x40\xfd\x40\xfd\x40\xfd\x40\xfd\x40\xfd\x40\xfd\x40\xfd\x40\xfd\x40\xfd\x40\xfd\x40\xfd\x00\x00\x00\x00\x40\xfd\x40\xfd\x40\xfd\x40\xfd\x00\x00\x40\xfd\x40\xfd\x40\xfd\x40\xfd\x40\xfd\x40\xfd\x40\xfd\x40\xfd\x40\xfd\x40\xfd\x40\xfd\x40\xfd\x40\xfd\x40\xfd\x40\xfd\x40\xfd\x40\xfd\x40\xfd\x40\xfd\x40\xfd\x40\xfd\x40\xfd\x40\xfd\x40\xfd\x40\xfd\x40\xfd\x40\xfd\x40\xfd\x40\xfd\x40\xfd\x40\xfd\x40\xfd\x40\xfd\x40\xfd\x40\xfd\x40\xfd\x40\xfd\x40\xfd\x40\xfd\x40\xfd\x40\xfd\x40\xfd\x40\xfd\x40\xfd\x40\xfd\x40\xfd\x40\xfd\x40\xfd\x7d\xfe\x7d\xfe\x7d\xfe\x7d\xfe\x00\x00\x00\x00\x00\x00\x7d\xfe\x7d\xfe\x7d\xfe\x7d\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7d\xfe\x7d\xfe\x00\x00\x00\x00\x7d\xfe\x7d\xfe\x7d\xfe\x00\x00\x7d\xfe\x7d\xfe\x00\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\x00\x00\x7d\xfe\x7d\xfe\x7d\xfe\x00\x00\x00\x00\x7d\xfe\x7d\xfe\x7d\xfe\x7d\xfe\x7d\xfe\x7d\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7d\xfe\x7d\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7d\xfe\x7d\xfe\x7d\xfe\x7d\xfe\x7d\xfe\x7d\xfe\x00\x00\x00\x00\x7d\xfe\x7d\xfe\x7d\xfe\x7d\xfe\x00\x00\x7d\xfe\x7d\xfe\x7d\xfe\x7d\xfe\x7d\xfe\x7d\xfe\x7d\xfe\x7d\xfe\x7d\xfe\x7d\xfe\x7d\xfe\x00\x00\x00\x00\x7d\xfe\x7d\xfe\x7d\xfe\x7d\xfe\x00\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\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\x7d\xfe\x7d\xfe\x7d\xfe\x7d\xfe\x91\xfe\x91\xfe\x91\xfe\x91\xfe\x00\x00\x00\x00\x00\x00\x91\xfe\x91\xfe\x91\xfe\x91\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x91\xfe\x91\xfe\x00\x00\x00\x00\x91\xfe\x91\xfe\x91\xfe\x00\x00\x91\xfe\x91\xfe\x00\x00\x91\xfe\x91\xfe\x91\xfe\x91\xfe\x91\xfe\x91\xfe\x91\xfe\x91\xfe\x91\xfe\x91\xfe\x91\xfe\x91\xfe\x91\xfe\x91\xfe\x00\x00\x91\xfe\x91\xfe\x91\xfe\x00\x00\x00\x00\x91\xfe\x91\xfe\x91\xfe\x91\xfe\x91\xfe\x91\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\x91\xfe\x91\xfe\x91\xfe\x91\xfe\x91\xfe\x91\xfe\x00\x00\x00\x00\x91\xfe\x91\xfe\xfb\x01\xfc\x01\x00\x00\x92\xfe\x91\xfe\x91\xfe\x91\xfe\x91\xfe\x91\xfe\x91\xfe\x91\xfe\x91\xfe\x91\xfe\x91\xfe\x00\x00\x00\x00\x91\xfe\xfd\x01\x00\x00\x91\xfe\x00\x00\x91\xfe\x91\xfe\x91\xfe\x91\xfe\x91\xfe\x91\xfe\x91\xfe\x91\xfe\x91\xfe\x91\xfe\x91\xfe\x91\xfe\x91\xfe\x91\xfe\x91\xfe\x91\xfe\x91\xfe\x91\xfe\x91\xfe\x91\xfe\x91\xfe\x91\xfe\x91\xfe\x91\xfe\x91\xfe\x91\xfe\x91\xfe\x91\xfe\x91\xfe\x91\xfe\x91\xfe\x91\xfe\x91\xfe\x91\xfe\x91\xfe\x91\xfe\x91\xfe\x91\xfe\x91\xfe\x91\xfe\x91\xfe\x91\xfe\x91\xfe\x91\xfe\x91\xfe\x91\xfe\x91\xfe\x91\xfe\x0e\xfe\x0e\xfe\x0e\xfe\x0e\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x0e\xfe\x0e\xfe\x0e\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0e\xfe\x00\x00\x00\x00\x0e\xfe\x0e\xfe\x0e\xfe\x00\x00\x0e\xfe\x0e\xfe\x00\x00\x0e\xfe\x0e\xfe\x0e\xfe\x0e\xfe\x0e\xfe\x0e\xfe\x0e\xfe\x0e\xfe\x0e\xfe\x0e\xfe\x0e\xfe\x0e\xfe\x0e\xfe\x0e\xfe\x00\x00\x0e\xfe\x0e\xfe\x0e\xfe\x00\x00\x00\x00\x0e\xfe\x0e\xfe\x0e\xfe\x0e\xfe\x0e\xfe\x0e\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\x0e\xfe\x0e\xfe\x81\x00\xbd\x01\x0e\xfe\x0e\xfe\x00\x00\x00\x00\x0e\xfe\x0e\xfe\x0e\xfe\x00\x00\x00\x00\x00\x00\x83\x00\x0e\xfe\x0e\xfe\x0e\xfe\x84\x00\xbe\x01\xbf\x01\xc0\x01\xc1\x01\x85\x00\x00\x00\x00\x00\x0e\xfe\x00\x00\x00\x00\x0e\xfe\x00\x00\x0e\xfe\x0e\xfe\x0e\xfe\x0e\xfe\x0e\xfe\x0e\xfe\x0e\xfe\x0e\xfe\x0e\xfe\x0e\xfe\x0e\xfe\x49\x01\x0e\xfe\x0e\xfe\x0e\xfe\x8b\x00\x8c\x00\x0e\xfe\x0e\xfe\x8e\x00\x8f\x00\x0e\xfe\x0e\xfe\x0e\xfe\x0e\xfe\x0e\xfe\x0e\xfe\x0e\xfe\x0e\xfe\x0e\xfe\x0e\xfe\x0e\xfe\x0e\xfe\x0e\xfe\x0e\xfe\x0e\xfe\x0e\xfe\x0e\xfe\x0e\xfe\x0e\xfe\x0e\xfe\x0e\xfe\x0e\xfe\x0e\xfe\x0e\xfe\x0e\xfe\x0e\xfe\x0e\xfe\x07\xfe\xa5\x00\x13\x00\xa6\x00\x00\x00\x00\x00\x00\x00\x00\x00\x07\xfe\x14\x00\xa7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd4\x00\x00\x00\x00\x00\x07\xfe\x15\x00\x07\xfe\x00\x00\x07\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\xa9\x00\x00\x00\x24\x00\x07\xfe\x07\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x07\xfe\x07\xfe\x07\xfe\x07\xfe\x07\xfe\xad\x00\x00\x00\x00\x00\x07\xfe\x07\xfe\x07\xfe\x00\x00\x00\x00\x00\x00\x07\xfe\xaf\x00\xb0\x00\xb1\x00\x07\xfe\x07\xfe\x07\xfe\x07\xfe\x07\xfe\x07\xfe\x00\x00\x00\x00\xbb\x01\x00\x00\x00\x00\x07\xfe\x00\x00\x07\xfe\xb2\x00\x07\xfe\xb3\x00\x07\xfe\xb4\x00\x07\xfe\xb5\x00\x07\xfe\x07\xfe\x07\xfe\x07\xfe\xb6\x00\x2c\x00\x8a\x00\x07\xfe\x07\xfe\x2d\x00\x8d\x00\x07\xfe\x07\xfe\xb7\x00\xb8\x00\x6a\x00\xb9\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\x07\xfe\xc8\x00\x07\xfe\x6e\x00\xc9\x00\xca\x00\x6f\x00\x70\x00\x07\xfe\x08\xfe\xa5\x00\x13\x00\xa6\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\xfe\x14\x00\xa7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd4\x00\x00\x00\x00\x00\x08\xfe\x15\x00\x08\xfe\x00\x00\x08\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\xa9\x00\x00\x00\x24\x00\x08\xfe\x08\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\xfe\x08\xfe\x08\xfe\x08\xfe\x08\xfe\xad\x00\x00\x00\x00\x00\x08\xfe\x08\xfe\x08\xfe\x00\x00\x00\x00\x00\x00\x08\xfe\xaf\x00\xb0\x00\xb1\x00\x08\xfe\x08\xfe\x08\xfe\x08\xfe\x08\xfe\x08\xfe\x00\x00\x00\x00\xbb\x01\x00\x00\x00\x00\x08\xfe\x00\x00\x08\xfe\xb2\x00\x08\xfe\xb3\x00\x08\xfe\xb4\x00\x08\xfe\xb5\x00\x08\xfe\x08\xfe\x08\xfe\x08\xfe\xb6\x00\x2c\x00\x8a\x00\x08\xfe\x08\xfe\x2d\x00\x8d\x00\x08\xfe\x08\xfe\xb7\x00\xb8\x00\x6a\x00\xb9\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\x08\xfe\xc8\x00\x08\xfe\x6e\x00\xc9\x00\xca\x00\x6f\x00\x70\x00\x08\xfe\x14\x02\xa5\x00\x13\x00\xa6\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\xa7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd4\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\xa9\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\xab\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\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\xad\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x15\x02\xb2\x00\x00\x00\xb3\x00\x00\x00\xb4\x00\x00\x00\xb5\x00\x00\x00\xae\x03\x00\x00\x00\x00\xb6\x00\x2c\x00\x8a\x00\x00\x00\x00\x00\x2d\x00\x8d\x00\x00\x00\x00\x00\xb7\x00\xb8\x00\x6a\x00\xb9\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\x00\x00\xc8\x00\x00\x00\x6e\x00\xc9\x00\xca\x00\x6f\x00\x70\x00\x14\x02\xa5\x00\x13\x00\xa6\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\xa7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd4\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\xa9\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\xad\x00\x00\x00\x00\x00\x93\xfd\x00\x00\x93\xfd\x00\x00\x00\x00\x00\x00\x00\x00\xaf\x00\xb0\x00\xb1\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x15\x02\xb2\x00\x00\x00\xb3\x00\x00\x00\xb4\x00\x00\x00\xb5\x00\x00\x00\xb6\x03\x00\x00\x00\x00\xb6\x00\x2c\x00\x8a\x00\x00\x00\x00\x00\x2d\x00\x8d\x00\x00\x00\x00\x00\xb7\x00\xb8\x00\x6a\x00\xb9\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\x00\x00\xc8\x00\x00\x00\x6e\x00\xc9\x00\xca\x00\x6f\x00\x70\x00\x7d\xfe\x7d\xfe\x7d\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7d\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7d\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7d\xfe\x7d\xfe\x7d\xfe\x7d\xfe\x7d\xfe\x7d\xfe\x00\x00\x00\x00\x7d\xfe\x7d\xfe\x7d\xfe\x7d\xfe\x7d\xfe\x00\x00\x00\x00\x7d\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x7d\xfe\x7d\xfe\x7d\xfe\x7d\xfe\x7d\xfe\x7d\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7d\xfe\x7d\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7d\xfe\x7d\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x58\xfe\x00\x00\x7d\xfe\x7d\xfe\x00\x00\x7d\xfe\x7d\xfe\x7d\xfe\x7d\xfe\x00\x00\x7d\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x7d\xfe\x00\x00\x00\x00\x7d\xfe\x7d\xfe\x7d\xfe\x7d\xfe\x00\x00\x7d\xfe\x7d\xfe\x00\x00\x7d\xfe\x00\x00\x7d\xfe\x00\x00\x00\x00\x00\x00\x7d\xfe\x00\x00\x7d\xfe\x7d\xfe\x7d\xfe\x7d\xfe\x7d\xfe\x7d\xfe\x00\x00\x7d\xfe\x7d\xfe\x7d\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x7d\xfe\x7d\xfe\x7d\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa5\x00\x13\x00\xa6\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\x7d\xfe\x14\x00\xa7\x00\x7d\xfe\x7d\xfe\xd1\x00\xd2\x00\xd3\x00\xf3\x00\xd4\x00\x00\x00\xf4\x00\x00\x00\x15\x00\x00\x00\xf5\x00\x00\x00\x16\x00\xf6\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xa9\x00\x00\x00\x24\x00\x00\x00\x00\x00\xf7\x00\xab\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\x00\x00\xf8\x00\xda\x00\xf9\x00\xfa\x00\x00\x00\x00\x00\xfb\x00\xdb\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xdc\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\xae\x00\xaf\x00\xb0\x00\xb1\x00\x00\x00\x00\x00\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\xdd\x00\x00\x00\xb4\x00\x00\x00\xb5\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb6\x00\x2c\x00\x8a\x00\x00\x00\x00\x00\x2d\x00\x8d\x00\x00\x00\x00\x00\xb7\x00\xb8\x00\x6a\x00\xb9\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\x00\x00\xc8\x00\x00\x00\x6e\x00\xc9\x00\xca\x00\x6f\x00\x70\x00\xf6\xfc\xf6\xfc\xf6\xfc\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf6\xfc\xf6\xfc\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf6\xfc\x00\x00\x00\x00\x00\x00\xf6\xfc\x00\x00\x00\x00\x00\x00\xf6\xfc\x00\x00\xf6\xfc\xf6\xfc\xf6\xfc\xf6\xfc\xf6\xfc\xf6\xfc\xf6\xfc\xf6\xfc\xf6\xfc\xf6\xfc\xf6\xfc\xf6\xfc\xf6\xfc\xf6\xfc\x00\x00\xf6\xfc\xb0\x04\xb1\x04\x00\x00\x00\x00\xf6\xfc\xf6\xfc\xf6\xfc\xf6\xfc\xf6\xfc\xf6\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\xf6\xfc\xf6\xfc\x00\x00\xf6\xfc\x00\x00\x00\x00\xf6\xfc\x00\x00\x00\x00\x00\x00\xf6\xfc\x00\x00\xf6\xfc\xf6\xfc\xf6\xfc\xf6\xfc\xf6\xfc\xf6\xfc\xf6\xfc\xf6\xfc\xf6\xfc\xf6\xfc\x00\x00\xf6\xfc\xf6\xfc\x00\x00\xf6\xfc\x00\x00\x00\x00\x00\x00\xf6\xfc\xf6\xfc\xf6\xfc\x00\x00\xf6\xfc\x00\x00\xf6\xfc\x00\x00\x00\x00\xf6\xfc\xf6\xfc\xf6\xfc\xf6\xfc\xf6\xfc\xf6\xfc\xf6\xfc\xf6\xfc\xf6\xfc\xf6\xfc\xf6\xfc\xf6\xfc\xf6\xfc\xf6\xfc\xf6\xfc\xf6\xfc\xf6\xfc\xf6\xfc\xf6\xfc\xf6\xfc\xf6\xfc\xf6\xfc\xf6\xfc\xf6\xfc\xf6\xfc\xf6\xfc\xf6\xfc\xf6\xfc\xf6\xfc\x00\x00\xf6\xfc\x00\x00\xf6\xfc\xf6\xfc\xf6\xfc\xf6\xfc\xf6\xfc\xa5\x00\x13\x00\xa6\x00\x00\x00\x8f\x04\x90\x04\x00\x00\x00\x00\x14\x00\xa7\x00\x00\x00\x00\x00\xd1\x00\xd2\x00\xd3\x00\x00\x00\xd4\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x91\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\xa9\x00\x00\x00\x24\x00\x00\x00\x00\x00\xf7\x00\xab\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\x00\x00\x00\x00\xda\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xdb\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xdc\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\xae\x00\xaf\x00\xb0\x00\xb1\x00\x00\x00\x00\x00\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\xdd\x00\x00\x00\xb4\x00\x00\x00\xb5\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb6\x00\x2c\x00\x8a\x00\x00\x00\x00\x00\x2d\x00\x8d\x00\x00\x00\x00\x00\xb7\x00\xb8\x00\x6a\x00\xb9\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\x00\x00\xc8\x00\x00\x00\x6e\x00\xc9\x00\xca\x00\x6f\x00\x70\x00\xa5\x00\x13\x00\xa6\x00\x00\x00\x85\x04\x00\x00\x00\x00\x00\x00\x14\x00\xa7\x00\x00\x00\x00\x00\xd1\x00\xd2\x00\xd3\x00\x00\x00\xd4\x00\x00\x00\x86\x04\x00\x00\x15\x00\x00\x00\x87\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\xa9\x00\x00\x00\x24\x00\x00\x00\x00\x00\xf7\x00\xab\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\x00\x00\x00\x00\xda\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xdb\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xdc\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\xae\x00\xaf\x00\xb0\x00\xb1\x00\x00\x00\x00\x00\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\xdd\x00\x00\x00\xb4\x00\x00\x00\xb5\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb6\x00\x2c\x00\x8a\x00\x00\x00\x00\x00\x2d\x00\x8d\x00\x00\x00\x00\x00\xb7\x00\xb8\x00\x6a\x00\xb9\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\x00\x00\xc8\x00\x00\x00\x6e\x00\xc9\x00\xca\x00\x6f\x00\x70\x00\xa5\x00\x13\x00\xa6\x00\x00\x00\x8f\x04\x90\x04\x00\x00\x00\x00\x14\x00\xa7\x00\x00\x00\x00\x00\xd1\x00\xd2\x00\xd3\x00\x00\x00\xd4\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x91\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\xa9\x00\x00\x00\x24\x00\x00\x00\x00\x00\xf7\x00\xab\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\x00\x00\x00\x00\xda\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xdb\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xdc\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\xae\x00\xaf\x00\xb0\x00\xb1\x00\x00\x00\x00\x00\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\xdd\x00\x00\x00\xb4\x00\x00\x00\xb5\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb6\x00\x2c\x00\x8a\x00\x00\x00\x00\x00\x2d\x00\x8d\x00\x00\x00\x00\x00\xb7\x00\xb8\x00\x6a\x00\xb9\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\x00\x00\xc8\x00\x00\x00\x6e\x00\xc9\x00\xca\x00\x6f\x00\x70\x00\xa5\x00\x13\x00\xa6\x00\x00\x00\x85\x04\x00\x00\x00\x00\x00\x00\x14\x00\xa7\x00\x00\x00\x00\x00\xd1\x00\xd2\x00\xd3\x00\x00\x00\xd4\x00\x00\x00\x86\x04\x00\x00\x15\x00\x00\x00\x87\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\xa9\x00\x00\x00\x24\x00\x00\x00\x00\x00\xf7\x00\xab\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\x00\x00\x00\x00\xda\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xdb\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xdc\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\xae\x00\xaf\x00\xb0\x00\xb1\x00\x00\x00\x00\x00\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\xdd\x00\x00\x00\xb4\x00\x00\x00\xb5\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb6\x00\x2c\x00\x8a\x00\x00\x00\x00\x00\x2d\x00\x8d\x00\x00\x00\x00\x00\xb7\x00\xb8\x00\x6a\x00\xb9\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\x00\x00\xc8\x00\x00\x00\x6e\x00\xc9\x00\xca\x00\x6f\x00\x70\x00\xa5\x00\x13\x00\xa6\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\xa7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd4\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\xa9\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\xab\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\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\x81\x00\x00\x00\x00\x00\xad\x00\x00\x00\x00\x00\x5d\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5e\x01\xaf\x00\xb0\x00\xb1\x00\x84\x00\x00\x00\x00\x00\x00\x00\x00\x00\x85\x00\x5f\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb2\x00\x00\x00\xb3\x00\x60\x01\xb4\x00\x00\x00\xb5\x00\x00\x00\x00\x00\x61\x01\x62\x01\xb6\x00\x2c\x00\x8a\x00\x8b\x00\x8c\x00\x2d\x00\x8d\x00\x8e\x00\x8f\x00\xb7\x00\xb8\x00\x6a\x00\xb9\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\x00\x00\xc8\x00\x00\x00\x6e\x00\xc9\x00\xca\x00\x6f\x00\x70\x00\xde\xfd\xde\xfd\xde\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xde\xfd\xde\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xde\xfd\x00\x00\x00\x00\x00\x00\xde\xfd\x00\x00\x00\x00\x00\x00\xde\xfd\x00\x00\xde\xfd\xde\xfd\xde\xfd\xde\xfd\xde\xfd\xde\xfd\xde\xfd\xde\xfd\xde\xfd\xde\xfd\xde\xfd\xde\xfd\xde\xfd\xde\xfd\x00\x00\xde\xfd\x00\x00\x00\x00\x00\x00\x00\x00\xde\xfd\xde\xfd\xde\xfd\xde\xfd\xde\xfd\xde\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\xde\xfd\xde\xfd\xde\xfd\xde\xfd\x00\x00\x00\x00\xde\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xde\xfd\xde\xfd\xde\xfd\xde\xfd\xde\xfd\x00\x00\x00\x00\x00\x00\x00\x00\xde\xfd\x00\x00\xde\xfd\xde\xfd\x00\x00\xde\xfd\x00\x00\x00\x00\x00\x00\xde\xfd\x00\x00\xde\xfd\x00\x00\xde\xfd\x00\x00\xde\xfd\x00\x00\x00\x00\x00\x00\xde\xfd\xde\xfd\xde\xfd\xde\xfd\xde\xfd\xde\xfd\xde\xfd\xde\xfd\xde\xfd\xde\xfd\xde\xfd\xde\xfd\xde\xfd\xde\xfd\xde\xfd\xde\xfd\xde\xfd\xde\xfd\xde\xfd\xde\xfd\xde\xfd\xde\xfd\xde\xfd\xde\xfd\xde\xfd\xde\xfd\xde\xfd\xde\xfd\x00\x00\xde\xfd\x00\x00\xde\xfd\xde\xfd\xde\xfd\xde\xfd\xde\xfd\xdd\xfd\xdd\xfd\xdd\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xdd\xfd\xdd\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xdd\xfd\x00\x00\x00\x00\x00\x00\xdd\xfd\x00\x00\x00\x00\x00\x00\xdd\xfd\x00\x00\xdd\xfd\xdd\xfd\xdd\xfd\xdd\xfd\xdd\xfd\xdd\xfd\xdd\xfd\xdd\xfd\xdd\xfd\xdd\xfd\xdd\xfd\xdd\xfd\xdd\xfd\xdd\xfd\x00\x00\xdd\xfd\x00\x00\x00\x00\x00\x00\x00\x00\xdd\xfd\xdd\xfd\xdd\xfd\xdd\xfd\xdd\xfd\xdd\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\xdd\xfd\xdd\xfd\xdd\xfd\xdd\xfd\x00\x00\x00\x00\xdd\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xdd\xfd\xdd\xfd\xdd\xfd\xdd\xfd\xdd\xfd\x00\x00\x00\x00\x00\x00\x00\x00\xdd\xfd\x00\x00\xdd\xfd\xdd\xfd\x00\x00\xdd\xfd\x00\x00\x00\x00\x00\x00\xdd\xfd\x00\x00\xdd\xfd\x00\x00\xdd\xfd\x00\x00\xdd\xfd\x00\x00\x00\x00\x00\x00\xdd\xfd\xdd\xfd\xdd\xfd\xdd\xfd\xdd\xfd\xdd\xfd\xdd\xfd\xdd\xfd\xdd\xfd\xdd\xfd\xdd\xfd\xdd\xfd\xdd\xfd\xdd\xfd\xdd\xfd\xdd\xfd\xdd\xfd\xdd\xfd\xdd\xfd\xdd\xfd\xdd\xfd\xdd\xfd\xdd\xfd\xdd\xfd\xdd\xfd\xdd\xfd\xdd\xfd\xdd\xfd\x00\x00\xdd\xfd\x00\x00\xdd\xfd\xdd\xfd\xdd\xfd\xdd\xfd\xdd\xfd\xea\xfd\xea\xfd\xea\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xea\xfd\xea\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xea\xfd\x00\x00\x00\x00\x00\x00\xea\xfd\x00\x00\x00\x00\x00\x00\xea\xfd\x00\x00\xea\xfd\xea\xfd\xea\xfd\xea\xfd\xea\xfd\xea\xfd\xea\xfd\xea\xfd\xea\xfd\xea\xfd\xea\xfd\xea\xfd\xea\xfd\xea\xfd\x00\x00\xea\xfd\x00\x00\x00\x00\x00\x00\x00\x00\xea\xfd\xea\xfd\xea\xfd\xea\xfd\xea\xfd\xea\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\xea\xfd\xea\xfd\x8d\x03\xea\xfd\x00\x00\x00\x00\xea\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xea\xfd\xea\xfd\xea\xfd\xea\xfd\xea\xfd\x00\x00\x00\x00\x00\x00\x00\x00\xea\xfd\x00\x00\xea\xfd\xea\xfd\x00\x00\xea\xfd\x00\x00\x00\x00\x00\x00\xea\xfd\x00\x00\xea\xfd\x00\x00\xea\xfd\x00\x00\xea\xfd\x00\x00\x00\x00\x00\x00\xea\xfd\xea\xfd\xea\xfd\xea\xfd\xea\xfd\xea\xfd\xea\xfd\xea\xfd\xea\xfd\xea\xfd\xea\xfd\xea\xfd\xea\xfd\xea\xfd\xea\xfd\xea\xfd\xea\xfd\xea\xfd\xea\xfd\xea\xfd\xea\xfd\xea\xfd\xea\xfd\xea\xfd\xea\xfd\xea\xfd\xea\xfd\xea\xfd\x00\x00\xea\xfd\x00\x00\xea\xfd\xea\xfd\xea\xfd\xea\xfd\xea\xfd\xa5\x00\x13\x00\xa6\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\xa7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd4\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\xa9\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\xab\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\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\x81\x00\x00\x00\x00\x00\xad\x00\x00\x00\x00\x00\x5d\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\x84\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\xb2\x00\x00\x00\xb3\x00\x00\x00\xb4\x00\x9a\x01\xb5\x00\x00\x00\x00\x00\x61\x01\x62\x01\xb6\x00\x2c\x00\x8a\x00\x8b\x00\x8c\x00\x2d\x00\x8d\x00\x8e\x00\x8f\x00\xb7\x00\xb8\x00\x6a\x00\xb9\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\x00\x00\xc8\x00\x00\x00\x6e\x00\xc9\x00\xca\x00\x6f\x00\x70\x00\xa5\x00\x13\x00\xa6\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\xa7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd4\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\xa9\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\xab\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\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\x81\x00\x00\x00\x00\x00\xad\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\x84\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\xb2\x00\x00\x00\xb3\x00\xb8\xfd\xb4\x00\xb8\xfd\xb5\x00\x00\x00\x00\x00\x38\x02\x62\x01\xb6\x00\x2c\x00\x8a\x00\x8b\x00\x8c\x00\x2d\x00\x8d\x00\x8e\x00\x8f\x00\xb7\x00\xb8\x00\x6a\x00\xb9\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\x00\x00\xc8\x00\x00\x00\x6e\x00\xc9\x00\xca\x00\x6f\x00\x70\x00\xa5\x00\x13\x00\xa6\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\xa7\x00\x00\x00\x00\x00\xd1\x00\xd2\x00\xd3\x00\x00\x00\xd4\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\xa9\x00\x00\x00\x24\x00\x00\x00\x00\x00\xd5\x00\xab\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\x00\x00\x00\x00\xda\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xdb\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xdc\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\xae\x00\xaf\x00\xb0\x00\xb1\x00\x00\x00\x00\x00\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\xdd\x00\x00\x00\xb4\x00\x00\x00\xb5\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb6\x00\x2c\x00\x8a\x00\x00\x00\x00\x00\x2d\x00\x8d\x00\x00\x00\x00\x00\xb7\x00\xb8\x00\x6a\x00\xb9\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\x00\x00\xc8\x00\x00\x00\x6e\x00\xc9\x00\xca\x00\x6f\x00\x70\x00\xa5\x00\x13\x00\xa6\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\xa7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd4\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\xa9\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\xab\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\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\x81\x00\x00\x00\x00\x00\xad\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\x84\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\xb2\x00\x00\x00\xb3\x00\x52\x02\xb4\x00\x00\x00\xb5\x00\x00\x00\x00\x00\x38\x02\x62\x01\xb6\x00\x2c\x00\x8a\x00\x8b\x00\x8c\x00\x2d\x00\x8d\x00\x8e\x00\x8f\x00\xb7\x00\xb8\x00\x6a\x00\xb9\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\x00\x00\xc8\x00\x00\x00\x6e\x00\xc9\x00\xca\x00\x6f\x00\x70\x00\xa5\x00\x13\x00\xa6\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\xa7\x00\x00\x00\x00\x00\xd1\x00\xd2\x00\xd3\x00\x00\x00\xd4\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\xa9\x00\x00\x00\x24\x00\x00\x00\x00\x00\xf7\x00\xab\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\x00\x00\x00\x00\xda\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xdb\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xdc\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\xae\x00\xaf\x00\xb0\x00\xb1\x00\x00\x00\x00\x00\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\xdd\x00\x00\x00\xb4\x00\x00\x00\xb5\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb6\x00\x2c\x00\x8a\x00\x00\x00\x00\x00\x2d\x00\x8d\x00\x00\x00\x00\x00\xb7\x00\xb8\x00\x6a\x00\xb9\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\x00\x00\xc8\x00\x00\x00\x6e\x00\xc9\x00\xca\x00\x6f\x00\x70\x00\xa5\x00\x13\x00\xa6\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\xa7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd4\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\xa9\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\xab\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\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\x81\x00\x00\x00\x00\x00\xad\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\x84\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\xb2\x00\x00\x00\xb3\x00\x00\x00\xb4\x00\x55\x02\xb5\x00\x00\x00\x00\x00\x38\x02\x62\x01\xb6\x00\x2c\x00\x8a\x00\x8b\x00\x8c\x00\x2d\x00\x8d\x00\x8e\x00\x8f\x00\xb7\x00\xb8\x00\x6a\x00\xb9\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\x00\x00\xc8\x00\x00\x00\x6e\x00\xc9\x00\xca\x00\x6f\x00\x70\x00\xa5\x00\x13\x00\xa6\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\xa7\x00\x00\x00\x00\x00\xd1\x00\xd2\x00\xd3\x00\x00\x00\xd4\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\xa9\x00\x00\x00\x24\x00\x00\x00\x00\x00\xf7\x00\xab\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\x00\x00\x00\x00\xda\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xdb\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xdc\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\xae\x00\xaf\x00\xb0\x00\xb1\x00\x00\x00\x00\x00\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\xdd\x00\x00\x00\xb4\x00\x00\x00\xb5\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb6\x00\x2c\x00\x8a\x00\x00\x00\x00\x00\x2d\x00\x8d\x00\x00\x00\x00\x00\xb7\x00\xb8\x00\x6a\x00\xb9\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\x00\x00\xc8\x00\x00\x00\x6e\x00\xc9\x00\xca\x00\x6f\x00\x70\x00\xa5\x00\x13\x00\xa6\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\xa7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd4\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\xa9\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\xab\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\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\x81\x00\x00\x00\x00\x00\xad\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\x84\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\xb2\x00\x9f\x01\xb3\x00\x00\x00\xb4\x00\x00\x00\xb5\x00\x00\x00\x00\x00\x00\x00\x62\x01\xb6\x00\x2c\x00\x8a\x00\x8b\x00\x8c\x00\x2d\x00\x8d\x00\x8e\x00\x8f\x00\xb7\x00\xb8\x00\x6a\x00\xb9\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\x00\x00\xc8\x00\x00\x00\x6e\x00\xc9\x00\xca\x00\x6f\x00\x70\x00\xa5\x00\x13\x00\xa6\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\xa7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd4\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\xa9\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\xab\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\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\x81\x00\x00\x00\x00\x00\xad\x00\x00\x00\x00\x00\x3c\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\x84\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\xb2\x00\x00\x00\xb3\x00\x00\x00\xb4\x00\x00\x00\xb5\x00\x00\x00\x00\x00\x00\x00\x62\x01\xb6\x00\x2c\x00\x8a\x00\x8b\x00\x8c\x00\x2d\x00\x8d\x00\x8e\x00\x8f\x00\xb7\x00\xb8\x00\x6a\x00\xb9\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\x00\x00\xc8\x00\x00\x00\x6e\x00\xc9\x00\xca\x00\x6f\x00\x70\x00\xa5\x00\x13\x00\xa6\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\xa7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd4\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\xa9\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\xab\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\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\x81\x00\x00\x00\x00\x00\xad\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\x84\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\xb2\x00\x00\x00\xb3\x00\x00\x00\xb4\x00\x00\x00\xb5\x00\x00\x00\x00\x00\x00\x00\x62\x01\xb6\x00\x2c\x00\x8a\x00\x8b\x00\x8c\x00\x2d\x00\x8d\x00\x8e\x00\x8f\x00\xb7\x00\xb8\x00\x6a\x00\xb9\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\x00\x00\xc8\x00\x00\x00\x6e\x00\xc9\x00\xca\x00\x6f\x00\x70\x00\xa5\x00\x13\x00\xa6\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\xa7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd4\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\xa9\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\xab\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\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\xad\x00\x00\x00\x00\x00\xb3\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb4\x01\x00\x00\x00\x00\x00\x00\xb2\x00\x00\x00\xb3\x00\x00\x00\xb4\x00\x00\x00\xb5\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb6\x00\x2c\x00\x8a\x00\x00\x00\x00\x00\x2d\x00\x8d\x00\x00\x00\x00\x00\xb7\x00\xb8\x00\x6a\x00\xb9\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\x00\x00\xc8\x00\x00\x00\x6e\x00\xc9\x00\xca\x00\x6f\x00\x70\x00\xa5\x00\x13\x00\xa6\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\xa7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd4\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\xa9\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\xab\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\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\xad\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb0\x03\x00\x00\x00\x00\xb2\x00\x00\x00\xb3\x00\x00\x00\xb4\x00\x00\x00\xb5\x00\x00\x00\xae\x03\x00\x00\x00\x00\xb6\x00\x2c\x00\x8a\x00\x00\x00\x00\x00\x2d\x00\x8d\x00\x00\x00\x00\x00\xb7\x00\xb8\x00\x6a\x00\xb9\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\x00\x00\xc8\x00\x00\x00\x6e\x00\xc9\x00\xca\x00\x6f\x00\x70\x00\xa5\x00\x13\x00\xa6\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\xa7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa8\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\xa9\x00\xaa\x00\x24\x00\x00\x00\x00\x00\x00\x00\xab\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\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\xad\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\x00\x00\x00\x00\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\xb3\x00\x00\x00\xb4\x00\x00\x00\xb5\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb6\x00\x2c\x00\x8a\x00\x00\x00\x00\x00\x2d\x00\x8d\x00\x00\x00\x00\x00\xb7\x00\xb8\x00\x6a\x00\xb9\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\x00\x00\xc8\x00\x00\x00\x6e\x00\xc9\x00\xca\x00\x6f\x00\x70\x00\xa5\x00\x13\x00\xa6\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\xa7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa8\x00\x00\x00\x00\x00\x00\x00\x15\x00\xa4\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\xa9\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\xab\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\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\xad\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\x00\x00\x00\x00\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\xb3\x00\x00\x00\xb4\x00\x00\x00\xb5\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb6\x00\x2c\x00\x8a\x00\x00\x00\x00\x00\x2d\x00\x8d\x00\x00\x00\x00\x00\xb7\x00\xb8\x00\x6a\x00\xb9\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\x00\x00\xc8\x00\x00\x00\x6e\x00\xc9\x00\xca\x00\x6f\x00\x70\x00\xa5\x00\x13\x00\xa6\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\xa7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa8\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\xa9\x00\xaa\x00\x24\x00\x00\x00\x00\x00\x00\x00\xab\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\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\xad\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\x00\x00\x00\x00\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\xb3\x00\x00\x00\xb4\x00\x00\x00\xb5\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb6\x00\x2c\x00\x8a\x00\x00\x00\x00\x00\x2d\x00\x8d\x00\x00\x00\x00\x00\xb7\x00\xb8\x00\x6a\x00\xb9\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\x00\x00\xc8\x00\x00\x00\x6e\x00\xc9\x00\xca\x00\x6f\x00\x70\x00\xa5\x00\x13\x00\xa6\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\xa7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd4\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\xa9\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\xab\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\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\xad\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\x00\x00\x00\x00\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\xb3\x00\x00\x00\xb4\x00\x00\x00\xb5\x00\x00\x00\xae\x03\x00\x00\x00\x00\xb6\x00\x2c\x00\x8a\x00\x00\x00\x00\x00\x2d\x00\x8d\x00\x00\x00\x00\x00\xb7\x00\xb8\x00\x6a\x00\xb9\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\x00\x00\xc8\x00\x00\x00\x6e\x00\xc9\x00\xca\x00\x6f\x00\x70\x00\xa5\x00\x13\x00\xa6\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\xa7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa8\x00\x00\x00\x00\x00\x00\x00\x15\x00\xa4\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\xa9\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\xab\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\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\xad\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\x00\x00\x00\x00\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\xb3\x00\x00\x00\xb4\x00\x00\x00\xb5\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb6\x00\x2c\x00\x8a\x00\x00\x00\x00\x00\x2d\x00\x8d\x00\x00\x00\x00\x00\xb7\x00\xb8\x00\x6a\x00\xb9\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\x00\x00\xc8\x00\x00\x00\x6e\x00\xc9\x00\xca\x00\x6f\x00\x70\x00\xa5\x00\x13\x00\xa6\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\xa7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd4\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\xa9\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\xab\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\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\xad\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\x00\x00\x00\x00\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\xb3\x00\x00\x00\xb4\x00\x00\x00\xb5\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb6\x00\x2c\x00\x8a\x00\x00\x00\x00\x00\x2d\x00\x8d\x00\x00\x00\x00\x00\xb7\x00\xb8\x00\x6a\x00\xb9\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\x00\x00\xc8\x00\x00\x00\x6e\x00\xc9\x00\xca\x00\x6f\x00\x70\x00\xa5\x00\x13\x00\xa6\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\xa7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa8\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\xa9\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\xab\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\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\xad\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\x00\x00\x00\x00\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\xb3\x00\x00\x00\xb4\x00\x00\x00\xb5\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb6\x00\x2c\x00\x8a\x00\x00\x00\x00\x00\x2d\x00\x8d\x00\x00\x00\x00\x00\xb7\x00\xb8\x00\x6a\x00\xb9\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\x00\x00\xc8\x00\x00\x00\x6e\x00\xc9\x00\xca\x00\x6f\x00\x70\x00\xa5\x00\x13\x00\xa6\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\xa7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd4\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\xa9\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\xab\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\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\xad\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\x00\x00\x00\x00\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\xb3\x00\x00\x00\xb4\x00\x00\x00\xb5\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb6\x00\x2c\x00\x8a\x00\x00\x00\x00\x00\x2d\x00\x8d\x00\x00\x00\x00\x00\xb7\x00\xb8\x00\x6a\x00\xb9\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\x00\x00\xc8\x00\x00\x00\x6e\x00\xc9\x00\xca\x00\x6f\x00\x70\x00\xa5\x00\x13\x00\xa6\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\xa7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa8\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\xa9\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\xab\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\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\xad\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\x00\x00\x00\x00\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\xb3\x00\x00\x00\xb4\x00\x00\x00\xb5\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb6\x00\x2c\x00\x8a\x00\x00\x00\x00\x00\x2d\x00\x8d\x00\x00\x00\x00\x00\xb7\x00\xb8\x00\x6a\x00\xb9\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\x00\x00\xc8\x00\x00\x00\x6e\x00\xc9\x00\xca\x00\x6f\x00\x70\x00\xa5\x00\x13\x00\xa6\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\xa7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd4\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\xa9\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\xab\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\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\xad\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\x00\x00\x00\x00\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\xb3\x00\x00\x00\xb4\x00\x00\x00\xb5\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb6\x00\x2c\x00\x8a\x00\x00\x00\x00\x00\x2d\x00\x8d\x00\x00\x00\x00\x00\xb7\x00\xb8\x00\x6a\x00\xb9\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\x00\x00\xc8\x00\x00\x00\x6e\x00\xc9\x00\xca\x00\x6f\x00\x70\x00\xa5\x00\x13\x00\xa6\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\xa7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd4\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\xa9\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\xab\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\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\xad\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\x00\x00\x00\x00\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\xb3\x00\x00\x00\xb4\x00\x00\x00\xb5\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb6\x00\x2c\x00\x8a\x00\x00\x00\x00\x00\x2d\x00\x8d\x00\x00\x00\x00\x00\xb7\x00\xb8\x00\x6a\x00\xb9\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\x00\x00\xc8\x00\x00\x00\x6e\x00\xc9\x00\xca\x00\x6f\x00\x70\x00\xa5\x00\x13\x00\xa6\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\xa7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd4\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\xa9\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\xab\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\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\xad\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\x00\x00\x00\x00\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\xb3\x00\x00\x00\xb4\x00\x00\x00\xb5\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb6\x00\x2c\x00\x8a\x00\x00\x00\x00\x00\x2d\x00\x8d\x00\x00\x00\x00\x00\xb7\x00\xb8\x00\x6a\x00\xb9\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\x00\x00\xc8\x00\x00\x00\x6e\x00\xc9\x00\xca\x00\x6f\x00\x70\x00\xa5\x00\x13\x00\xa6\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\xa7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa8\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\xa9\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\xab\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\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\xad\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\x00\x00\x00\x00\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\xb3\x00\x00\x00\xb4\x00\x00\x00\xb5\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb6\x00\x2c\x00\x8a\x00\x00\x00\x00\x00\x2d\x00\x8d\x00\x00\x00\x00\x00\xb7\x00\xb8\x00\x6a\x00\xb9\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\x00\x00\xc8\x00\x00\x00\x6e\x00\xc9\x00\xca\x00\x6f\x00\x70\x00\xa5\x00\x13\x00\xa6\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\xa7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd4\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\xa9\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\xab\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\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\xad\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\x00\x00\x00\x00\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\xb3\x00\x00\x00\xb4\x00\x00\x00\xb5\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb6\x00\x2c\x00\x8a\x00\x00\x00\x00\x00\x2d\x00\x8d\x00\x00\x00\x00\x00\xb7\x00\xb8\x00\x6a\x00\xb9\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\x00\x00\xc8\x00\x00\x00\x6e\x00\xc9\x00\xca\x00\x6f\x00\x70\x00\xa5\x00\x13\x00\xa6\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\xa7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd4\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\xa9\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\xad\x00\xa7\x01\xa8\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xaf\x00\xb0\x00\xb1\x00\x00\x00\x00\x00\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\xb3\x00\x00\x00\xb4\x00\x00\x00\xb5\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb6\x00\x2c\x00\x8a\x00\x00\x00\x00\x00\x2d\x00\x8d\x00\x00\x00\x00\x00\xb7\x00\xb8\x00\x6a\x00\xb9\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\x00\x00\xc8\x00\x00\x00\x6e\x00\xc9\x00\xca\x00\x6f\x00\x70\x00\xa5\x00\x13\x00\xa6\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\xa7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd4\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\xa9\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\xab\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\xad\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\x00\x00\x00\x00\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\xb3\x00\x00\x00\xb4\x00\x00\x00\xb5\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb6\x00\x2c\x00\x8a\x00\x00\x00\x00\x00\x2d\x00\x8d\x00\x00\x00\x00\x00\xb7\x00\xb8\x00\x6a\x00\xb9\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\x00\x00\xc8\x00\x00\x00\x6e\x00\xc9\x00\xca\x00\x6f\x00\x70\x00\xd4\xfe\xd4\xfe\xd4\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd4\xfe\xd4\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd4\xfe\x00\x00\x00\x00\x00\x00\xd4\xfe\x00\x00\x00\x00\x00\x00\xd4\xfe\x00\x00\xd4\xfe\xd4\xfe\xd4\xfe\xd4\xfe\xd4\xfe\xd4\xfe\xd4\xfe\xd4\xfe\xd4\xfe\xd4\xfe\xd4\xfe\xd4\xfe\xd4\xfe\xd4\xfe\x00\x00\xd4\xfe\x00\x00\x00\x00\x00\x00\xd4\xfe\xd4\xfe\xd4\xfe\xd4\xfe\xd4\xfe\xd4\xfe\xd4\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\xd4\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd4\xfe\xd4\xfe\xd4\xfe\xd4\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\x09\x03\x00\x00\xd4\xfe\x00\x00\xd4\xfe\x00\x00\xd4\xfe\x00\x00\x00\x00\x00\x00\x00\x00\xd4\xfe\xd4\xfe\xd4\xfe\x00\x00\x00\x00\xd4\xfe\xd4\xfe\x00\x00\x00\x00\xd4\xfe\xd4\xfe\xd4\xfe\xd4\xfe\xd4\xfe\xd4\xfe\xd4\xfe\xd4\xfe\xd4\xfe\xd4\xfe\xd4\xfe\xd4\xfe\xd4\xfe\xd4\xfe\xd4\xfe\xd4\xfe\xd4\xfe\xd4\xfe\x00\x00\xd4\xfe\x00\x00\xd4\xfe\xd4\xfe\xd4\xfe\xd4\xfe\xd4\xfe\xa5\x00\x13\x00\xa6\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\xa7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd4\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\xa9\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\xab\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\xad\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\x00\x00\x00\x00\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\xb3\x00\x00\x00\xb4\x00\x00\x00\xb5\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb6\x00\x2c\x00\x8a\x00\x00\x00\x00\x00\x2d\x00\x8d\x00\x00\x00\x00\x00\xb7\x00\xb8\x00\x6a\x00\xb9\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\x00\x00\xc8\x00\x00\x00\x6e\x00\xc9\x00\xca\x00\x6f\x00\x70\x00\xa5\x00\x13\x00\xa6\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\xa7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd4\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\xa9\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\xad\x00\x00\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\xaf\x00\xb0\x00\xb1\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb8\x03\x00\x00\x00\x00\xb2\x00\x00\x00\xb3\x00\x00\x00\xb4\x00\x00\x00\xb5\x00\x00\x00\xb6\x03\x00\x00\x00\x00\xb6\x00\x2c\x00\x8a\x00\x00\x00\x00\x00\x2d\x00\x8d\x00\x00\x00\x00\x00\xb7\x00\xb8\x00\x6a\x00\xb9\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\x00\x00\xc8\x00\x00\x00\x6e\x00\xc9\x00\xca\x00\x6f\x00\x70\x00\xcb\xfe\xcb\xfe\xcb\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xcb\xfe\xcb\xfe\x1b\x02\x1c\x02\x78\x05\x00\x00\x00\x00\x00\x00\xcb\xfe\x00\x00\x00\x00\x00\x00\xcb\xfe\x00\x00\x00\x00\x1d\x02\x39\x03\x00\x00\xcb\xfe\xcb\xfe\xcb\xfe\xcb\xfe\xcb\xfe\xcb\xfe\xcb\xfe\xcb\xfe\xcb\xfe\xcb\xfe\xcb\xfe\xcb\xfe\xcb\xfe\xcb\xfe\x00\x00\xcb\xfe\x00\x00\x00\x00\x00\x00\xcb\xfe\xcb\xfe\xcb\xfe\xcb\xfe\xcb\xfe\xcb\xfe\xcb\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\xcb\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xcb\xfe\xcb\xfe\xcb\xfe\xcb\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\xcb\xfe\x00\x00\xcb\xfe\x00\x00\xcb\xfe\x00\x00\xcb\xfe\x00\x00\x00\x00\x00\x00\x00\x00\xcb\xfe\xcb\xfe\xcb\xfe\x00\x00\x00\x00\xcb\xfe\xcb\xfe\x00\x00\x00\x00\xcb\xfe\xcb\xfe\xcb\xfe\xcb\xfe\xcb\xfe\xcb\xfe\xcb\xfe\xcb\xfe\xcb\xfe\xcb\xfe\xcb\xfe\xcb\xfe\xcb\xfe\xcb\xfe\xcb\xfe\xcb\xfe\xcb\xfe\xcb\xfe\x00\x00\xcb\xfe\x00\x00\xcb\xfe\xcb\xfe\xcb\xfe\xcb\xfe\xcb\xfe\xa5\x00\x13\x00\xa6\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\xa7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd4\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\xa9\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\xab\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\xad\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\x00\x00\x00\x00\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\xb3\x00\x00\x00\xb4\x00\x00\x00\xb5\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb6\x00\x2c\x00\x8a\x00\x00\x00\x00\x00\x2d\x00\x8d\x00\x00\x00\x00\x00\xb7\x00\xb8\x00\x6a\x00\xb9\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\x00\x00\xc8\x00\x00\x00\x6e\x00\xc9\x00\xca\x00\x6f\x00\x70\x00\xa5\x00\x13\x00\xa6\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\xa7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd4\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\xa9\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\xad\x00\x00\x00\x00\x00\x93\xfd\x00\x00\x93\xfd\x00\x00\x00\x00\x00\x00\x00\x00\xaf\x00\xb0\x00\xb1\x00\x00\x00\x00\x00\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\xb3\x00\x00\x00\xb4\x00\x00\x00\xb5\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb6\x00\x2c\x00\x8a\x00\x00\x00\x00\x00\x2d\x00\x8d\x00\x00\x00\x00\x00\xb7\x00\xb8\x00\x6a\x00\xb9\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\x00\x00\xc8\x00\x00\x00\x6e\x00\xc9\x00\xca\x00\x6f\x00\x70\x00\xcc\xfe\xcc\xfe\xcc\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xcc\xfe\xcc\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xcc\xfe\x00\x00\x00\x00\x00\x00\xcc\xfe\x00\x00\x00\x00\x00\x00\xff\x04\x00\x00\xcc\xfe\xcc\xfe\xcc\xfe\xcc\xfe\xcc\xfe\xcc\xfe\xcc\xfe\xcc\xfe\xcc\xfe\xcc\xfe\xcc\xfe\xcc\xfe\xcc\xfe\xcc\xfe\x00\x00\xcc\xfe\x00\x00\x00\x00\x00\x00\xcc\xfe\xcc\xfe\xcc\xfe\xcc\xfe\xcc\xfe\xcc\xfe\xcc\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\xcc\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xcc\xfe\xcc\xfe\xcc\xfe\xcc\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\xcc\xfe\x00\x00\xcc\xfe\x00\x00\xcc\xfe\x00\x00\xcc\xfe\x00\x00\x00\x00\x00\x00\x00\x00\xcc\xfe\xcc\xfe\xcc\xfe\x00\x00\x00\x00\xcc\xfe\xcc\xfe\x00\x00\x00\x00\xcc\xfe\xcc\xfe\xcc\xfe\xcc\xfe\xcc\xfe\xcc\xfe\xcc\xfe\xcc\xfe\xcc\xfe\xcc\xfe\xcc\xfe\xcc\xfe\xcc\xfe\xcc\xfe\xcc\xfe\xcc\xfe\xcc\xfe\xcc\xfe\x00\x00\xcc\xfe\x00\x00\xcc\xfe\xcc\xfe\xcc\xfe\xcc\xfe\xcc\xfe\xa5\x00\x13\x00\xa6\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\xa7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd4\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\xa9\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\xab\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\xad\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\x00\x00\x00\x00\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\xb3\x00\x00\x00\xb4\x00\x00\x00\xb5\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb6\x00\x2c\x00\x8a\x00\x00\x00\x00\x00\x2d\x00\x8d\x00\x00\x00\x00\x00\xb7\x00\xb8\x00\x6a\x00\xb9\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\x00\x00\xc8\x00\x00\x00\x6e\x00\xc9\x00\xca\x00\x6f\x00\x70\x00\xa5\x00\x13\x00\xa6\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\xa7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd4\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\xa9\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\xab\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\xad\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xaf\x00\xb0\x00\xb1\x00\x00\x00\x00\x00\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\xb3\x00\x00\x00\xb4\x00\x00\x00\xb5\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb6\x00\x2c\x00\x8a\x00\x00\x00\x00\x00\x2d\x00\x8d\x00\x00\x00\x00\x00\xb7\x00\xb8\x00\x6a\x00\xb9\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\x00\x00\xc8\x00\x00\x00\x6e\x00\xc9\x00\xca\x00\x6f\x00\x70\x00\xa5\x00\x13\x00\xa6\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\xa7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd4\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\xa9\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\xad\x00\x00\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\xaf\x00\xb0\x00\xb1\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\xb2\x00\x00\x00\xb3\x00\x00\x00\xb4\x00\x00\x00\xb5\x00\x9a\x03\x00\x00\x00\x00\x00\x00\xb6\x00\x2c\x00\x8a\x00\x00\x00\x00\x00\x2d\x00\x8d\x00\x00\x00\x00\x00\xb7\x00\xb8\x00\x6a\x00\xb9\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\x00\x00\xc8\x00\x00\x00\x6e\x00\xc9\x00\xca\x00\x6f\x00\x70\x00\xa5\x00\x13\x00\xa6\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\xa7\x00\x1b\x02\x1c\x02\x00\x00\x00\x00\x00\x00\x00\x00\xd4\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x1d\x02\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\xa9\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\xad\x00\x00\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\xaf\x00\xb0\x00\xb1\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\xcd\x04\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb2\x00\x00\x00\xb3\x00\x00\x00\xb4\x00\x00\x00\xb5\x00\x00\x00\xb6\x03\x00\x00\x00\x00\xb6\x00\x2c\x00\x8a\x00\x00\x00\x00\x00\x2d\x00\x8d\x00\x00\x00\x00\x00\xb7\x00\xb8\x00\x6a\x00\xb9\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\x00\x00\xc8\x00\x00\x00\x6e\x00\xc9\x00\xca\x00\x6f\x00\x70\x00\xa5\x00\x13\x00\xa6\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\xa7\x00\x1b\x02\x1c\x02\x00\x00\x00\x00\x00\x00\x00\x00\xd4\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x1d\x02\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\xa9\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\xad\x00\x00\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\xaf\x00\xb0\x00\xb1\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\xb2\x00\x00\x00\xb3\x00\x00\x00\xb4\x00\x00\x00\xb5\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb6\x00\x2c\x00\x8a\x00\x00\x00\x00\x00\x2d\x00\x8d\x00\x00\x00\x00\x00\xb7\x00\xb8\x00\x6a\x00\xb9\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\x00\x00\xc8\x00\x00\x00\x6e\x00\xc9\x00\xca\x00\x6f\x00\x70\x00\x40\xfd\x40\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\xfd\x00\x00\x1b\x02\x1c\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\xfd\x00\x00\x00\x00\x1d\x02\x00\x00\x00\x00\x40\xfd\x40\xfd\x40\xfd\x40\xfd\x40\xfd\x40\xfd\x00\x00\x00\x00\x40\xfd\x40\xfd\x40\xfd\x40\xfd\x40\xfd\x00\x00\x00\x00\x40\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x40\xfd\x40\xfd\x40\xfd\x40\xfd\x40\xfd\x40\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\xfd\x40\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\xfd\x40\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\xfd\x40\xfd\x00\x00\x40\xfd\x40\xfd\x40\xfd\x40\xfd\x00\x00\x40\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x40\xfd\x00\x00\x00\x00\x40\xfd\x40\xfd\x40\xfd\x00\x00\x00\x00\x00\x00\x40\xfd\x00\x00\x40\xfd\x39\x02\x40\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x40\xfd\x40\xfd\x40\xfd\x40\xfd\x40\xfd\x40\xfd\x40\xfd\x00\x00\x40\xfd\x40\xfd\x40\xfd\x7d\xfe\x7d\xfe\x00\x00\x00\x00\x40\xfd\x40\xfd\x40\xfd\x00\x00\x7d\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7d\xfe\x40\xfd\x00\x00\x00\x00\x40\xfd\x40\xfd\x7d\xfe\x7d\xfe\x7d\xfe\x7d\xfe\x7d\xfe\x7d\xfe\x00\x00\x00\x00\x7d\xfe\x7d\xfe\x7d\xfe\x7d\xfe\x7d\xfe\x00\x00\x00\x00\x7d\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x7d\xfe\x7d\xfe\x7d\xfe\x7d\xfe\x7d\xfe\x7d\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7d\xfe\x7d\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7d\xfe\xd2\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7d\xfe\x7d\xfe\x00\x00\x7d\xfe\x7d\xfe\x7d\xfe\x7d\xfe\x00\x00\x7d\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x7d\xfe\x00\x00\x00\x00\x7d\xfe\x7d\xfe\x7d\xfe\x00\x00\x00\x00\x00\x00\x7d\xfe\x00\x00\x7d\xfe\x7d\xfe\x7d\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x7d\xfe\x7d\xfe\x7d\xfe\x7d\xfe\x7d\xfe\x7d\xfe\x7d\xfe\x00\x00\x7d\xfe\x7d\xfe\x7d\xfe\x00\x00\x00\x00\xa5\x00\x13\x00\x7d\xfe\x7d\xfe\x7d\xfe\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\x7d\xfe\x15\x00\x00\x00\x7d\xfe\x7d\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\x00\x00\x00\x00\xc9\x02\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\xb2\x00\x00\x00\xb3\x00\x00\x00\xb4\x00\x00\x00\xb5\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb6\x00\x2c\x00\x8a\x00\x00\x00\x00\x00\x2d\x00\x8d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6a\x00\xb9\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\x00\x00\xc8\x00\x00\x00\x6e\x00\xc9\x00\xca\x00\x6f\x00\x70\x00\x50\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x2c\x00\x8a\x00\x00\x00\x00\x00\x2d\x00\x8d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\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\xdf\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\xe0\x01\x60\x00\x00\x00\x00\x00\x00\x00\x00\x00\x61\x01\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x00\x00\x67\x00\x68\x00\x69\x00\x00\x00\x00\x00\x6a\x00\x00\x00\x6b\x00\x6c\x00\x6d\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\x6e\x00\x00\x00\x00\x00\x6f\x00\x70\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\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\x5d\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\xdb\x01\x00\x00\x00\x00\x00\x00\x61\x01\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x00\x00\x67\x00\x68\x00\x69\x00\x00\x00\x00\x00\x6a\x00\x00\x00\x6b\x00\x6c\x00\x6d\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\x6e\x00\x00\x00\x00\x00\x6f\x00\x70\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\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\xdf\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\xe0\x01\x60\x00\x00\x00\x00\x00\x00\x00\x00\x00\x61\x01\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x00\x00\x67\x00\x68\x00\x69\x00\x00\x00\x00\x00\x6a\x00\x00\x00\x6b\x00\x6c\x00\x6d\x00\x50\x00\x13\x00\x00\x00\x00\x00\x2f\x01\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x30\x01\x00\x00\x6f\x00\x70\x00\x00\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\x31\x01\x32\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\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\x00\x00\x67\x00\x68\x00\x69\x00\x00\x00\x00\x00\x50\x00\x13\x00\x6b\x00\x6c\x00\x6d\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\x6e\x00\x15\x00\x00\x00\x6f\x00\x70\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\x47\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x48\x02\x59\x00\x5a\x00\x00\x00\x49\x02\x00\x00\x00\x00\x00\x00\x00\x00\x4a\x02\x00\x00\x00\x00\x00\x00\x00\x00\x5d\x00\x00\x00\x00\x00\x00\x00\x5e\x00\x00\x00\x5f\x00\x60\x01\x60\x00\x00\x00\x00\x00\x00\x00\x00\x00\x61\x01\x61\x00\x62\x00\x63\x00\x64\x00\x4b\x02\x4c\x02\x00\x00\x67\x00\x68\x00\x4d\x02\x00\x00\x00\x00\x6a\x00\x00\x00\x6b\x00\x6c\x00\x6d\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\x6e\x00\x00\x00\x00\x00\x6f\x00\x70\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\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\xe2\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\x00\x00\x67\x00\x68\x00\x69\x00\x00\x00\x00\x00\x6a\x00\x00\x00\x6b\x00\x6c\x00\x6d\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\x6e\x00\xeb\x04\x00\x00\x6f\x00\x70\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\xf4\x02\x00\x00\x17\x00\x18\x00\x19\x00\x52\x00\x53\x00\x54\x00\xec\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\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\x00\x00\x67\x00\x68\x00\x69\x00\x00\x00\x00\x00\x50\x00\x13\x00\x6b\x00\x6c\x00\x6d\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\x6e\x00\x15\x00\x00\x00\x6f\x00\x70\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\xdd\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\x00\x00\x67\x00\x68\x00\x69\x00\x00\x00\x00\x00\x6a\x00\x00\x00\x6b\x00\x6c\x00\x6d\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\x6e\x00\x00\x00\x00\x00\x6f\x00\x70\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\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\x00\x00\x67\x00\x68\x00\x69\x00\x00\x00\x00\x00\x6a\x00\x00\x00\x6b\x00\x6c\x00\x6d\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\x6e\x00\x00\x00\x00\x00\x6f\x00\x70\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\xf4\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\x1f\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\x00\x00\x67\x00\x68\x00\x69\x00\x00\x00\x00\x00\x50\x00\x13\x00\x6b\x00\x6c\x00\x6d\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\x6e\x00\x15\x00\x00\x00\x6f\x00\x70\x00\xf4\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\x1d\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\x00\x00\x67\x00\x68\x00\x69\x00\x00\x00\x00\x00\x50\x00\x13\x00\x6b\x00\x6c\x00\x6d\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\x6e\x00\x15\x00\x00\x00\x6f\x00\x70\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\x00\x00\x67\x00\x68\x00\x69\x00\x00\x00\x00\x00\x6a\x00\x00\x00\x6b\x00\x6c\x00\x6d\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\x6e\x00\x00\x00\x00\x00\x6f\x00\x70\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\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\x4c\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\x00\x00\x67\x00\x68\x00\x69\x00\x00\x00\x00\x00\x6a\x00\x00\x00\x6b\x00\x6c\x00\x6d\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\x6e\x00\x00\x00\x00\x00\x6f\x00\x70\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\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\x00\x00\x67\x00\x68\x00\x69\x00\x00\x00\x00\x00\x6a\x00\x00\x00\x6b\x00\x6c\x00\x6d\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\x6e\x00\x00\x00\x00\x00\x6f\x00\x70\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\xf4\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\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\x00\x00\x67\x00\x68\x00\x69\x00\x00\x00\x00\x00\x50\x00\x13\x00\x6b\x00\x6c\x00\x6d\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\x6e\x00\x15\x00\x00\x00\x6f\x00\x70\x00\x6d\x03\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\x00\x00\x67\x00\x68\x00\x69\x00\x00\x00\x00\x00\x50\x00\x13\x00\x6b\x00\x6c\x00\x6d\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\x6e\x00\x15\x00\x00\x00\x6f\x00\x70\x00\xf4\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\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\x00\x00\x67\x00\x68\x00\x69\x00\x00\x00\x00\x00\x50\x00\x13\x00\x6b\x00\x6c\x00\x6d\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\x6e\x00\x15\x00\x00\x00\x6f\x00\x70\x00\x6d\x03\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\x00\x00\x67\x00\x68\x00\x69\x00\x00\x00\x00\x00\x50\x00\x13\x00\x6b\x00\x6c\x00\x6d\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\x6e\x00\x15\x00\x00\x00\x6f\x00\x70\x00\xf4\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\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\x00\x00\x67\x00\x68\x00\x69\x00\x50\x00\x13\x00\x00\x00\x00\x00\x6b\x00\x6c\x00\x6d\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\x6e\x00\x00\x00\x00\x00\x6f\x00\x70\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\x00\x00\x67\x00\x68\x00\x69\x00\x50\x00\x13\x00\x00\x00\x00\x00\x6b\x00\x6c\x00\x6d\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\x6e\x00\x00\x00\x00\x00\x6f\x00\x70\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\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\x59\x00\x5a\x00\x00\x00\x5b\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\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\x00\x00\xea\x01\x63\x00\x64\x00\x00\x00\x00\x00\x00\x00\x67\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6b\x00\x6c\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\x6e\x00\x00\x00\x00\x00\x6f\x00\x70\x00\xe8\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\x48\x03\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x45\x03\x46\x03\x47\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\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\x8f\x00\xdd\x00\x91\x00\x00\x00\x92\x00\xe8\x01\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x00\x00\x00\x00\x98\x00\x99\x00\x2c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x48\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa7\x03\xa8\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe8\x01\x00\x00\x00\x00\x00\x00\x9e\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2c\x00\x00\x00\x00\x00\x00\x00\xa0\x00\x72\x00\x00\x00\x00\x00\x00\x00\x73\x00\x74\x00\x00\x00\x00\x00\x48\x03\x00\x00\x8f\x00\xdd\x00\x91\x00\x00\x00\x92\x00\x00\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x00\x00\x00\x00\x98\x00\x99\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa2\x00\xa9\x03\xa7\x03\xa8\x03\x00\x00\x00\x00\x00\x00\x00\x00\xa3\x00\x00\x00\x00\x00\xaa\x03\x00\x00\xab\x03\x00\x00\xac\x03\x00\x00\x00\x00\x00\x00\x9e\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\x00\x72\x00\x00\x00\x00\x00\x00\x00\x73\x00\x74\x00\x00\x00\x00\x00\x00\x00\x8f\x00\xdd\x00\x91\x00\x00\x00\x92\x00\x00\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x00\x00\x00\x00\x98\x00\x99\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa2\x00\xa7\x03\xa8\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa3\x00\x00\x00\x00\x00\xae\x03\x00\x00\xab\x03\x00\x00\xac\x03\x00\x00\x00\x00\x9e\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\x00\x72\x00\x00\x00\x00\x00\x00\x00\x73\x00\x74\x00\x00\x00\x00\x00\x00\x00\x8f\x00\xdd\x00\x91\x00\x00\x00\x92\x00\x00\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x00\x00\x00\x00\x98\x00\x99\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa2\x00\xa7\x03\xa8\x03\x0e\xfe\x81\x00\xbd\x01\x00\x00\x00\x00\xa3\x00\x00\x00\x0e\xfe\xfa\x03\x0e\xfe\xab\x03\x00\x00\xac\x03\x83\x00\x00\x00\x9e\x00\x9f\x00\x84\x00\xbe\x01\xbf\x01\xc0\x01\xc1\x01\x85\x00\x00\x00\x00\x00\xa0\x00\x72\x00\x00\x00\x0e\xfe\x8f\x00\x73\x00\x74\x00\x0e\xfe\x00\x00\x0e\xfe\x00\x00\x0e\xfe\xa3\x01\x96\x00\x97\x00\x0e\xfe\x49\x01\x98\x00\x99\x00\x00\x00\x8b\x00\x8c\x00\x00\x00\x00\x00\x8e\x00\x8f\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\xa4\x01\xb0\x03\xa2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x9e\x00\x9f\x00\x00\x00\xb2\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\x00\x72\x00\x00\x00\x00\x00\x00\x00\x73\x00\x74\x00\x00\x00\x8f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa3\x01\x96\x00\x97\x00\x00\x00\x00\x00\x98\x00\x99\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa2\x00\xb1\x03\xa4\x01\xb0\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb2\x03\x00\x00\xb3\x03\x00\x00\xb4\x03\x00\x00\x9e\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\x00\x72\x00\x00\x00\x00\x00\x00\x00\x73\x00\x74\x00\x8f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa3\x01\x96\x00\x97\x00\x00\x00\x00\x00\x98\x00\x99\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa2\x00\xa4\x01\xb0\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x8f\x00\xb6\x03\x00\x00\xb3\x03\x00\x00\xb4\x03\x9e\x00\x9f\x00\xa3\x01\x96\x00\x97\x00\x00\x00\x00\x00\x98\x00\x99\x00\x00\x00\xa0\x00\x72\x00\x00\x00\x00\x00\x00\x00\x73\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\xa4\x01\xb0\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x9e\x00\x9f\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa2\x00\x00\x00\xa0\x00\x72\x00\x00\x00\x00\x00\x00\x00\x73\x00\x74\x00\x00\x00\xf2\x03\x00\x00\xb3\x03\x00\x00\xb4\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\xa1\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x15\x00\x7c\x00\x7d\x00\x00\x00\x16\x00\xa2\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xb5\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\x81\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x82\x00\x00\x00\x00\x00\x00\x00\x83\x00\x00\x00\x00\x00\x00\x00\x84\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\x86\x00\x13\x00\x87\x00\x00\x00\x88\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x89\x00\x00\x00\x2c\x00\x8a\x00\x8b\x00\x8c\x00\x2d\x00\x8d\x00\x8e\x00\x8f\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\x81\x00\x00\x00\x00\x00\x00\x00\x00\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\x00\x00\x85\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd1\x01\x00\x00\xd2\x01\x00\x00\x88\x00\x00\x00\x00\x00\x00\x00\x00\x00\x13\x00\xd3\x01\x00\x00\x2c\x00\x8a\x00\x8b\x00\x8c\x00\x14\x00\x8d\x00\x00\x00\x8f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x56\x04\x00\x00\x00\x00\x15\x00\x00\x00\x57\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\x58\x04\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\x56\x04\x00\x00\x00\x00\x15\x00\x00\x00\x57\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\x58\x04\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\x59\x04\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5a\x04\x14\x00\x00\x00\x2c\x00\x64\x00\x00\x00\x00\x00\x2d\x00\x67\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\x59\x04\x19\xfe\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x19\xfe\x00\x00\x2c\x00\x64\x00\x00\x00\x00\x00\x2d\x00\x67\x00\x00\x00\x00\x00\x00\x00\x00\x00\x19\xfe\x00\x00\x00\x00\x00\x00\x19\xfe\x00\x00\x19\xfe\x19\xfe\x19\xfe\x19\xfe\x19\xfe\x19\xfe\x19\xfe\x19\xfe\x19\xfe\x19\xfe\x19\xfe\x19\xfe\x19\xfe\x00\x00\x00\x00\x19\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x19\xfe\x19\xfe\x19\xfe\x19\xfe\x19\xfe\x19\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x86\x00\x00\x00\x93\x01\x00\x00\x88\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2c\x00\x8a\x00\x00\x00\x00\x00\x2d\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\x00\x00\x13\x00\x00\x00\x00\x00\x00\x00\x70\x01\x00\x00\x19\xfe\x14\x00\x19\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x19\xfe\x19\xfe\x00\x00\x15\x00\x19\xfe\x19\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\x57\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\x86\x00\x00\x00\x93\x01\x00\x00\x88\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x13\x00\x2c\x00\x8a\x00\x00\x00\x00\x00\x2d\x00\x8d\x00\x14\x00\x00\x00\x08\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\x59\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\x67\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\xd1\x01\x00\x00\xd2\x01\x14\x00\x88\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2c\x00\x8a\x00\x00\x00\x15\x00\x00\x00\x8d\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\x8a\x00\x00\x00\x15\x00\x2d\x00\x8d\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\x19\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x19\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x72\x01\x00\x00\x00\x00\x2c\x00\x8a\x00\x19\xfe\x00\x00\x00\x00\x8d\x00\x19\xfe\x00\x00\x19\xfe\x19\xfe\x19\xfe\x19\xfe\x19\xfe\x19\xfe\x19\xfe\x19\xfe\x19\xfe\x19\xfe\x19\xfe\x19\xfe\x19\xfe\x00\x00\x00\x00\x19\xfe\x00\x00\x00\x00\x00\x00\x19\xfe\x19\xfe\x19\xfe\x19\xfe\x19\xfe\x19\xfe\x19\xfe\x19\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x63\x00\x64\x00\x19\xfe\x00\x00\x00\x00\x67\x00\x19\xfe\x00\x00\x19\xfe\x19\xfe\x19\xfe\x19\xfe\x19\xfe\x19\xfe\x19\xfe\x19\xfe\x19\xfe\x19\xfe\x19\xfe\x19\xfe\x19\xfe\x00\x00\x00\x00\x19\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x19\xfe\x19\xfe\x19\xfe\x19\xfe\x19\xfe\x19\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x70\x01\x00\x00\x19\xfe\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x19\xfe\x00\x00\x00\x00\x00\x00\x19\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\x70\x01\x00\x00\x19\xfe\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x13\x00\x00\x00\x19\xfe\x00\x00\x00\x00\x00\x00\x19\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\x64\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\x81\x00\x8f\x00\x00\x00\x00\x00\xd7\x02\xd8\x02\x00\x00\xd9\x02\x94\x00\x95\x00\x96\x00\x97\x00\x83\x00\x00\x00\x98\x00\x99\x00\x84\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\x86\x00\x00\x00\x6c\x01\x60\x01\x88\x00\x00\x00\x00\x00\x00\x00\x00\x00\x61\x01\x00\x00\x00\x00\x2c\x00\x8a\x00\x8b\x00\x8c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9e\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\x00\x72\x00\x00\x00\x00\x00\x8f\x00\x73\x00\x74\x00\x68\x03\xd8\x02\x00\x00\xd9\x02\x94\x00\x95\x00\x96\x00\x97\x00\x00\x00\x00\x00\x98\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\xa1\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xda\x02\x00\x00\x00\x00\x9e\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\x00\x72\x00\x00\x00\x00\x00\x00\x00\x73\x00\x74\x00\x8f\x00\x4c\x01\x4d\x01\x00\x00\x92\x00\x00\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x4e\x01\x00\x00\x98\x00\x99\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4f\x01\x50\x01\x00\x00\x00\x00\xa1\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xda\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9e\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\x00\x72\x00\x00\x00\x00\x00\x00\x00\x73\x00\x74\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\x52\x01\x53\x01\x00\x00\x54\x01\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x55\x01\x56\x01\x9a\x01\x58\x01\x11\x00\x7b\x00\x7c\x00\x7d\x00\x59\x01\x7f\x00\xa2\x00\x00\x00\x00\x00\x5a\x01\x00\x00\x5b\x01\x00\x00\x13\x00\xa3\x00\x8f\x00\x4c\x01\x4d\x01\x00\x00\x92\x00\x14\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x4e\x01\x00\x00\x98\x00\x99\x00\x00\x00\x00\x00\x15\x00\x00\x00\x4f\x01\x50\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\x9e\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\x00\x72\x00\x00\x00\x00\x00\x00\x00\x73\x00\x74\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\x52\x01\x53\x01\x00\x00\x54\x01\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x55\x01\x56\x01\x57\x01\x58\x01\x11\x00\x7b\x00\x7c\x00\x7d\x00\x59\x01\x7f\x00\xa2\x00\x00\x00\x00\x00\x5a\x01\x2c\x00\x5b\x01\x00\x00\x13\x00\xa3\x00\x8f\x00\x4c\x01\x4d\x01\x00\x00\x92\x00\x14\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x00\x00\x00\x00\x98\x00\x99\x00\x00\x00\x00\x00\x15\x00\x00\x00\x94\x01\x95\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\x9e\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\x00\x72\x00\x00\x00\x00\x00\x00\x00\x73\x00\x74\x00\x00\x00\x51\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x28\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x52\x01\x53\x01\x00\x00\x54\x01\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x55\x01\x96\x01\x00\x00\x97\x01\x11\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\xa2\x00\x00\x00\x00\x00\x98\x01\x63\x00\x5b\x01\x00\x00\x00\x00\xa3\x00\x8f\x00\x4c\x01\x4d\x01\x00\x00\x92\x00\x00\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x00\x00\x00\x00\x98\x00\x99\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9b\x01\x00\x00\x00\x00\x00\x00\x9c\x01\x9d\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\x9e\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\x00\x72\x00\x00\x00\x00\x00\x00\x00\x73\x00\x74\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\x52\x01\x53\x01\x00\x00\x54\x01\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x55\x01\x96\x01\x00\x00\x97\x01\x11\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\xa2\x00\x00\x00\x00\x00\x8f\x00\x4c\x01\x4d\x01\x00\x00\x92\x00\xa3\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x00\x00\x00\x00\x98\x00\x99\x00\x00\x00\x00\x00\x00\x00\x00\x00\x83\x02\x00\x00\x00\x00\x84\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\x9e\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\x00\x72\x00\x00\x00\x00\x00\x00\x00\x73\x00\x74\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\x52\x01\x53\x01\x00\x00\x54\x01\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x55\x01\x96\x01\x00\x00\x97\x01\x11\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\xa2\x00\x00\x00\x00\x00\x8f\x00\x4c\x01\x4d\x01\x00\x00\x92\x00\xa3\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x00\x00\x00\x00\x98\x00\x99\x00\x00\x00\x00\x00\x00\x00\x00\x00\x83\x02\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\x00\x00\x00\x00\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\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\x00\x72\x00\x00\x00\x00\x00\x00\x00\x73\x00\x74\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\x52\x01\x53\x01\x00\x00\x54\x01\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x55\x01\x96\x01\x00\x00\x97\x01\x11\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\xa2\x00\x00\x00\x00\x00\x8f\x00\x4c\x01\x4d\x01\x00\x00\x92\x00\xa3\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x00\x00\x00\x00\x98\x00\x99\x00\x00\x00\x00\x00\x00\x00\x00\x00\xca\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\x9e\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\x00\x72\x00\x00\x00\x00\x00\x00\x00\x73\x00\x74\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\x52\x01\x53\x01\x00\x00\x54\x01\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x55\x01\x96\x01\x00\x00\x97\x01\x11\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\xa2\x00\x00\x00\x00\x00\x8f\x00\x4c\x01\x4d\x01\x00\x00\x92\x00\xa3\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x00\x00\x00\x00\x98\x00\x99\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa5\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\x9e\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\x00\x72\x00\x00\x00\x00\x00\x00\x00\x73\x00\x74\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\x52\x01\x53\x01\x00\x00\x54\x01\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x55\x01\x96\x01\x00\x00\x97\x01\x11\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\xa2\x00\x00\x00\x00\x00\x8f\x00\x9c\x03\x4d\x01\x00\x00\x92\x00\xa3\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x00\x00\x00\x00\x98\x00\x99\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9d\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\x9e\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\x00\x72\x00\x00\x00\x00\x00\x00\x00\x73\x00\x74\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\x52\x01\x53\x01\x00\x00\x54\x01\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x55\x01\x96\x01\x00\x00\x97\x01\x11\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\xa2\x00\x00\x00\x00\x00\x8f\x00\x4c\x01\x4d\x01\x00\x00\x92\x00\xa3\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x00\x00\x00\x00\x98\x00\x99\x00\x00\x00\x00\x00\x00\x00\x00\x00\x73\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\x9e\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\x00\x72\x00\x00\x00\x00\x00\x00\x00\x73\x00\x74\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\x52\x01\x53\x01\x00\x00\x54\x01\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x55\x01\x96\x01\x00\x00\x97\x01\x11\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\xa2\x00\x00\x00\x00\x00\x8f\x00\x4c\x01\x4d\x01\x00\x00\x92\x00\xa3\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x00\x00\x00\x00\x98\x00\x99\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x9e\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\x00\x72\x00\x00\x00\x00\x00\x00\x00\x73\x00\x74\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\x52\x01\x53\x01\x00\x00\x54\x01\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x55\x01\x96\x01\x00\x00\x97\x01\x11\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\xa2\x00\x00\x00\x00\x00\x8f\x00\x4c\x01\x4d\x01\x00\x00\x92\x00\xa3\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x00\x00\x00\x00\x98\x00\x99\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd1\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\x9e\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\x00\x72\x00\x00\x00\x00\x00\x00\x00\x73\x00\x74\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\x52\x01\x53\x01\x00\x00\x54\x01\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x55\x01\x96\x01\x00\x00\x97\x01\x11\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\xa2\x00\x00\x00\x00\x00\x8f\x00\x90\x00\x91\x00\x00\x00\x92\x00\xa3\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x00\x00\x00\x00\x98\x00\x99\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9e\x03\x9f\x03\xa0\x03\xa1\x03\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\xa2\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9e\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\x00\x72\x00\x00\x00\x00\x00\x00\x00\x73\x00\x74\x00\x00\x00\x8f\x00\x90\x00\x91\x00\x00\x00\x92\x00\x00\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x00\x00\x00\x00\x98\x00\x99\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\x00\x00\x0f\x00\x10\x00\xae\x04\xa0\x03\xa1\x03\x00\x00\x00\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa2\x00\x9a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa3\x00\xa2\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9e\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\x00\x72\x00\x00\x00\x00\x00\x00\x00\x73\x00\x74\x00\x00\x00\x00\x00\x00\x00\x8f\x00\x90\x00\x91\x00\x00\x00\x92\x00\x00\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x00\x00\x00\x00\x98\x00\x99\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa2\x00\x00\x00\x00\x00\x9a\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa3\x00\xfb\x00\xfc\x00\x9d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9e\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\x00\x72\x00\x00\x00\x00\x00\x00\x00\x73\x00\x74\x00\x00\x00\x00\x00\x8f\x00\x90\x00\x91\x00\x00\x00\x92\x00\x00\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x00\x00\x00\x00\x98\x00\x99\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa2\x00\x00\x00\x9a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9b\x00\xa3\x00\x9c\x00\x9d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9e\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\x00\x72\x00\x00\x00\x00\x00\x00\x00\x73\x00\x74\x00\x00\x00\x00\x00\x8f\x00\x90\x00\x91\x00\x00\x00\x92\x00\x00\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x00\x00\x00\x00\x98\x00\x99\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa2\x00\x00\x00\x9a\x00\x00\x00\x00\x00\x00\x00\x8d\x02\x00\x00\xa3\x00\x8c\x02\x9d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9e\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\x00\x72\x00\x00\x00\x00\x00\x00\x00\x73\x00\x74\x00\x00\x00\x00\x00\x8f\x00\x90\x00\x91\x00\x00\x00\x92\x00\x00\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x00\x00\x00\x00\x98\x00\x99\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa2\x00\x00\x00\x9a\x00\x00\x00\x00\x00\x00\x00\x8b\x02\x00\x00\xa3\x00\x8c\x02\x9d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9e\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\x00\x72\x00\x00\x00\x00\x00\x00\x00\x73\x00\x74\x00\x00\x00\x8f\x00\x90\x00\x91\x00\x00\x00\x92\x00\x00\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x00\x00\x00\x00\x98\x00\x99\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x6a\x02\x6b\x02\x11\x00\x00\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa2\x00\x9a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa3\x00\x6c\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9e\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\x00\x72\x00\x00\x00\x00\x00\x00\x00\x73\x00\x74\x00\x00\x00\x8f\x00\x90\x00\x91\x00\x00\x00\x92\x00\x00\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x00\x00\x00\x00\x98\x00\x99\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x63\x03\x6b\x02\x11\x00\x00\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa2\x00\x9a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa3\x00\x6c\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9e\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\x00\x72\x00\x00\x00\x00\x00\x00\x00\x73\x00\x74\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x8f\x00\xae\x01\x91\x00\x00\x00\x92\x00\x00\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x00\x00\x00\x00\x98\x00\x99\x00\x00\x00\x00\x00\xa1\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa2\x00\xaf\x01\xb0\x01\xb1\x01\x00\x00\x00\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\x9e\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\x00\x72\x00\x00\x00\x00\x00\x00\x00\x73\x00\x74\x00\x00\x00\x00\x00\x8f\x00\x90\x00\x91\x00\x00\x00\x92\x00\x00\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x00\x00\x00\x00\x98\x00\x99\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa2\x00\x00\x00\x9a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa3\x00\x03\x04\x9d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9e\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\x00\x72\x00\x00\x00\x00\x00\x00\x00\x73\x00\x74\x00\x00\x00\x8f\x00\x90\x00\x91\x00\x00\x00\x92\x00\x00\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x00\x00\x00\x00\x98\x00\x99\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\xac\x04\x00\x00\x00\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa2\x00\x9a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa3\x00\xad\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9e\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\x00\x72\x00\x00\x00\x00\x00\x00\x00\x73\x00\x74\x00\x00\x00\x8f\x00\x90\x00\x91\x00\x00\x00\x92\x00\x00\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x00\x00\x00\x00\x98\x00\x99\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa2\x00\x9a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa3\x00\xef\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9e\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\x00\x72\x00\x00\x00\x00\x00\x00\x00\x73\x00\x74\x00\x8f\x00\xdd\x00\x91\x00\x00\x00\x92\x00\x00\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x00\x00\x00\x00\x98\x00\x99\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\xde\x00\x00\x00\xa2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9e\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\x00\x72\x00\x00\x00\x00\x00\x00\x00\x73\x00\x74\x00\x8f\x00\xdd\x00\x91\x00\x00\x00\x92\x00\x00\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x00\x00\x00\x00\x98\x00\x99\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\x3a\x03\x00\x00\xa2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9e\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\x00\x72\x00\x00\x00\x00\x00\x00\x00\x73\x00\x74\x00\x8f\x00\xdd\x00\x91\x00\x00\x00\x92\x00\x00\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x00\x00\x00\x00\x98\x00\x99\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\x39\x03\x00\x00\xa2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9e\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\x00\x72\x00\x00\x00\x00\x00\x00\x00\x73\x00\x74\x00\x8f\x00\xdf\x00\x91\x00\x00\x00\x92\x00\x00\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x00\x00\x00\x00\x98\x00\x99\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9e\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\x00\x72\x00\x00\x00\x00\x00\x00\x00\x73\x00\x74\x00\x8f\x00\xbb\x01\x91\x00\x00\x00\x92\x00\x00\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x00\x00\x00\x00\x98\x00\x99\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9e\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\x00\x72\x00\x00\x00\x00\x00\x00\x00\x73\x00\x74\x00\x8f\x00\xb4\x01\x91\x00\x00\x00\x92\x00\x00\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x00\x00\x00\x00\x98\x00\x99\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9e\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\x00\x72\x00\x00\x00\x00\x00\x00\x00\x73\x00\x74\x00\x8f\x00\x8b\x01\x91\x00\x00\x00\x92\x00\x00\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x00\x00\x00\x00\x98\x00\x99\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9e\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\x00\x72\x00\x00\x00\x00\x00\x00\x00\x73\x00\x74\x00\x8f\x00\x85\x01\x91\x00\x00\x00\x92\x00\x00\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x00\x00\x00\x00\x98\x00\x99\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9e\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\x00\x72\x00\x00\x00\x00\x00\x00\x00\x73\x00\x74\x00\x8f\x00\x66\x02\x91\x00\x00\x00\x92\x00\x00\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x00\x00\x00\x00\x98\x00\x99\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9e\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\x00\x72\x00\x00\x00\x00\x00\x00\x00\x73\x00\x74\x00\x8f\x00\x5a\x02\x91\x00\x00\x00\x92\x00\x00\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x00\x00\x00\x00\x98\x00\x99\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9e\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\x00\x72\x00\x00\x00\x00\x00\x00\x00\x73\x00\x74\x00\x8f\x00\x59\x02\x91\x00\x00\x00\x92\x00\x00\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x00\x00\x00\x00\x98\x00\x99\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9e\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\x00\x72\x00\x00\x00\x00\x00\x00\x00\x73\x00\x74\x00\x8f\x00\x58\x02\x91\x00\x00\x00\x92\x00\x00\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x00\x00\x00\x00\x98\x00\x99\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9e\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\x00\x72\x00\x00\x00\x00\x00\x00\x00\x73\x00\x74\x00\x8f\x00\x57\x02\x91\x00\x00\x00\x92\x00\x00\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x00\x00\x00\x00\x98\x00\x99\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9e\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\x00\x72\x00\x00\x00\x00\x00\x00\x00\x73\x00\x74\x00\x8f\x00\xb9\x03\x91\x00\x00\x00\x92\x00\x00\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x00\x00\x00\x00\x98\x00\x99\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9e\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\x00\x72\x00\x00\x00\x00\x00\x00\x00\x73\x00\x74\x00\x8f\x00\xb8\x03\x91\x00\x00\x00\x92\x00\x00\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x00\x00\x00\x00\x98\x00\x99\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9e\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\x00\x72\x00\x00\x00\x00\x00\x00\x00\x73\x00\x74\x00\x8f\x00\xa6\x03\x91\x00\x00\x00\x92\x00\x00\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x00\x00\x00\x00\x98\x00\x99\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9e\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\x00\x72\x00\x00\x00\x00\x00\x00\x00\x73\x00\x74\x00\x8f\x00\xa4\x03\x91\x00\x00\x00\x92\x00\x00\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x00\x00\x00\x00\x98\x00\x99\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9e\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\x00\x72\x00\x00\x00\x00\x00\x00\x00\x73\x00\x74\x00\x8f\x00\x64\x03\x91\x00\x00\x00\x92\x00\x00\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x00\x00\x00\x00\x98\x00\x99\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9e\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\x00\x72\x00\x00\x00\x00\x00\x00\x00\x73\x00\x74\x00\x8f\x00\x08\x04\x91\x00\x00\x00\x92\x00\x00\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x00\x00\x00\x00\x98\x00\x99\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9e\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\x00\x72\x00\x00\x00\x00\x00\x00\x00\x73\x00\x74\x00\x8f\x00\xfe\x03\x91\x00\x00\x00\x92\x00\x00\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x00\x00\x00\x00\x98\x00\x99\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9e\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\x00\x72\x00\x00\x00\x00\x00\x00\x00\x73\x00\x74\x00\x8f\x00\xf0\x03\x91\x00\x00\x00\x92\x00\x00\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x00\x00\x00\x00\x98\x00\x99\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9e\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\x00\x72\x00\x00\x00\x00\x00\x00\x00\x73\x00\x74\x00\x8f\x00\xee\x03\x91\x00\x00\x00\x92\x00\x00\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x00\x00\x00\x00\x98\x00\x99\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9e\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\x00\x72\x00\x00\x00\x00\x00\x00\x00\x73\x00\x74\x00\x8f\x00\xb3\x04\x91\x00\x00\x00\x92\x00\x00\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x00\x00\x00\x00\x98\x00\x99\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9e\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\x00\x72\x00\x00\x00\x00\x00\x00\x00\x73\x00\x74\x00\x8f\x00\xab\x04\x91\x00\x00\x00\x92\x00\x00\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x00\x00\x00\x00\x98\x00\x99\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9e\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\x00\x72\x00\x00\x00\x00\x00\x00\x00\x73\x00\x74\x00\x8f\x00\x92\x04\x91\x00\x00\x00\x92\x00\x00\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x00\x00\x00\x00\x98\x00\x99\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9e\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\x00\x72\x00\x00\x00\x00\x00\x00\x00\x73\x00\x74\x00\x8f\x00\x00\x05\x91\x00\x00\x00\x92\x00\x00\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x00\x00\x00\x00\x98\x00\x99\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9e\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\x00\x72\x00\x00\x00\x00\x00\x00\x00\x73\x00\x74\x00\x8f\x00\xd5\x04\x91\x00\x00\x00\x92\x00\x00\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x00\x00\x00\x00\x98\x00\x99\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9e\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\x00\x72\x00\x00\x00\x00\x00\x00\x00\x73\x00\x74\x00\x8f\x00\xd4\x04\x91\x00\x00\x00\x92\x00\x00\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x00\x00\x00\x00\x98\x00\x99\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9e\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\x00\x72\x00\x00\x00\x00\x00\x00\x00\x73\x00\x74\x00\x8f\x00\xd3\x04\x91\x00\x00\x00\x92\x00\x00\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x00\x00\x00\x00\x98\x00\x99\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9e\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\x00\x72\x00\x00\x00\x00\x00\x00\x00\x73\x00\x74\x00\x8f\x00\x34\x05\x91\x00\x00\x00\x92\x00\x00\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x00\x00\x00\x00\x98\x00\x99\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9e\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\x00\x72\x00\x00\x00\x00\x00\x00\x00\x73\x00\x74\x00\x8f\x00\x44\x05\x91\x00\x00\x00\x92\x00\x00\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x00\x00\x00\x00\x98\x00\x99\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa2\x00\x00\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa3\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9e\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\xa0\x00\x72\x00\x17\x00\x18\x00\x19\x00\x73\x00\x74\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\xa1\x00\x13\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa2\x00\x00\x00\x16\x01\x00\x00\x00\x00\x15\x00\x00\x00\x17\x01\xa3\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\x1b\x02\x1c\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\x86\x00\x00\x00\x18\x01\x00\x00\x88\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2c\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\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x86\x00\x00\x00\x6c\x01\x00\x00\x88\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x2c\x00\x8a\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\x86\x00\x00\x00\x27\x01\x00\x00\x88\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2c\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\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x86\x00\x00\x00\x18\x01\x00\x00\x88\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x2c\x00\x8a\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\x86\x00\x00\x00\x6c\x01\x00\x00\x88\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2c\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\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x86\x00\x00\x00\x18\x01\x00\x00\x88\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x2c\x00\x8a\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\x8a\x00\x00\x00\x00\x00\x02\xff\x00\x00\x15\x00\x00\x00\x00\x00\x02\xff\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\x04\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\xb1\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\xe8\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\x42\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\xe8\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\x42\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\xf2\x01\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\xf3\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\xf3\x01\x00\x00\x00\x00\x00\x00\x8f\x00\x00\x00\x8a\x01\x00\x00\x92\x00\x00\x00\x63\x00\x94\x00\x95\x00\x96\x00\x97\x00\x00\x00\x00\x00\x98\x00\x99\x00\x00\x00\x00\x00\x8f\x00\x00\x00\xcc\x02\x00\x00\x92\x00\x00\x00\x00\x00\x94\x00\x95\x00\x96\x00\x97\x00\x00\x00\x00\x00\x98\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\x00\x00\x00\x00\x00\x00\x00\x00\x9e\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x63\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\x00\x72\x00\x00\x00\x00\x00\x00\x00\x73\x00\x74\x00\x9e\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\x00\x72\x00\x00\x00\x00\x00\x00\x00\x73\x00\x74\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa2\x00\x00\x00\xa1\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\x00\x00\x8f\x00\xa2\x00\x42\x04\x00\x00\x92\x00\x00\x00\x00\x00\x94\x00\x95\x00\x96\x00\x97\x00\x00\x00\x00\x00\x98\x00\x99\x00\x00\x00\x00\x00\x8f\x00\x00\x00\xec\x04\x00\x00\x92\x00\x00\x00\x00\x00\x94\x00\x95\x00\x96\x00\x97\x00\x00\x00\x00\x00\x98\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\x00\x00\x00\x00\x00\x00\x00\x00\x9e\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\x00\x72\x00\x00\x00\x00\x00\x00\x00\x73\x00\x74\x00\x9e\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\x00\x72\x00\x00\x00\x00\x00\x00\x00\x73\x00\x74\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa2\x00\x00\x00\xa1\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x8f\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa2\x00\xa3\x01\x96\x00\x97\x00\x00\x00\x00\x00\x98\x00\x99\x00\x00\x00\x00\x00\x8f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa3\x01\x96\x00\x97\x00\x00\x00\x00\x00\x98\x00\x99\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x01\xa5\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\x9e\x00\x9f\x00\x00\x00\xa4\x01\x7c\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\x00\x72\x00\x00\x00\x00\x00\x00\x00\x73\x00\x74\x00\x9e\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\x00\x72\x00\x00\x00\x00\x00\x00\x00\x73\x00\x74\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa2\x00\x00\x00\xa1\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x8f\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa2\x00\x00\x00\xa2\x01\x95\x00\x96\x00\x97\x00\x00\x00\x00\x00\x98\x00\x99\x00\x00\x00\x00\x00\x8f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x97\x03\x96\x00\x97\x00\x00\x00\x00\x00\x98\x00\x99\x00\x00\x00\x98\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\x9e\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\x00\x72\x00\x00\x00\x00\x00\x00\x00\x73\x00\x74\x00\x9e\x00\x9f\x00\x00\x00\x00\x00\x8f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\x00\x72\x00\xb9\x01\x96\x00\x97\x00\x73\x00\x74\x00\x98\x00\x99\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa2\x00\x00\x00\xa1\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa2\x00\x00\x00\x9e\x00\x9f\x00\x00\x00\x00\x00\x8f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\x00\x72\x00\xac\x01\x96\x00\x97\x00\x73\x00\x74\x00\x98\x00\x99\x00\x00\x00\x00\x00\x8f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xaa\x01\x96\x00\x97\x00\x00\x00\x00\x00\x98\x00\x99\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa2\x00\x00\x00\x9e\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\x00\x72\x00\x00\x00\x00\x00\x00\x00\x73\x00\x74\x00\x9e\x00\x9f\x00\x00\x00\x00\x00\x8f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\x00\x72\x00\xa1\x01\x96\x00\x97\x00\x73\x00\x74\x00\x98\x00\x99\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa2\x00\x00\x00\xa1\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa2\x00\x00\x00\x9e\x00\x9f\x00\x00\x00\x00\x00\x8f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\x00\x72\x00\xa0\x01\x96\x00\x97\x00\x73\x00\x74\x00\x98\x00\x99\x00\x00\x00\x00\x00\x8f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x01\x96\x00\x97\x00\x00\x00\x00\x00\x98\x00\x99\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa2\x00\x00\x00\x9e\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\x00\x72\x00\x00\x00\x00\x00\x00\x00\x73\x00\x74\x00\x9e\x00\x9f\x00\x00\x00\x00\x00\x8f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\x00\x72\x00\x93\x01\x96\x00\x97\x00\x73\x00\x74\x00\x98\x00\x99\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa2\x00\x00\x00\xa1\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa2\x00\x00\x00\x9e\x00\x9f\x00\x00\x00\x00\x00\x8f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\x00\x72\x00\x18\x03\x96\x00\x97\x00\x73\x00\x74\x00\x98\x00\x99\x00\x00\x00\x00\x00\x8f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x17\x03\x96\x00\x97\x00\x00\x00\x00\x00\x98\x00\x99\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa2\x00\x00\x00\x9e\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\x00\x72\x00\x00\x00\x00\x00\x00\x00\x73\x00\x74\x00\x9e\x00\x9f\x00\x00\x00\x00\x00\x8f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\x00\x72\x00\xb9\x01\x96\x00\x97\x00\x73\x00\x74\x00\x98\x00\x99\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa2\x00\x00\x00\xa1\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa2\x00\x00\x00\x9e\x00\x9f\x00\x00\x00\x00\x00\x8f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\x00\x72\x00\x67\x02\x96\x00\x97\x00\x73\x00\x74\x00\x98\x00\x99\x00\x00\x00\x00\x00\x8f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2e\x03\x96\x00\x97\x00\x00\x00\x00\x00\x98\x00\x99\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa2\x00\x00\x00\x9e\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\x00\x72\x00\x00\x00\x00\x00\x00\x00\x73\x00\x74\x00\x9e\x00\x9f\x00\x00\x00\x00\x00\x8f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\x00\x72\x00\x00\x00\x00\x00\xc8\x01\x73\x00\x74\x00\x98\x00\x99\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa2\x00\x00\x00\xa1\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x8f\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa2\x00\x00\x00\x9e\x00\x9f\x00\x00\x00\x83\x01\x00\x00\x00\x00\x98\x00\x99\x00\x00\x00\x00\x00\xa0\x00\x72\x00\x00\x00\x00\x00\x00\x00\x73\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\x00\x00\x00\x00\x84\x01\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x9e\x00\x9f\x00\x00\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa2\x00\xa0\x00\x72\x00\x00\x00\x00\x00\x00\x00\x73\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\x00\x00\x00\x00\x84\x01\x00\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7c\x00\x7d\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\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, 832) [ - (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) - ] - -happy_n_terms = 151 :: Prelude.Int -happy_n_nonterms = 314 :: 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 happyOut299 happy_x_1 of { (HappyWrap299 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 happyOut269 happy_x_1 of { (HappyWrap269 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 happyOut293 happy_x_1 of { (HappyWrap293 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 happyOut277 happy_x_1 of { (HappyWrap277 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) - (NameAnn NameParens (glAA happy_var_1) (glAA happy_var_2) (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 (glAA happy_var_1) []))}) - ) (\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 happyOut316 happy_x_1 of { (HappyWrap316 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 happyOut316 happy_x_1 of { (HappyWrap316 happy_var_1) -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut316 happy_x_3 of { (HappyWrap316 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 happyOut316 happy_x_2 of { (HappyWrap316 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 happyOut316 happy_x_3 of { (HappyWrap316 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 happyOut308 happy_x_1 of { (HappyWrap308 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 happyOut316 happy_x_1 of { (HappyWrap316 happy_var_1) -> - case happyOut316 happy_x_3 of { (HappyWrap316 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 happyOut316 happy_x_1 of { (HappyWrap316 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 happyOut63 happy_x_2 of { (HappyWrap63 happy_var_2) -> - case happyOut316 happy_x_3 of { (HappyWrap316 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 happyOut316 happy_x_2 of { (HappyWrap316 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 happyOut316 happy_x_2 of { (HappyWrap316 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)) 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 happyOut316 happy_x_2 of { (HappyWrap316 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 -> (L loc (HsModule (XModulePs - (EpAnn (spanAsAnchor loc) (AnnsModule [mj AnnModule happy_var_1, mj AnnWhere happy_var_5] (fstOf3 happy_var_6)) 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 -> (L loc (HsModule (XModulePs - (EpAnn (spanAsAnchor loc) (AnnsModule [] (fstOf3 happy_var_1)) 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 happyOut144 happy_x_2 of { (HappyWrap144 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 3# 22# happyReduction_66 -happyReduction_66 (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 -> - ( fmap Just $ amsrp (sLL happy_var_1 happy_var_3 $ WarningTxt (sL1 happy_var_1 $ getWARNING_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_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 - ((AnnList Nothing (Just $ moc happy_var_1) (Just $ mcc happy_var_3) [] (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 - ((AnnList Nothing Nothing Nothing [] (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 - ((AnnList Nothing (Just $ moc happy_var_1) (Just $ mcc happy_var_3) [] (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 - ((AnnList Nothing Nothing Nothing [] [], 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 happyOut59 happy_x_1 of { (HappyWrap59 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 happyOut61 happy_x_1 of { (HappyWrap61 happy_var_1) -> - case happyOut76 happy_x_2 of { (HappyWrap76 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 happyOut61 happy_x_1 of { (HappyWrap61 happy_var_1) -> - case happyOut75 happy_x_2 of { (HappyWrap75 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 happyOut60 happy_x_1 of { (HappyWrap60 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 happyOut316 happy_x_2 of { (HappyWrap316 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] (AnnList Nothing Nothing 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 happyOut316 happy_x_2 of { (HappyWrap316 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] (AnnList Nothing Nothing 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 happyOut61 happy_x_1 of { (HappyWrap61 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 happyOut60 happy_x_1 of { (HappyWrap60 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 2# 35# happyReduction_94 -happyReduction_94 (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) -> - ( mkModuleImpExp (fst $ unLoc happy_var_2) happy_var_1 (snd $ unLoc happy_var_2) - >>= \ie -> fmap (unitOL . reLocA) (return (sLL (reLoc happy_var_1) happy_var_2 ie)))}}) - ) (\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 2# 35# happyReduction_95 -happyReduction_95 (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) -> - ( fmap (unitOL . reLocA) (acs (\cs -> sLL happy_var_1 (reLoc happy_var_2) (IEModuleContents (EpAnn (glR happy_var_1) [mj AnnModule happy_var_1] cs) happy_var_2))))}}) - ) (\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_2 35# happyReduction_96 -happyReduction_96 happy_x_2 - happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut269 happy_x_2 of { (HappyWrap269 happy_var_2) -> - happyIn51 - (unitOL (reLocA (sLL happy_var_1 (reLocN happy_var_2) - (IEVar noExtField (sLLa happy_var_1 (reLocN happy_var_2) (IEPattern (glAA happy_var_1) happy_var_2))))) - )}} - -happyReduce_97 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_97 = happySpecReduce_0 36# happyReduction_97 -happyReduction_97 = happyIn52 - (sL0 ([],ImpExpAbs) - ) - -happyReduce_98 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_98 = happyMonadReduce 3# 36# happyReduction_98 -happyReduction_98 (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 (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 (happyIn52 r)) - -happyReduce_99 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_99 = happySpecReduce_0 37# happyReduction_99 -happyReduction_99 = happyIn53 - (([],[]) - ) - -happyReduce_100 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_100 = happySpecReduce_1 37# happyReduction_100 -happyReduction_100 happy_x_1 - = case happyOut54 happy_x_1 of { (HappyWrap54 happy_var_1) -> - happyIn53 - (happy_var_1 - )} - -happyReduce_101 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_101 = happyMonadReduce 3# 38# happyReduction_101 -happyReduction_101 (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 (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 (happyIn54 r)) - -happyReduce_102 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_102 = happySpecReduce_1 38# happyReduction_102 -happyReduction_102 happy_x_1 - = case happyOut55 happy_x_1 of { (HappyWrap55 happy_var_1) -> - happyIn54 - ((fst (unLoc happy_var_1),[snd (unLoc happy_var_1)]) - )} - -happyReduce_103 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_103 = happySpecReduce_1 39# happyReduction_103 -happyReduction_103 happy_x_1 - = case happyOut56 happy_x_1 of { (HappyWrap56 happy_var_1) -> - happyIn55 - (sL1A happy_var_1 ([],happy_var_1) - )} - -happyReduce_104 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_104 = happySpecReduce_1 39# happyReduction_104 -happyReduction_104 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn55 - (sL1 happy_var_1 ([mj AnnDotdot happy_var_1], sL1a happy_var_1 ImpExpQcWildcard) - )} - -happyReduce_105 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_105 = happySpecReduce_1 40# happyReduction_105 -happyReduction_105 happy_x_1 - = case happyOut57 happy_x_1 of { (HappyWrap57 happy_var_1) -> - happyIn56 - (reLocA $ sL1N happy_var_1 (ImpExpQcName happy_var_1) - )} - -happyReduce_106 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_106 = happyMonadReduce 2# 40# happyReduction_106 -happyReduction_106 (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) -> - ( do { n <- mkTypeImpExp happy_var_2 - ; return $ sLLa happy_var_1 (reLocN happy_var_2) (ImpExpQcType (glAA happy_var_1) n) })}}) - ) (\r -> happyReturn (happyIn56 r)) - -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_1 41# happyReduction_108 -happyReduction_108 happy_x_1 - = case happyOut281 happy_x_1 of { (HappyWrap281 happy_var_1) -> - happyIn57 - (happy_var_1 - )} - -happyReduce_109 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_109 = happySpecReduce_2 42# happyReduction_109 -happyReduction_109 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 - (sLL happy_var_1 happy_var_2 $ if isZeroWidthSpan (gl happy_var_2) then (unLoc happy_var_1) else (AddSemiAnn (glAA happy_var_2) : (unLoc happy_var_1)) - )}} - -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 happyOutTok happy_x_1 of { happy_var_1 -> - happyIn58 - (sL1 happy_var_1 $ msemi happy_var_1 - )} - -happyReduce_111 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_111 = happySpecReduce_2 43# happyReduction_111 -happyReduction_111 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 (glAA happy_var_2) : happy_var_1) - )}} - -happyReduce_112 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_112 = happySpecReduce_0 43# happyReduction_112 -happyReduction_112 = happyIn59 - ([] - ) - -happyReduce_113 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_113 = happySpecReduce_2 44# happyReduction_113 -happyReduction_113 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_114 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_114 = happyMonadReduce 3# 45# happyReduction_114 -happyReduction_114 (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 (reLoc happy_var_2) happy_var_3) (reverse $ unLoc happy_var_3) - ; return (i : happy_var_1)})}}}) - ) (\r -> happyReturn (happyIn61 r)) - -happyReduce_115 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_115 = happySpecReduce_0 45# happyReduction_115 -happyReduction_115 = happyIn61 - ([] - ) - -happyReduce_116 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_116 = happyMonadReduce 9# 46# happyReduction_116 -happyReduction_116 (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 happyOut64 happy_x_3 of { (HappyWrap64 happy_var_3) -> - case happyOut66 happy_x_4 of { (HappyWrap66 happy_var_4) -> - case happyOut65 happy_x_5 of { (HappyWrap65 happy_var_5) -> - case happyOut316 happy_x_6 of { (HappyWrap316 happy_var_6) -> - case happyOut66 happy_x_7 of { (HappyWrap66 happy_var_7) -> - case happyOut67 happy_x_8 of { (HappyWrap67 happy_var_8) -> - case happyOut68 happy_x_9 of { (HappyWrap68 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 (happyIn62 r)) - -happyReduce_117 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_117 = happySpecReduce_2 47# happyReduction_117 -happyReduction_117 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 (glAA happy_var_1,glAA happy_var_2),getSOURCE_PRAGs happy_var_1) - , IsBoot) - )}} - -happyReduce_118 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_118 = happySpecReduce_0 47# happyReduction_118 -happyReduction_118 = happyIn63 - (((Nothing,NoSourceText),NotBoot) - ) - -happyReduce_119 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_119 = happySpecReduce_1 48# happyReduction_119 -happyReduction_119 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn64 - ((Just (glAA happy_var_1),True) - )} - -happyReduce_120 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_120 = happySpecReduce_0 48# happyReduction_120 -happyReduction_120 = happyIn64 - ((Nothing, False) - ) - -happyReduce_121 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_121 = happyMonadReduce 1# 49# happyReduction_121 -happyReduction_121 (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 (happyIn65 r)) - -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,NoRawPkgQual) - ) - -happyReduce_123 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_123 = happySpecReduce_1 50# happyReduction_123 -happyReduction_123 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn66 - (sL1 happy_var_1 (Just (glAA happy_var_1)) - )} - -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 - (noLoc Nothing - ) - -happyReduce_125 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_125 = happySpecReduce_2 51# happyReduction_125 -happyReduction_125 happy_x_2 - happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut316 happy_x_2 of { (HappyWrap316 happy_var_2) -> - happyIn67 - ((Just (glAA happy_var_1) - ,sLL happy_var_1 (reLoc happy_var_2) (Just happy_var_2)) - )}} - -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,noLoc Nothing) - ) - -happyReduce_127 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_127 = happyMonadReduce 1# 52# happyReduction_127 -happyReduction_127 (happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut69 happy_x_1 of { (HappyWrap69 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 (happyIn68 r)) - -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 - (noLoc Nothing - ) - -happyReduce_129 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_129 = happyMonadReduce 3# 53# happyReduction_129 -happyReduction_129 (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 -> - ( 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 (happyIn69 r)) - -happyReduce_130 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_130 = happyMonadReduce 4# 53# happyReduction_130 -happyReduction_130 (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 happyOut49 happy_x_3 of { (HappyWrap49 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 (happyIn69 r)) - -happyReduce_131 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_131 = happySpecReduce_0 54# happyReduction_131 -happyReduction_131 = happyIn70 - (Nothing - ) - -happyReduce_132 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_132 = happySpecReduce_1 54# happyReduction_132 -happyReduction_132 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn70 - (Just (sL1 happy_var_1 (getINTEGERs happy_var_1,fromInteger (il_value (getINTEGER happy_var_1)))) - )} - -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 happyOutTok happy_x_1 of { happy_var_1 -> - happyIn71 - (sL1 happy_var_1 InfixN - )} - -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 happyOutTok happy_x_1 of { happy_var_1 -> - happyIn71 - (sL1 happy_var_1 InfixL - )} - -happyReduce_135 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_135 = happySpecReduce_1 55# happyReduction_135 -happyReduction_135 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn71 - (sL1 happy_var_1 InfixR - )} - -happyReduce_136 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_136 = happyMonadReduce 3# 56# happyReduction_136 -happyReduction_136 (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 happyOut288 happy_x_3 of { (HappyWrap288 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 (happyIn72 r)) - -happyReduce_137 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_137 = happySpecReduce_1 56# happyReduction_137 -happyReduction_137 happy_x_1 - = case happyOut288 happy_x_1 of { (HappyWrap288 happy_var_1) -> - happyIn72 - (sL1N happy_var_1 (unitOL happy_var_1) - )} - -happyReduce_138 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_138 = happySpecReduce_2 57# happyReduction_138 -happyReduction_138 happy_x_2 - happy_x_1 - = case happyOut74 happy_x_1 of { (HappyWrap74 happy_var_1) -> - case happyOut78 happy_x_2 of { (HappyWrap78 happy_var_2) -> - happyIn73 - (happy_var_1 `snocOL` happy_var_2 - )}} - -happyReduce_139 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_139 = happyMonadReduce 3# 58# happyReduction_139 -happyReduction_139 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut74 happy_x_1 of { (HappyWrap74 happy_var_1) -> - case happyOut78 happy_x_2 of { (HappyWrap78 happy_var_2) -> - case happyOut58 happy_x_3 of { (HappyWrap58 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 (happyIn74 r)) - -happyReduce_140 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_140 = happySpecReduce_0 58# happyReduction_140 -happyReduction_140 = happyIn74 - (nilOL - ) - -happyReduce_141 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_141 = happySpecReduce_2 59# happyReduction_141 -happyReduction_141 happy_x_2 - happy_x_1 - = case happyOut76 happy_x_1 of { (HappyWrap76 happy_var_1) -> - case happyOut77 happy_x_2 of { (HappyWrap77 happy_var_2) -> - happyIn75 - (happy_var_1 `snocOL` happy_var_2 - )}} - -happyReduce_142 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_142 = happyMonadReduce 3# 60# happyReduction_142 -happyReduction_142 (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 happyOut77 happy_x_2 of { (HappyWrap77 happy_var_2) -> - case happyOut58 happy_x_3 of { (HappyWrap58 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 (happyIn76 r)) - -happyReduce_143 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_143 = happySpecReduce_0 60# happyReduction_143 -happyReduction_143 = happyIn76 - (nilOL - ) - -happyReduce_144 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_144 = happyMonadReduce 1# 61# happyReduction_144 -happyReduction_144 (happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut78 happy_x_1 of { (HappyWrap78 happy_var_1) -> - ( commentsPA happy_var_1)}) - ) (\r -> happyReturn (happyIn77 r)) - -happyReduce_145 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_145 = happySpecReduce_1 62# happyReduction_145 -happyReduction_145 happy_x_1 - = case happyOut79 happy_x_1 of { (HappyWrap79 happy_var_1) -> - happyIn78 - (sL1 happy_var_1 (TyClD noExtField (unLoc happy_var_1)) - )} - -happyReduce_146 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_146 = happySpecReduce_1 62# happyReduction_146 -happyReduction_146 happy_x_1 - = case happyOut80 happy_x_1 of { (HappyWrap80 happy_var_1) -> - happyIn78 - (sL1 happy_var_1 (TyClD noExtField (unLoc happy_var_1)) - )} - -happyReduce_147 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_147 = happySpecReduce_1 62# happyReduction_147 -happyReduction_147 happy_x_1 - = case happyOut81 happy_x_1 of { (HappyWrap81 happy_var_1) -> - happyIn78 - (sL1 happy_var_1 (KindSigD noExtField (unLoc happy_var_1)) - )} - -happyReduce_148 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_148 = happySpecReduce_1 62# happyReduction_148 -happyReduction_148 happy_x_1 - = case happyOut83 happy_x_1 of { (HappyWrap83 happy_var_1) -> - happyIn78 - (sL1 happy_var_1 (InstD noExtField (unLoc happy_var_1)) - )} - -happyReduce_149 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_149 = happySpecReduce_1 62# happyReduction_149 -happyReduction_149 happy_x_1 - = case happyOut108 happy_x_1 of { (HappyWrap108 happy_var_1) -> - happyIn78 - (sL1 happy_var_1 (DerivD noExtField (unLoc happy_var_1)) - )} - -happyReduce_150 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_150 = happySpecReduce_1 62# happyReduction_150 -happyReduction_150 happy_x_1 - = case happyOut109 happy_x_1 of { (HappyWrap109 happy_var_1) -> - happyIn78 - (sL1 happy_var_1 (RoleAnnotD noExtField (unLoc happy_var_1)) - )} - -happyReduce_151 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_151 = happyMonadReduce 4# 62# happyReduction_151 -happyReduction_151 (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 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 (happyIn78 r)) - -happyReduce_152 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_152 = happyMonadReduce 2# 62# happyReduction_152 -happyReduction_152 (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) -> - ( 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 (happyIn78 r)) - -happyReduce_153 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_153 = happyMonadReduce 3# 62# happyReduction_153 -happyReduction_153 (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 -> - ( 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 (happyIn78 r)) - -happyReduce_154 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_154 = happyMonadReduce 3# 62# happyReduction_154 -happyReduction_154 (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 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 (happyIn78 r)) - -happyReduce_155 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_155 = happyMonadReduce 3# 62# happyReduction_155 -happyReduction_155 (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_2 of { (HappyWrap132 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 (happyIn78 r)) - -happyReduce_156 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_156 = happySpecReduce_1 62# happyReduction_156 -happyReduction_156 happy_x_1 - = case happyOut146 happy_x_1 of { (HappyWrap146 happy_var_1) -> - happyIn78 - (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 62# happyReduction_157 -happyReduction_157 happy_x_1 - = case happyOut198 happy_x_1 of { (HappyWrap198 happy_var_1) -> - happyIn78 - (happy_var_1 - )} - -happyReduce_158 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_158 = happyMonadReduce 1# 62# happyReduction_158 -happyReduction_158 (happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut208 happy_x_1 of { (HappyWrap208 happy_var_1) -> - ( runPV (unECP happy_var_1) >>= \ happy_var_1 -> - do { d <- mkSpliceDecl happy_var_1 - ; commentsPA d })}) - ) (\r -> happyReturn (happyIn78 r)) - -happyReduce_159 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_159 = happyMonadReduce 4# 63# happyReduction_159 -happyReduction_159 (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 happyOut105 happy_x_2 of { (HappyWrap105 happy_var_2) -> - case happyOut178 happy_x_3 of { (HappyWrap178 happy_var_3) -> - case happyOut123 happy_x_4 of { (HappyWrap123 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 (happyIn79 r)) - -happyReduce_160 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_160 = happyMonadReduce 4# 64# happyReduction_160 -happyReduction_160 (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 happyOut162 happy_x_2 of { (HappyWrap162 happy_var_2) -> - case happyOutTok happy_x_3 of { happy_var_3 -> - case happyOut159 happy_x_4 of { (HappyWrap159 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 (happyIn80 r)) - -happyReduce_161 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_161 = happyMonadReduce 6# 64# happyReduction_161 -happyReduction_161 (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 happyOut162 happy_x_3 of { (HappyWrap162 happy_var_3) -> - case happyOut103 happy_x_4 of { (HappyWrap103 happy_var_4) -> - case happyOut88 happy_x_5 of { (HappyWrap88 happy_var_5) -> - case happyOut91 happy_x_6 of { (HappyWrap91 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 (happyIn80 r)) - -happyReduce_162 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_162 = happyMonadReduce 5# 64# happyReduction_162 -happyReduction_162 (happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - 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 happyOut107 happy_x_2 of { (HappyWrap107 happy_var_2) -> - case happyOut105 happy_x_3 of { (HappyWrap105 happy_var_3) -> - case happyOut186 happy_x_4 of { (HappyWrap186 happy_var_4) -> - case happyOut194 happy_x_5 of { (HappyWrap194 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 (happyIn80 r)) - -happyReduce_163 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_163 = happyMonadReduce 6# 64# happyReduction_163 -happyReduction_163 (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 happyOut99 happy_x_1 of { (HappyWrap99 happy_var_1) -> - case happyOut107 happy_x_2 of { (HappyWrap107 happy_var_2) -> - case happyOut105 happy_x_3 of { (HappyWrap105 happy_var_3) -> - case happyOut101 happy_x_4 of { (HappyWrap101 happy_var_4) -> - case happyOut183 happy_x_5 of { (HappyWrap183 happy_var_5) -> - case happyOut194 happy_x_6 of { (HappyWrap194 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 (happyIn80 r)) - -happyReduce_164 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_164 = happyMonadReduce 4# 64# happyReduction_164 -happyReduction_164 (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 happyOut162 happy_x_3 of { (HappyWrap162 happy_var_3) -> - case happyOut102 happy_x_4 of { (HappyWrap102 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 (happyIn80 r)) - -happyReduce_165 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_165 = happyMonadReduce 4# 65# happyReduction_165 -happyReduction_165 (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 happyOut82 happy_x_2 of { (HappyWrap82 happy_var_2) -> - case happyOutTok happy_x_3 of { happy_var_3 -> - case happyOut153 happy_x_4 of { (HappyWrap153 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 (happyIn81 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 happyOut82 happy_x_1 of { (HappyWrap82 happy_var_1) -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut280 happy_x_3 of { (HappyWrap280 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 (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 happyOut280 happy_x_1 of { (HappyWrap280 happy_var_1) -> - happyIn82 - (sL1N happy_var_1 [happy_var_1] - )} - -happyReduce_168 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_168 = happyMonadReduce 4# 67# happyReduction_168 -happyReduction_168 (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 happyOut84 happy_x_2 of { (HappyWrap84 happy_var_2) -> - case happyOut170 happy_x_3 of { (HappyWrap170 happy_var_3) -> - case happyOut127 happy_x_4 of { (HappyWrap127 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 (happyIn83 r)) - -happyReduce_169 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_169 = happyMonadReduce 3# 67# happyReduction_169 -happyReduction_169 (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 happyOut94 happy_x_3 of { (HappyWrap94 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 (happyIn83 r)) - -happyReduce_170 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_170 = happyMonadReduce 6# 67# happyReduction_170 -happyReduction_170 (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 happyOut100 happy_x_1 of { (HappyWrap100 happy_var_1) -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut107 happy_x_3 of { (HappyWrap107 happy_var_3) -> - case happyOut106 happy_x_4 of { (HappyWrap106 happy_var_4) -> - case happyOut186 happy_x_5 of { (HappyWrap186 happy_var_5) -> - case happyOut194 happy_x_6 of { (HappyWrap194 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 (happyIn83 r)) - -happyReduce_171 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_171 = happyMonadReduce 7# 67# happyReduction_171 -happyReduction_171 (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 happyOut100 happy_x_1 of { (HappyWrap100 happy_var_1) -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut107 happy_x_3 of { (HappyWrap107 happy_var_3) -> - case happyOut106 happy_x_4 of { (HappyWrap106 happy_var_4) -> - case happyOut101 happy_x_5 of { (HappyWrap101 happy_var_5) -> - case happyOut183 happy_x_6 of { (HappyWrap183 happy_var_6) -> - case happyOut194 happy_x_7 of { (HappyWrap194 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 (happyIn83 r)) - -happyReduce_172 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_172 = happyMonadReduce 2# 68# happyReduction_172 -happyReduction_172 (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 (happyIn84 r)) - -happyReduce_173 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_173 = happyMonadReduce 2# 68# happyReduction_173 -happyReduction_173 (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 (happyIn84 r)) - -happyReduce_174 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_174 = happyMonadReduce 2# 68# happyReduction_174 -happyReduction_174 (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 (happyIn84 r)) - -happyReduce_175 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_175 = happyMonadReduce 2# 68# happyReduction_175 -happyReduction_175 (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 (happyIn84 r)) - -happyReduce_176 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_176 = happySpecReduce_0 68# happyReduction_176 -happyReduction_176 = happyIn84 - (Nothing - ) - -happyReduce_177 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_177 = happyMonadReduce 1# 69# happyReduction_177 -happyReduction_177 (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 (happyIn85 r)) - -happyReduce_178 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_178 = happyMonadReduce 1# 69# happyReduction_178 -happyReduction_178 (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 (happyIn85 r)) - -happyReduce_179 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_179 = happyMonadReduce 1# 69# happyReduction_179 -happyReduction_179 (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 (happyIn85 r)) - -happyReduce_180 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_180 = happyMonadReduce 2# 70# happyReduction_180 -happyReduction_180 (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) -> - ( 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 (happyIn86 r)) - -happyReduce_181 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_181 = happyMonadReduce 1# 71# happyReduction_181 -happyReduction_181 (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 (happyIn87 r)) - -happyReduce_182 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_182 = happyMonadReduce 1# 71# happyReduction_182 -happyReduction_182 (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 (happyIn87 r)) - -happyReduce_183 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_183 = happyMonadReduce 1# 71# happyReduction_183 -happyReduction_183 (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 (happyIn87 r)) - -happyReduce_184 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_184 = happySpecReduce_1 71# happyReduction_184 -happyReduction_184 happy_x_1 - = case happyOut86 happy_x_1 of { (HappyWrap86 happy_var_1) -> - happyIn87 - (Just happy_var_1 - )} - -happyReduce_185 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_185 = happySpecReduce_0 71# happyReduction_185 -happyReduction_185 = happyIn87 - (Nothing - ) - -happyReduce_186 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_186 = happySpecReduce_0 72# happyReduction_186 -happyReduction_186 = happyIn88 - (noLoc ([], Nothing) - ) - -happyReduce_187 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_187 = happySpecReduce_2 72# happyReduction_187 -happyReduction_187 happy_x_2 - happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut89 happy_x_2 of { (HappyWrap89 happy_var_2) -> - happyIn88 - (sLL happy_var_1 (reLoc happy_var_2) ([mj AnnVbar happy_var_1] - , Just (happy_var_2)) - )}} - -happyReduce_188 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_188 = happyMonadReduce 3# 73# happyReduction_188 -happyReduction_188 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut297 happy_x_1 of { (HappyWrap297 happy_var_1) -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut90 happy_x_3 of { (HappyWrap90 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 (happyIn89 r)) - -happyReduce_189 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_189 = happySpecReduce_2 74# happyReduction_189 -happyReduction_189 happy_x_2 - happy_x_1 - = case happyOut90 happy_x_1 of { (HappyWrap90 happy_var_1) -> - case happyOut297 happy_x_2 of { (HappyWrap297 happy_var_2) -> - happyIn90 - (sLL happy_var_1 (reLocN happy_var_2) (happy_var_2 : unLoc happy_var_1) - )}} - -happyReduce_190 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_190 = happySpecReduce_1 74# happyReduction_190 -happyReduction_190 happy_x_1 - = case happyOut297 happy_x_1 of { (HappyWrap297 happy_var_1) -> - happyIn90 - (sL1N happy_var_1 [happy_var_1] - )} - -happyReduce_191 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_191 = happySpecReduce_0 75# happyReduction_191 -happyReduction_191 = happyIn91 - (noLoc ([],OpenTypeFamily) - ) - -happyReduce_192 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_192 = happySpecReduce_2 75# happyReduction_192 -happyReduction_192 happy_x_2 - happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut92 happy_x_2 of { (HappyWrap92 happy_var_2) -> - happyIn91 - (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_193 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_193 = happySpecReduce_3 76# happyReduction_193 -happyReduction_193 happy_x_3 - 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) -> - case happyOutTok happy_x_3 of { happy_var_3 -> - happyIn92 - (sLL happy_var_1 happy_var_3 ([moc happy_var_1,mcc happy_var_3] - ,Just (unLoc happy_var_2)) - )}}} - -happyReduce_194 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_194 = happySpecReduce_3 76# happyReduction_194 -happyReduction_194 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut93 happy_x_2 of { (HappyWrap93 happy_var_2) -> - happyIn92 - (let (L loc _) = happy_var_2 in - L loc ([],Just (unLoc happy_var_2)) - )} - -happyReduce_195 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_195 = happySpecReduce_3 76# happyReduction_195 -happyReduction_195 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 -> - happyIn92 - (sLL happy_var_1 happy_var_3 ([moc happy_var_1,mj AnnDotdot happy_var_2 - ,mcc happy_var_3],Nothing) - )}}} - -happyReduce_196 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_196 = happySpecReduce_3 76# happyReduction_196 -happyReduction_196 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOutTok happy_x_2 of { happy_var_2 -> - happyIn92 - (let (L loc _) = happy_var_2 in - L loc ([mj AnnDotdot happy_var_2],Nothing) - )} - -happyReduce_197 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_197 = happyMonadReduce 3# 77# happyReduction_197 -happyReduction_197 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut93 happy_x_1 of { (HappyWrap93 happy_var_1) -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut94 happy_x_3 of { (HappyWrap94 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 (happyIn93 r)) - -happyReduce_198 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_198 = happyMonadReduce 2# 77# happyReduction_198 -happyReduction_198 (happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut93 happy_x_1 of { (HappyWrap93 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 (happyIn93 r)) - -happyReduce_199 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_199 = happySpecReduce_1 77# happyReduction_199 -happyReduction_199 happy_x_1 - = case happyOut94 happy_x_1 of { (HappyWrap94 happy_var_1) -> - happyIn93 - (sLLAA happy_var_1 happy_var_1 [happy_var_1] - )} - -happyReduce_200 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_200 = happySpecReduce_0 77# happyReduction_200 -happyReduction_200 = happyIn93 - (noLoc [] - ) - -happyReduce_201 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_201 = happyMonadReduce 6# 78# happyReduction_201 -happyReduction_201 (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 happyOut175 happy_x_2 of { (HappyWrap175 happy_var_2) -> - case happyOutTok happy_x_3 of { happy_var_3 -> - case happyOut162 happy_x_4 of { (HappyWrap162 happy_var_4) -> - case happyOutTok happy_x_5 of { happy_var_5 -> - case happyOut159 happy_x_6 of { (HappyWrap159 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 (happyIn94 r)) - -happyReduce_202 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_202 = happyMonadReduce 3# 78# happyReduction_202 -happyReduction_202 (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 happyOut159 happy_x_3 of { (HappyWrap159 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 (happyIn94 r)) - -happyReduce_203 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_203 = happyMonadReduce 4# 79# happyReduction_203 -happyReduction_203 (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 happyOut96 happy_x_2 of { (HappyWrap96 happy_var_2) -> - case happyOut162 happy_x_3 of { (HappyWrap162 happy_var_3) -> - case happyOut102 happy_x_4 of { (HappyWrap102 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 (happyIn95 r)) - -happyReduce_204 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_204 = happyMonadReduce 3# 79# happyReduction_204 -happyReduction_204 (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 happyOut162 happy_x_2 of { (HappyWrap162 happy_var_2) -> - case happyOut104 happy_x_3 of { (HappyWrap104 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 (happyIn95 r)) - -happyReduce_205 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_205 = happyMonadReduce 4# 79# happyReduction_205 -happyReduction_205 (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 happyOut162 happy_x_3 of { (HappyWrap162 happy_var_3) -> - case happyOut104 happy_x_4 of { (HappyWrap104 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 (happyIn95 r)) - -happyReduce_206 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_206 = happyMonadReduce 2# 79# happyReduction_206 -happyReduction_206 (happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut94 happy_x_2 of { (HappyWrap94 happy_var_2) -> - ( liftM mkInstD (mkTyFamInst (comb2A happy_var_1 happy_var_2) (unLoc happy_var_2) - [mj AnnType happy_var_1]))}}) - ) (\r -> happyReturn (happyIn95 r)) - -happyReduce_207 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_207 = happyMonadReduce 3# 79# happyReduction_207 -happyReduction_207 (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 happyOut94 happy_x_3 of { (HappyWrap94 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 (happyIn95 r)) - -happyReduce_208 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_208 = happySpecReduce_0 80# happyReduction_208 -happyReduction_208 = happyIn96 - ([] - ) - -happyReduce_209 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_209 = happySpecReduce_1 80# happyReduction_209 -happyReduction_209 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn96 - ([mj AnnFamily happy_var_1] - )} - -happyReduce_210 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_210 = happySpecReduce_0 81# happyReduction_210 -happyReduction_210 = happyIn97 - ([] - ) - -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 happyOutTok happy_x_1 of { happy_var_1 -> - happyIn97 - ([mj AnnInstance happy_var_1] - )} - -happyReduce_212 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_212 = happyMonadReduce 3# 82# happyReduction_212 -happyReduction_212 (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 happyOut97 happy_x_2 of { (HappyWrap97 happy_var_2) -> - case happyOut94 happy_x_3 of { (HappyWrap94 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 (happyIn98 r)) - -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 happyOut100 happy_x_1 of { (HappyWrap100 happy_var_1) -> - case happyOut97 happy_x_2 of { (HappyWrap97 happy_var_2) -> - case happyOut107 happy_x_3 of { (HappyWrap107 happy_var_3) -> - case happyOut106 happy_x_4 of { (HappyWrap106 happy_var_4) -> - case happyOut186 happy_x_5 of { (HappyWrap186 happy_var_5) -> - case happyOut194 happy_x_6 of { (HappyWrap194 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 (happyIn98 r)) - -happyReduce_214 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_214 = happyMonadReduce 7# 82# happyReduction_214 -happyReduction_214 (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 happyOut100 happy_x_1 of { (HappyWrap100 happy_var_1) -> - case happyOut97 happy_x_2 of { (HappyWrap97 happy_var_2) -> - case happyOut107 happy_x_3 of { (HappyWrap107 happy_var_3) -> - case happyOut106 happy_x_4 of { (HappyWrap106 happy_var_4) -> - case happyOut101 happy_x_5 of { (HappyWrap101 happy_var_5) -> - case happyOut183 happy_x_6 of { (HappyWrap183 happy_var_6) -> - case happyOut194 happy_x_7 of { (HappyWrap194 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 (happyIn98 r)) - -happyReduce_215 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_215 = happySpecReduce_1 83# happyReduction_215 -happyReduction_215 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn99 - (sL1 happy_var_1 ([mj AnnData happy_var_1], False,DataType) - )} - -happyReduce_216 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_216 = happySpecReduce_1 83# happyReduction_216 -happyReduction_216 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn99 - (sL1 happy_var_1 ([mj AnnNewtype happy_var_1], False,NewType) - )} - -happyReduce_217 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_217 = happySpecReduce_2 83# happyReduction_217 -happyReduction_217 happy_x_2 - happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOutTok happy_x_2 of { happy_var_2 -> - happyIn99 - (sL1 happy_var_1 ([mj AnnType happy_var_1, mj AnnData happy_var_2],True ,DataType) - )}} - -happyReduce_218 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_218 = happySpecReduce_1 84# happyReduction_218 -happyReduction_218 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn100 - (sL1 happy_var_1 (mj AnnData happy_var_1,DataType) - )} - -happyReduce_219 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_219 = happySpecReduce_1 84# happyReduction_219 -happyReduction_219 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn100 - (sL1 happy_var_1 (mj AnnNewtype happy_var_1,NewType) - )} - -happyReduce_220 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_220 = happySpecReduce_0 85# happyReduction_220 -happyReduction_220 = happyIn101 - (noLoc ([] , Nothing) - ) - -happyReduce_221 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_221 = happySpecReduce_2 85# happyReduction_221 -happyReduction_221 happy_x_2 - happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut182 happy_x_2 of { (HappyWrap182 happy_var_2) -> - happyIn101 - (sLL happy_var_1 (reLoc happy_var_2) ([mu AnnDcolon happy_var_1], Just happy_var_2) - )}} - -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 - (noLoc ([] , noLocA (NoSig noExtField) ) - ) - -happyReduce_223 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_223 = happySpecReduce_2 86# happyReduction_223 -happyReduction_223 happy_x_2 - happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut182 happy_x_2 of { (HappyWrap182 happy_var_2) -> - happyIn102 - (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_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 - (noLoc ([] , noLocA (NoSig noExtField) ) - ) - -happyReduce_225 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_225 = happySpecReduce_2 87# happyReduction_225 -happyReduction_225 happy_x_2 - happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut182 happy_x_2 of { (HappyWrap182 happy_var_2) -> - happyIn103 - (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_226 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_226 = happyMonadReduce 2# 87# happyReduction_226 -happyReduction_226 (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) -> - ( 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 (happyIn103 r)) - -happyReduce_227 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_227 = happySpecReduce_0 88# happyReduction_227 -happyReduction_227 = happyIn104 - (noLoc ([], (noLocA (NoSig noExtField), Nothing)) - ) - -happyReduce_228 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_228 = happySpecReduce_2 88# happyReduction_228 -happyReduction_228 happy_x_2 - happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut182 happy_x_2 of { (HappyWrap182 happy_var_2) -> - happyIn104 - (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_229 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_229 = happyMonadReduce 4# 88# happyReduction_229 -happyReduction_229 (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 happyOut177 happy_x_2 of { (HappyWrap177 happy_var_2) -> - case happyOutTok happy_x_3 of { happy_var_3 -> - case happyOut89 happy_x_4 of { (HappyWrap89 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 (happyIn104 r)) - -happyReduce_230 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_230 = happyMonadReduce 3# 89# happyReduction_230 -happyReduction_230 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut161 happy_x_1 of { (HappyWrap161 happy_var_1) -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut162 happy_x_3 of { (HappyWrap162 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 (happyIn105 r)) - -happyReduce_231 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_231 = happySpecReduce_1 89# happyReduction_231 -happyReduction_231 happy_x_1 - = case happyOut162 happy_x_1 of { (HappyWrap162 happy_var_1) -> - happyIn105 - (sL1A happy_var_1 (Nothing, happy_var_1) - )} - -happyReduce_232 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_232 = happyMonadReduce 6# 90# happyReduction_232 -happyReduction_232 (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 happyOut175 happy_x_2 of { (HappyWrap175 happy_var_2) -> - case happyOutTok happy_x_3 of { happy_var_3 -> - case happyOut161 happy_x_4 of { (HappyWrap161 happy_var_4) -> - case happyOutTok happy_x_5 of { happy_var_5 -> - case happyOut162 happy_x_6 of { (HappyWrap162 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 (happyIn106 r)) - -happyReduce_233 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_233 = happyMonadReduce 4# 90# happyReduction_233 -happyReduction_233 (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 happyOut175 happy_x_2 of { (HappyWrap175 happy_var_2) -> - case happyOutTok happy_x_3 of { happy_var_3 -> - case happyOut162 happy_x_4 of { (HappyWrap162 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 (happyIn106 r)) - -happyReduce_234 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_234 = happyMonadReduce 3# 90# happyReduction_234 -happyReduction_234 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut161 happy_x_1 of { (HappyWrap161 happy_var_1) -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut162 happy_x_3 of { (HappyWrap162 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 (happyIn106 r)) - -happyReduce_235 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_235 = happySpecReduce_1 90# happyReduction_235 -happyReduction_235 happy_x_1 - = case happyOut162 happy_x_1 of { (HappyWrap162 happy_var_1) -> - happyIn106 - (sL1A happy_var_1 (Nothing, mkHsOuterImplicit, happy_var_1) - )} - -happyReduce_236 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_236 = happyMonadReduce 4# 91# happyReduction_236 -happyReduction_236 (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 (happyIn107 r)) - -happyReduce_237 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_237 = happyMonadReduce 3# 91# happyReduction_237 -happyReduction_237 (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 (happyIn107 r)) - -happyReduce_238 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_238 = happySpecReduce_0 91# happyReduction_238 -happyReduction_238 = happyIn107 - (Nothing - ) - -happyReduce_239 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_239 = happyMonadReduce 5# 92# happyReduction_239 -happyReduction_239 (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 happyOut87 happy_x_2 of { (HappyWrap87 happy_var_2) -> - case happyOutTok happy_x_3 of { happy_var_3 -> - case happyOut84 happy_x_4 of { (HappyWrap84 happy_var_4) -> - case happyOut170 happy_x_5 of { (HappyWrap170 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 (happyIn108 r)) - -happyReduce_240 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_240 = happyMonadReduce 4# 93# happyReduction_240 -happyReduction_240 (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 happyOut280 happy_x_3 of { (HappyWrap280 happy_var_3) -> - case happyOut110 happy_x_4 of { (HappyWrap110 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 (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 [] - ) - -happyReduce_242 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_242 = happySpecReduce_1 94# happyReduction_242 -happyReduction_242 happy_x_1 - = case happyOut111 happy_x_1 of { (HappyWrap111 happy_var_1) -> - happyIn110 - (happy_var_1 - )} - -happyReduce_243 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_243 = happySpecReduce_1 95# happyReduction_243 -happyReduction_243 happy_x_1 - = case happyOut112 happy_x_1 of { (HappyWrap112 happy_var_1) -> - happyIn111 - (sLL happy_var_1 happy_var_1 [happy_var_1] - )} - -happyReduce_244 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_244 = happySpecReduce_2 95# happyReduction_244 -happyReduction_244 happy_x_2 - happy_x_1 - = case happyOut111 happy_x_1 of { (HappyWrap111 happy_var_1) -> - case happyOut112 happy_x_2 of { (HappyWrap112 happy_var_2) -> - happyIn111 - (sLL happy_var_1 happy_var_2 $ happy_var_2 : unLoc happy_var_1 - )}} - -happyReduce_245 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_245 = happySpecReduce_1 96# happyReduction_245 -happyReduction_245 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn112 - (sL1 happy_var_1 $ Just $ getVARID happy_var_1 - )} - -happyReduce_246 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_246 = happySpecReduce_1 96# happyReduction_246 -happyReduction_246 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn112 - (sL1 happy_var_1 Nothing - )} - -happyReduce_247 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_247 = happyMonadReduce 4# 97# 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 happyOut114 happy_x_2 of { (HappyWrap114 happy_var_2) -> - case happyOutTok happy_x_3 of { happy_var_3 -> - case happyOut242 happy_x_4 of { (HappyWrap242 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 (happyIn113 r)) - -happyReduce_248 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_248 = happyMonadReduce 4# 97# 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 happyOut114 happy_x_2 of { (HappyWrap114 happy_var_2) -> - case happyOutTok happy_x_3 of { happy_var_3 -> - case happyOut242 happy_x_4 of { (HappyWrap242 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 (happyIn113 r)) - -happyReduce_249 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_249 = happyMonadReduce 5# 97# happyReduction_249 -happyReduction_249 (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 happyOut114 happy_x_2 of { (HappyWrap114 happy_var_2) -> - case happyOutTok happy_x_3 of { happy_var_3 -> - case happyOut242 happy_x_4 of { (HappyWrap242 happy_var_4) -> - case happyOut117 happy_x_5 of { (HappyWrap117 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 (happyIn113 r)) - -happyReduce_250 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_250 = happySpecReduce_2 98# happyReduction_250 -happyReduction_250 happy_x_2 - happy_x_1 - = case happyOut271 happy_x_1 of { (HappyWrap271 happy_var_1) -> - case happyOut115 happy_x_2 of { (HappyWrap115 happy_var_2) -> - happyIn114 - ((happy_var_1, PrefixCon noTypeArgs happy_var_2, []) - )}} - -happyReduce_251 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_251 = happySpecReduce_3 98# happyReduction_251 -happyReduction_251 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut302 happy_x_1 of { (HappyWrap302 happy_var_1) -> - case happyOut276 happy_x_2 of { (HappyWrap276 happy_var_2) -> - case happyOut302 happy_x_3 of { (HappyWrap302 happy_var_3) -> - happyIn114 - ((happy_var_2, InfixCon happy_var_1 happy_var_3, []) - )}}} - -happyReduce_252 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_252 = happyReduce 4# 98# happyReduction_252 -happyReduction_252 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut271 happy_x_1 of { (HappyWrap271 happy_var_1) -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut116 happy_x_3 of { (HappyWrap116 happy_var_3) -> - case happyOutTok happy_x_4 of { happy_var_4 -> - happyIn114 - ((happy_var_1, RecCon happy_var_3, [moc happy_var_2, mcc happy_var_4] ) - ) `HappyStk` happyRest}}}} - -happyReduce_253 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_253 = happySpecReduce_0 99# happyReduction_253 -happyReduction_253 = happyIn115 - ([] - ) - -happyReduce_254 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_254 = happySpecReduce_2 99# happyReduction_254 -happyReduction_254 happy_x_2 - happy_x_1 - = case happyOut302 happy_x_1 of { (HappyWrap302 happy_var_1) -> - case happyOut115 happy_x_2 of { (HappyWrap115 happy_var_2) -> - happyIn115 - (happy_var_1 : happy_var_2 - )}} - -happyReduce_255 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_255 = happySpecReduce_1 100# happyReduction_255 -happyReduction_255 happy_x_1 - = case happyOut298 happy_x_1 of { (HappyWrap298 happy_var_1) -> - happyIn116 - ([RecordPatSynField (mkFieldOcc 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 = happyMonadReduce 3# 100# happyReduction_256 -happyReduction_256 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut298 happy_x_1 of { (HappyWrap298 happy_var_1) -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut116 happy_x_3 of { (HappyWrap116 happy_var_3) -> - ( do { h <- addTrailingCommaN happy_var_1 (gl happy_var_2) - ; return ((RecordPatSynField (mkFieldOcc h) h) : happy_var_3 )})}}}) - ) (\r -> happyReturn (happyIn116 r)) - -happyReduce_257 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_257 = happyMonadReduce 4# 101# happyReduction_257 -happyReduction_257 (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 happyOut128 happy_x_3 of { (HappyWrap128 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 (happyIn117 r)) - -happyReduce_258 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_258 = happyMonadReduce 4# 101# happyReduction_258 -happyReduction_258 (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 happyOut128 happy_x_3 of { (HappyWrap128 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 (happyIn117 r)) - -happyReduce_259 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_259 = happyMonadReduce 4# 102# 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 happyOut272 happy_x_2 of { (HappyWrap272 happy_var_2) -> - case happyOutTok happy_x_3 of { happy_var_3 -> - case happyOut154 happy_x_4 of { (HappyWrap154 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 (happyIn118 r)) - -happyReduce_260 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_260 = happySpecReduce_1 103# happyReduction_260 -happyReduction_260 happy_x_1 - = case happyOut299 happy_x_1 of { (HappyWrap299 happy_var_1) -> - happyIn119 - (happy_var_1 - )} - -happyReduce_261 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_261 = happySpecReduce_1 103# happyReduction_261 -happyReduction_261 happy_x_1 - = case happyOut269 happy_x_1 of { (HappyWrap269 happy_var_1) -> - happyIn119 - (happy_var_1 - )} - -happyReduce_262 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_262 = happySpecReduce_1 104# happyReduction_262 -happyReduction_262 happy_x_1 - = case happyOut95 happy_x_1 of { (HappyWrap95 happy_var_1) -> - happyIn120 - (happy_var_1 - )} - -happyReduce_263 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_263 = happySpecReduce_1 104# happyReduction_263 -happyReduction_263 happy_x_1 - = case happyOut199 happy_x_1 of { (HappyWrap199 happy_var_1) -> - happyIn120 - (happy_var_1 - )} - -happyReduce_264 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_264 = happyMonadReduce 4# 104# happyReduction_264 -happyReduction_264 (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 happyOut208 happy_x_2 of { (HappyWrap208 happy_var_2) -> - case happyOutTok happy_x_3 of { happy_var_3 -> - case happyOut154 happy_x_4 of { (HappyWrap154 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 (happyIn120 r)) - -happyReduce_265 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_265 = happyMonadReduce 3# 105# happyReduction_265 -happyReduction_265 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut121 happy_x_1 of { (HappyWrap121 happy_var_1) -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut120 happy_x_3 of { (HappyWrap120 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 (happyIn121 r)) - -happyReduce_266 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_266 = happyMonadReduce 2# 105# happyReduction_266 -happyReduction_266 (happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut121 happy_x_1 of { (HappyWrap121 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 (happyIn121 r)) - -happyReduce_267 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_267 = happySpecReduce_1 105# happyReduction_267 -happyReduction_267 happy_x_1 - = case happyOut120 happy_x_1 of { (HappyWrap120 happy_var_1) -> - happyIn121 - (sL1A happy_var_1 ([], unitOL happy_var_1) - )} - -happyReduce_268 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_268 = happySpecReduce_0 105# happyReduction_268 -happyReduction_268 = happyIn121 - (noLoc ([],nilOL) - ) - -happyReduce_269 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_269 = happySpecReduce_3 106# happyReduction_269 -happyReduction_269 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut121 happy_x_2 of { (HappyWrap121 happy_var_2) -> - case happyOutTok happy_x_3 of { happy_var_3 -> - happyIn122 - (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_270 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_270 = happySpecReduce_3 106# happyReduction_270 -happyReduction_270 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut121 happy_x_2 of { (HappyWrap121 happy_var_2) -> - happyIn122 - (let { L l (anns, decls) = happy_var_2 } - in L l (anns, decls, VirtualBraces (getVOCURLY happy_var_1)) - )}} - -happyReduce_271 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_271 = happySpecReduce_2 107# happyReduction_271 -happyReduction_271 happy_x_2 - happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut122 happy_x_2 of { (HappyWrap122 happy_var_2) -> - happyIn123 - (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_272 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_272 = happySpecReduce_0 107# happyReduction_272 -happyReduction_272 = happyIn123 - (noLoc ([],nilOL,NoLayoutInfo) - ) - -happyReduce_273 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_273 = happySpecReduce_1 108# happyReduction_273 -happyReduction_273 happy_x_1 - = case happyOut98 happy_x_1 of { (HappyWrap98 happy_var_1) -> - happyIn124 - (sL1A happy_var_1 (unitOL (sL1 happy_var_1 (InstD noExtField (unLoc 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 happyOut199 happy_x_1 of { (HappyWrap199 happy_var_1) -> - happyIn124 - (sL1A happy_var_1 (unitOL happy_var_1) - )} - -happyReduce_275 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_275 = happyMonadReduce 3# 109# happyReduction_275 -happyReduction_275 (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 (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 (happyIn125 r)) - -happyReduce_276 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_276 = happyMonadReduce 2# 109# happyReduction_276 -happyReduction_276 (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_277 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_277 = happySpecReduce_1 109# happyReduction_277 -happyReduction_277 happy_x_1 - = case happyOut124 happy_x_1 of { (HappyWrap124 happy_var_1) -> - happyIn125 - (sL1 happy_var_1 ([],unLoc happy_var_1) - )} - -happyReduce_278 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_278 = happySpecReduce_0 109# happyReduction_278 -happyReduction_278 = happyIn125 - (noLoc ([],nilOL) - ) - -happyReduce_279 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_279 = happySpecReduce_3 110# happyReduction_279 -happyReduction_279 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) - )}}} - -happyReduce_280 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_280 = happySpecReduce_3 110# happyReduction_280 -happyReduction_280 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut125 happy_x_2 of { (HappyWrap125 happy_var_2) -> - happyIn126 - (L (gl happy_var_2) (unLoc happy_var_2) - )} - -happyReduce_281 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_281 = happySpecReduce_2 111# happyReduction_281 -happyReduction_281 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:(fst $ unLoc happy_var_2) - ,(snd $ unLoc happy_var_2)) - )}} - -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 = happyMonadReduce 3# 112# happyReduction_283 -happyReduction_283 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut128 happy_x_1 of { (HappyWrap128 happy_var_1) -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut199 happy_x_3 of { (HappyWrap199 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 (happyIn128 r)) - -happyReduce_284 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_284 = happyMonadReduce 2# 112# happyReduction_284 -happyReduction_284 (happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut128 happy_x_1 of { (HappyWrap128 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 (happyIn128 r)) - -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 happyOut199 happy_x_1 of { (HappyWrap199 happy_var_1) -> - happyIn128 - (sL1A happy_var_1 ([], unitOL happy_var_1) - )} - -happyReduce_286 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_286 = happySpecReduce_0 112# happyReduction_286 -happyReduction_286 = happyIn128 - (noLoc ([],nilOL) - ) - -happyReduce_287 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_287 = happySpecReduce_3 113# happyReduction_287 -happyReduction_287 happy_x_3 - 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) -> - case happyOutTok happy_x_3 of { happy_var_3 -> - happyIn129 - (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_288 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_288 = happySpecReduce_3 113# happyReduction_288 -happyReduction_288 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut128 happy_x_2 of { (HappyWrap128 happy_var_2) -> - happyIn129 - (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_289 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_289 = happyMonadReduce 1# 114# happyReduction_289 -happyReduction_289 (happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut129 happy_x_1 of { (HappyWrap129 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 (happyIn130 r)) - -happyReduce_290 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_290 = happyMonadReduce 3# 114# happyReduction_290 -happyReduction_290 (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 happyOut257 happy_x_2 of { (HappyWrap257 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 (happyIn130 r)) - -happyReduce_291 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_291 = happyMonadReduce 3# 114# happyReduction_291 -happyReduction_291 (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 happyOut257 happy_x_2 of { (HappyWrap257 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 (happyIn130 r)) - -happyReduce_292 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_292 = happyMonadReduce 2# 115# happyReduction_292 -happyReduction_292 (happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut130 happy_x_2 of { (HappyWrap130 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 (happyIn131 r)) - -happyReduce_293 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_293 = happySpecReduce_0 115# happyReduction_293 -happyReduction_293 = happyIn131 - (Nothing - ) - -happyReduce_294 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_294 = happyMonadReduce 3# 116# happyReduction_294 -happyReduction_294 (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 happyOut133 happy_x_3 of { (HappyWrap133 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 (happyIn132 r)) - -happyReduce_295 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_295 = happyMonadReduce 2# 116# happyReduction_295 -happyReduction_295 (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 happy_var_1 of - [] -> return happy_var_1 - (h:t) -> do - h' <- addTrailingSemiA h (gl happy_var_2) - return (h':t))}}) - ) (\r -> happyReturn (happyIn132 r)) - -happyReduce_296 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_296 = happySpecReduce_1 116# happyReduction_296 -happyReduction_296 happy_x_1 - = case happyOut133 happy_x_1 of { (HappyWrap133 happy_var_1) -> - happyIn132 - ([happy_var_1] - )} - -happyReduce_297 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_297 = happySpecReduce_0 116# happyReduction_297 -happyReduction_297 = happyIn132 - ([] - ) - -happyReduce_298 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_298 = happyMonadReduce 6# 117# happyReduction_298 -happyReduction_298 (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 happyOut134 happy_x_2 of { (HappyWrap134 happy_var_2) -> - case happyOut137 happy_x_3 of { (HappyWrap137 happy_var_3) -> - case happyOut208 happy_x_4 of { (HappyWrap208 happy_var_4) -> - case happyOutTok happy_x_5 of { happy_var_5 -> - case happyOut207 happy_x_6 of { (HappyWrap207 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 (happyIn133 r)) - -happyReduce_299 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_299 = happySpecReduce_0 118# happyReduction_299 -happyReduction_299 = happyIn134 - (([],Nothing) - ) - -happyReduce_300 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_300 = happySpecReduce_1 118# happyReduction_300 -happyReduction_300 happy_x_1 - = case happyOut136 happy_x_1 of { (HappyWrap136 happy_var_1) -> - happyIn134 - ((fst happy_var_1,Just (snd happy_var_1)) - )} - -happyReduce_301 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_301 = happySpecReduce_1 119# happyReduction_301 -happyReduction_301 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn135 - ([mj AnnTilde happy_var_1] - )} - -happyReduce_302 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_302 = happyMonadReduce 1# 119# happyReduction_302 -happyReduction_302 (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 (happyIn135 r)) - -happyReduce_303 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_303 = happySpecReduce_3 120# happyReduction_303 -happyReduction_303 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 -> - happyIn136 - (([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_304 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_304 = happyReduce 4# 120# happyReduction_304 -happyReduction_304 (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 happyOut135 happy_x_2 of { (HappyWrap135 happy_var_2) -> - case happyOutTok happy_x_3 of { happy_var_3 -> - case happyOutTok happy_x_4 of { happy_var_4 -> - happyIn136 - ((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_305 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_305 = happySpecReduce_3 120# happyReduction_305 -happyReduction_305 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut135 happy_x_2 of { (HappyWrap135 happy_var_2) -> - case happyOutTok happy_x_3 of { happy_var_3 -> - happyIn136 - ((happy_var_2++[mos happy_var_1,mcs happy_var_3] - ,NeverActive) - )}}} - -happyReduce_306 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_306 = happyMonadReduce 6# 121# happyReduction_306 -happyReduction_306 (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 happyOutTok happy_x_3 of { happy_var_3 -> - case happyOutTok happy_x_4 of { happy_var_4 -> - case happyOut138 happy_x_5 of { (HappyWrap138 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 (happyIn137 r)) - -happyReduce_307 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_307 = happySpecReduce_3 121# happyReduction_307 -happyReduction_307 happy_x_3 - happy_x_2 - happy_x_1 - = 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 -> - happyIn137 - ((\anns -> HsRuleAnn Nothing (Just (mu AnnForall happy_var_1,mj AnnDot happy_var_3)) anns, - Nothing, mkRuleBndrs happy_var_2) - )}}} - -happyReduce_308 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_308 = happySpecReduce_0 121# happyReduction_308 -happyReduction_308 = happyIn137 - ((\anns -> HsRuleAnn Nothing Nothing anns, Nothing, []) - ) - -happyReduce_309 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_309 = happySpecReduce_2 122# happyReduction_309 -happyReduction_309 happy_x_2 - happy_x_1 - = case happyOut139 happy_x_1 of { (HappyWrap139 happy_var_1) -> - case happyOut138 happy_x_2 of { (HappyWrap138 happy_var_2) -> - happyIn138 - (happy_var_1 : happy_var_2 - )}} - -happyReduce_310 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_310 = happySpecReduce_0 122# happyReduction_310 -happyReduction_310 = happyIn138 - ([] - ) - -happyReduce_311 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_311 = happySpecReduce_1 123# happyReduction_311 -happyReduction_311 happy_x_1 - = case happyOut302 happy_x_1 of { (HappyWrap302 happy_var_1) -> - happyIn139 - (sL1l happy_var_1 (RuleTyTmVar noAnn happy_var_1 Nothing) - )} - -happyReduce_312 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_312 = happyMonadReduce 5# 123# happyReduction_312 -happyReduction_312 (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 happyOut302 happy_x_2 of { (HappyWrap302 happy_var_2) -> - case happyOutTok happy_x_3 of { happy_var_3 -> - case happyOut160 happy_x_4 of { (HappyWrap160 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 (happyIn139 r)) - -happyReduce_313 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_313 = happyMonadReduce 3# 124# happyReduction_313 -happyReduction_313 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut140 happy_x_1 of { (HappyWrap140 happy_var_1) -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut141 happy_x_3 of { (HappyWrap141 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 (happyIn140 r)) - -happyReduce_314 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_314 = happyMonadReduce 2# 124# happyReduction_314 -happyReduction_314 (happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut140 happy_x_1 of { (HappyWrap140 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 (happyIn140 r)) - -happyReduce_315 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_315 = happySpecReduce_1 124# happyReduction_315 -happyReduction_315 happy_x_1 - = case happyOut141 happy_x_1 of { (HappyWrap141 happy_var_1) -> - happyIn140 - (happy_var_1 - )} - -happyReduce_316 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_316 = happySpecReduce_0 124# happyReduction_316 -happyReduction_316 = happyIn140 - (nilOL - ) - -happyReduce_317 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_317 = happyMonadReduce 2# 125# happyReduction_317 -happyReduction_317 (happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut266 happy_x_1 of { (HappyWrap266 happy_var_1) -> - case happyOut144 happy_x_2 of { (HappyWrap144 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) - (WarningTxt (noLoc NoSourceText) $ map stringLiteralToHsDocWst $ snd $ unLoc happy_var_2))))}}) - ) (\r -> happyReturn (happyIn141 r)) - -happyReduce_318 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_318 = happyMonadReduce 3# 126# happyReduction_318 -happyReduction_318 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut142 happy_x_1 of { (HappyWrap142 happy_var_1) -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut143 happy_x_3 of { (HappyWrap143 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 (happyIn142 r)) - -happyReduce_319 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_319 = happyMonadReduce 2# 126# happyReduction_319 -happyReduction_319 (happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut142 happy_x_1 of { (HappyWrap142 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 (happyIn142 r)) - -happyReduce_320 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_320 = happySpecReduce_1 126# happyReduction_320 -happyReduction_320 happy_x_1 - = case happyOut143 happy_x_1 of { (HappyWrap143 happy_var_1) -> - happyIn142 - (happy_var_1 - )} - -happyReduce_321 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_321 = happySpecReduce_0 126# happyReduction_321 -happyReduction_321 = happyIn142 - (nilOL - ) - -happyReduce_322 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_322 = happyMonadReduce 2# 127# happyReduction_322 -happyReduction_322 (happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut266 happy_x_1 of { (HappyWrap266 happy_var_1) -> - case happyOut144 happy_x_2 of { (HappyWrap144 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 (happyIn143 r)) - -happyReduce_323 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_323 = happySpecReduce_1 128# happyReduction_323 -happyReduction_323 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn144 - (sL1 happy_var_1 ([],[L (gl happy_var_1) (getStringLiteral happy_var_1)]) - )} - -happyReduce_324 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_324 = happySpecReduce_3 128# happyReduction_324 -happyReduction_324 happy_x_3 - happy_x_2 - happy_x_1 - = 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 -> - happyIn144 - (sLL happy_var_1 happy_var_3 $ ([mos happy_var_1,mcs happy_var_3],fromOL (unLoc happy_var_2)) - )}}} - -happyReduce_325 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_325 = happyMonadReduce 3# 129# happyReduction_325 -happyReduction_325 (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 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 (happyIn145 r)) - -happyReduce_326 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_326 = happySpecReduce_1 129# happyReduction_326 -happyReduction_326 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn145 - (sLL happy_var_1 happy_var_1 (unitOL (L (gl happy_var_1) (getStringLiteral happy_var_1))) - )} - -happyReduce_327 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_327 = happySpecReduce_0 129# happyReduction_327 -happyReduction_327 = happyIn145 - (noLoc nilOL - ) - -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 happyOut267 happy_x_2 of { (HappyWrap267 happy_var_2) -> - case happyOut214 happy_x_3 of { (HappyWrap214 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 (happyIn146 r)) - -happyReduce_329 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_329 = happyMonadReduce 5# 130# happyReduction_329 -happyReduction_329 (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 happyOut287 happy_x_3 of { (HappyWrap287 happy_var_3) -> - case happyOut214 happy_x_4 of { (HappyWrap214 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 (happyIn146 r)) - -happyReduce_330 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_330 = happyMonadReduce 4# 130# happyReduction_330 -happyReduction_330 (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 happyOut214 happy_x_3 of { (HappyWrap214 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 (happyIn146 r)) - -happyReduce_331 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_331 = happyMonadReduce 4# 131# happyReduction_331 -happyReduction_331 (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 happyOut148 happy_x_2 of { (HappyWrap148 happy_var_2) -> - case happyOut149 happy_x_3 of { (HappyWrap149 happy_var_3) -> - case happyOut150 happy_x_4 of { (HappyWrap150 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 (happyIn147 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 happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut148 happy_x_2 of { (HappyWrap148 happy_var_2) -> - case happyOut150 happy_x_3 of { (HappyWrap150 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 (happyIn147 r)) - -happyReduce_333 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_333 = happyMonadReduce 3# 131# happyReduction_333 -happyReduction_333 (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 happyOut150 happy_x_3 of { (HappyWrap150 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 (happyIn147 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 happyOutTok happy_x_1 of { happy_var_1 -> - happyIn148 - (sLL happy_var_1 happy_var_1 StdCallConv - )} - -happyReduce_335 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_335 = happySpecReduce_1 132# happyReduction_335 -happyReduction_335 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn148 - (sLL happy_var_1 happy_var_1 CCallConv - )} - -happyReduce_336 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_336 = happySpecReduce_1 132# happyReduction_336 -happyReduction_336 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn148 - (sLL happy_var_1 happy_var_1 CApiConv - )} - -happyReduce_337 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_337 = happySpecReduce_1 132# happyReduction_337 -happyReduction_337 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn148 - (sLL happy_var_1 happy_var_1 PrimCallConv - )} - -happyReduce_338 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_338 = happySpecReduce_1 132# happyReduction_338 -happyReduction_338 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn148 - (sLL happy_var_1 happy_var_1 JavaScriptCallConv - )} - -happyReduce_339 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_339 = happySpecReduce_1 133# happyReduction_339 -happyReduction_339 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn149 - (sLL happy_var_1 happy_var_1 PlayRisky - )} - -happyReduce_340 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_340 = happySpecReduce_1 133# happyReduction_340 -happyReduction_340 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn149 - (sLL happy_var_1 happy_var_1 PlaySafe - )} - -happyReduce_341 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_341 = happySpecReduce_1 133# happyReduction_341 -happyReduction_341 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn149 - (sLL happy_var_1 happy_var_1 PlayInterruptible - )} - -happyReduce_342 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_342 = happyReduce 4# 134# happyReduction_342 -happyReduction_342 (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 happyOut298 happy_x_2 of { (HappyWrap298 happy_var_2) -> - case happyOutTok happy_x_3 of { happy_var_3 -> - case happyOut154 happy_x_4 of { (HappyWrap154 happy_var_4) -> - happyIn150 - (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_343 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_343 = happySpecReduce_3 134# happyReduction_343 -happyReduction_343 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut298 happy_x_1 of { (HappyWrap298 happy_var_1) -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut154 happy_x_3 of { (HappyWrap154 happy_var_3) -> - happyIn150 - (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_344 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_344 = happySpecReduce_0 135# happyReduction_344 -happyReduction_344 = happyIn151 - (Nothing - ) - -happyReduce_345 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_345 = happySpecReduce_2 135# happyReduction_345 -happyReduction_345 happy_x_2 - happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut160 happy_x_2 of { (HappyWrap160 happy_var_2) -> - happyIn151 - (Just (mu AnnDcolon happy_var_1, happy_var_2) - )}} - -happyReduce_346 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_346 = happySpecReduce_0 136# happyReduction_346 -happyReduction_346 = happyIn152 - (([], Nothing) - ) - -happyReduce_347 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_347 = happySpecReduce_2 136# happyReduction_347 -happyReduction_347 happy_x_2 - happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut278 happy_x_2 of { (HappyWrap278 happy_var_2) -> - happyIn152 - (([mu AnnDcolon happy_var_1], Just happy_var_2) - )}} - -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 happyOut154 happy_x_1 of { (HappyWrap154 happy_var_1) -> - happyIn153 - (happy_var_1 - )} - -happyReduce_349 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_349 = happyMonadReduce 3# 137# happyReduction_349 -happyReduction_349 (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 happyOut182 happy_x_3 of { (HappyWrap182 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 (happyIn153 r)) - -happyReduce_350 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_350 = happySpecReduce_1 138# happyReduction_350 -happyReduction_350 happy_x_1 - = case happyOut160 happy_x_1 of { (HappyWrap160 happy_var_1) -> - happyIn154 - (hsTypeToHsSigType happy_var_1 - )} - -happyReduce_351 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_351 = happyMonadReduce 3# 139# happyReduction_351 -happyReduction_351 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut155 happy_x_1 of { (HappyWrap155 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 - [] -> 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 (happyIn155 r)) - -happyReduce_352 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_352 = happySpecReduce_1 139# happyReduction_352 -happyReduction_352 happy_x_1 - = case happyOut298 happy_x_1 of { (HappyWrap298 happy_var_1) -> - happyIn155 - (sL1N happy_var_1 [happy_var_1] - )} - -happyReduce_353 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_353 = happySpecReduce_1 140# happyReduction_353 -happyReduction_353 happy_x_1 - = case happyOut154 happy_x_1 of { (HappyWrap154 happy_var_1) -> - happyIn156 - (unitOL happy_var_1 - )} - -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 happyOut154 happy_x_1 of { (HappyWrap154 happy_var_1) -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut156 happy_x_3 of { (HappyWrap156 happy_var_3) -> - ( do { st <- addTrailingCommaA happy_var_1 (gl happy_var_2) - ; return $ unitOL st `appOL` happy_var_3 })}}}) - ) (\r -> happyReturn (happyIn156 r)) - -happyReduce_355 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_355 = happySpecReduce_2 141# happyReduction_355 -happyReduction_355 happy_x_2 - happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOutTok happy_x_2 of { happy_var_2 -> - happyIn157 - (sLL happy_var_1 happy_var_2 (UnpackednessPragma [mo happy_var_1, mc happy_var_2] (getUNPACK_PRAGs happy_var_1) SrcUnpack) - )}} - -happyReduce_356 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_356 = happySpecReduce_2 141# happyReduction_356 -happyReduction_356 happy_x_2 - happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOutTok happy_x_2 of { happy_var_2 -> - happyIn157 - (sLL happy_var_1 happy_var_2 (UnpackednessPragma [mo happy_var_1, mc happy_var_2] (getNOUNPACK_PRAGs happy_var_1) SrcNoUnpack) - )}} - -happyReduce_357 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_357 = happyMonadReduce 3# 142# happyReduction_357 -happyReduction_357 (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 happyOut175 happy_x_2 of { (HappyWrap175 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 (happyIn158 r)) - -happyReduce_358 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_358 = happyMonadReduce 3# 142# happyReduction_358 -happyReduction_358 (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 happyOut175 happy_x_2 of { (HappyWrap175 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 (happyIn158 r)) - -happyReduce_359 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_359 = happySpecReduce_1 143# happyReduction_359 -happyReduction_359 happy_x_1 - = case happyOut160 happy_x_1 of { (HappyWrap160 happy_var_1) -> - happyIn159 - (happy_var_1 - )} - -happyReduce_360 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_360 = happyMonadReduce 3# 143# happyReduction_360 -happyReduction_360 (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 happyOut182 happy_x_3 of { (HappyWrap182 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 (happyIn159 r)) - -happyReduce_361 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_361 = happySpecReduce_2 144# happyReduction_361 -happyReduction_361 happy_x_2 - happy_x_1 - = case happyOut158 happy_x_1 of { (HappyWrap158 happy_var_1) -> - case happyOut160 happy_x_2 of { (HappyWrap160 happy_var_2) -> - happyIn160 - (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_362 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_362 = happyMonadReduce 3# 144# happyReduction_362 -happyReduction_362 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut161 happy_x_1 of { (HappyWrap161 happy_var_1) -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut160 happy_x_3 of { (HappyWrap160 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 (happyIn160 r)) - -happyReduce_363 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_363 = happyMonadReduce 3# 144# happyReduction_363 -happyReduction_363 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut259 happy_x_1 of { (HappyWrap259 happy_var_1) -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut160 happy_x_3 of { (HappyWrap160 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 (happyIn160 r)) - -happyReduce_364 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_364 = happySpecReduce_1 144# happyReduction_364 -happyReduction_364 happy_x_1 - = case happyOut162 happy_x_1 of { (HappyWrap162 happy_var_1) -> - happyIn160 - (happy_var_1 - )} - -happyReduce_365 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_365 = happyMonadReduce 1# 145# happyReduction_365 -happyReduction_365 (happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut164 happy_x_1 of { (HappyWrap164 happy_var_1) -> - ( checkContext happy_var_1)}) - ) (\r -> happyReturn (happyIn161 r)) - -happyReduce_366 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_366 = happySpecReduce_1 146# happyReduction_366 -happyReduction_366 happy_x_1 - = case happyOut164 happy_x_1 of { (HappyWrap164 happy_var_1) -> - happyIn162 - (happy_var_1 - )} - -happyReduce_367 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_367 = happyMonadReduce 3# 146# happyReduction_367 -happyReduction_367 (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 happyOut160 happy_x_3 of { (HappyWrap160 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 (happyIn162 r)) - -happyReduce_368 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_368 = happyMonadReduce 4# 146# happyReduction_368 -happyReduction_368 (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 happyOut163 happy_x_2 of { (HappyWrap163 happy_var_2) -> - case happyOutTok happy_x_3 of { happy_var_3 -> - case happyOut160 happy_x_4 of { (HappyWrap160 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 (happyIn162 r)) - -happyReduce_369 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_369 = happyMonadReduce 3# 146# happyReduction_369 -happyReduction_369 (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 happyOut160 happy_x_3 of { (HappyWrap160 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 (happyIn162 r)) - -happyReduce_370 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_370 = happySpecReduce_2 147# happyReduction_370 -happyReduction_370 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) -> - happyIn163 - (sLL happy_var_1 (reLoc happy_var_2) (mkMultTy (hsTok happy_var_1) happy_var_2) - )}} - -happyReduce_371 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_371 = happyMonadReduce 1# 148# happyReduction_371 -happyReduction_371 (happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut165 happy_x_1 of { (HappyWrap165 happy_var_1) -> - ( runPV happy_var_1)}) - ) (\r -> happyReturn (happyIn164 r)) - -happyReduce_372 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_372 = happySpecReduce_1 149# happyReduction_372 -happyReduction_372 happy_x_1 - = case happyOut166 happy_x_1 of { (HappyWrap166 happy_var_1) -> - happyIn165 - (happy_var_1 - )} - -happyReduce_373 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_373 = happySpecReduce_3 149# happyReduction_373 -happyReduction_373 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut166 happy_x_1 of { (HappyWrap166 happy_var_1) -> - case happyOut168 happy_x_2 of { (HappyWrap168 happy_var_2) -> - case happyOut165 happy_x_3 of { (HappyWrap165 happy_var_3) -> - happyIn165 - (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_374 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_374 = happySpecReduce_2 149# happyReduction_374 -happyReduction_374 happy_x_2 - happy_x_1 - = case happyOut157 happy_x_1 of { (HappyWrap157 happy_var_1) -> - case happyOut165 happy_x_2 of { (HappyWrap165 happy_var_2) -> - happyIn165 - (happy_var_2 >>= \ happy_var_2 -> - mkUnpackednessPV happy_var_1 happy_var_2 - )}} - -happyReduce_375 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_375 = happySpecReduce_1 150# happyReduction_375 -happyReduction_375 happy_x_1 - = case happyOut169 happy_x_1 of { (HappyWrap169 happy_var_1) -> - happyIn166 - (mkHsAppTyHeadPV 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 150# happyReduction_376 -happyReduction_376 happy_x_1 - = case happyOut168 happy_x_1 of { (HappyWrap168 happy_var_1) -> - happyIn166 - (failOpFewArgs (fst happy_var_1) - )} - -happyReduce_377 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_377 = happySpecReduce_2 150# happyReduction_377 -happyReduction_377 happy_x_2 - happy_x_1 - = case happyOut166 happy_x_1 of { (HappyWrap166 happy_var_1) -> - case happyOut167 happy_x_2 of { (HappyWrap167 happy_var_2) -> - happyIn166 - (happy_var_1 >>= \ happy_var_1 -> - mkHsAppTyPV happy_var_1 happy_var_2 - )}} - -happyReduce_378 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_378 = happySpecReduce_3 150# happyReduction_378 -happyReduction_378 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut166 happy_x_1 of { (HappyWrap166 happy_var_1) -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut169 happy_x_3 of { (HappyWrap169 happy_var_3) -> - happyIn166 - (happy_var_1 >>= \ happy_var_1 -> - mkHsAppKindTyPV happy_var_1 (getLoc happy_var_2) happy_var_3 - )}}} - -happyReduce_379 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_379 = happySpecReduce_1 151# happyReduction_379 -happyReduction_379 happy_x_1 - = case happyOut169 happy_x_1 of { (HappyWrap169 happy_var_1) -> - happyIn167 - (happy_var_1 - )} - -happyReduce_380 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_380 = happyMonadReduce 2# 151# happyReduction_380 -happyReduction_380 (happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut157 happy_x_1 of { (HappyWrap157 happy_var_1) -> - case happyOut169 happy_x_2 of { (HappyWrap169 happy_var_2) -> - ( addUnpackednessP happy_var_1 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 = happySpecReduce_1 152# happyReduction_381 -happyReduction_381 happy_x_1 - = case happyOut282 happy_x_1 of { (HappyWrap282 happy_var_1) -> - happyIn168 - ((happy_var_1, NotPromoted) - )} - -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 happyOut296 happy_x_1 of { (HappyWrap296 happy_var_1) -> - happyIn168 - ((happy_var_1, NotPromoted) - )} - -happyReduce_383 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_383 = happyMonadReduce 2# 152# happyReduction_383 -happyReduction_383 (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) -> - ( 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 (happyIn168 r)) - -happyReduce_384 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_384 = happyMonadReduce 2# 152# happyReduction_384 -happyReduction_384 (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) -> - ( 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 (happyIn168 r)) - -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 happyOut279 happy_x_1 of { (HappyWrap279 happy_var_1) -> - ( acsa (\cs -> sL1a (reLocN happy_var_1) (HsTyVar (EpAnn (glNR happy_var_1) [] cs) NotPromoted 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 = happyMonadReduce 1# 153# happyReduction_386 -happyReduction_386 (happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut295 happy_x_1 of { (HappyWrap295 happy_var_1) -> - ( acsa (\cs -> sL1a (reLocN happy_var_1) (HsTyVar (EpAnn (glNR happy_var_1) [] cs) NotPromoted happy_var_1)))}) - ) (\r -> happyReturn (happyIn169 r)) - -happyReduce_387 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_387 = happyMonadReduce 1# 153# happyReduction_387 -happyReduction_387 (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 (happyIn169 r)) - -happyReduce_388 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_388 = happyMonadReduce 2# 153# happyReduction_388 -happyReduction_388 (happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut169 happy_x_2 of { (HappyWrap169 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 (happyIn169 r)) - -happyReduce_389 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_389 = happyMonadReduce 2# 153# happyReduction_389 -happyReduction_389 (happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut169 happy_x_2 of { (HappyWrap169 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 (happyIn169 r)) - -happyReduce_390 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_390 = happyMonadReduce 3# 153# happyReduction_390 -happyReduction_390 (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 happyOut191 happy_x_2 of { (HappyWrap191 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 (happyIn169 r)) - -happyReduce_391 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_391 = happyMonadReduce 2# 153# happyReduction_391 -happyReduction_391 (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 (happyIn169 r)) - -happyReduce_392 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_392 = happyMonadReduce 5# 153# happyReduction_392 -happyReduction_392 (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 happyOut159 happy_x_2 of { (HappyWrap159 happy_var_2) -> - case happyOutTok happy_x_3 of { happy_var_3 -> - case happyOut173 happy_x_4 of { (HappyWrap173 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 (happyIn169 r)) - -happyReduce_393 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_393 = happyMonadReduce 2# 153# happyReduction_393 -happyReduction_393 (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 (happyIn169 r)) - -happyReduce_394 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_394 = happyMonadReduce 3# 153# happyReduction_394 -happyReduction_394 (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 happyOut173 happy_x_2 of { (HappyWrap173 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 (happyIn169 r)) - -happyReduce_395 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_395 = happyMonadReduce 3# 153# happyReduction_395 -happyReduction_395 (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 happyOut174 happy_x_2 of { (HappyWrap174 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 (happyIn169 r)) - -happyReduce_396 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_396 = happyMonadReduce 3# 153# happyReduction_396 -happyReduction_396 (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 happyOut159 happy_x_2 of { (HappyWrap159 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 (happyIn169 r)) - -happyReduce_397 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_397 = happyMonadReduce 3# 153# happyReduction_397 -happyReduction_397 (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 happyOut159 happy_x_2 of { (HappyWrap159 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 (happyIn169 r)) - -happyReduce_398 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_398 = happySpecReduce_1 153# happyReduction_398 -happyReduction_398 happy_x_1 - = case happyOut206 happy_x_1 of { (HappyWrap206 happy_var_1) -> - happyIn169 - (mapLocA (HsSpliceTy noExtField) happy_var_1 - )} - -happyReduce_399 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_399 = happySpecReduce_1 153# happyReduction_399 -happyReduction_399 happy_x_1 - = case happyOut219 happy_x_1 of { (HappyWrap219 happy_var_1) -> - happyIn169 - (mapLocA (HsSpliceTy noExtField) happy_var_1 - )} - -happyReduce_400 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_400 = happyMonadReduce 2# 153# happyReduction_400 -happyReduction_400 (happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut268 happy_x_2 of { (HappyWrap268 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 (happyIn169 r)) - -happyReduce_401 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_401 = happyMonadReduce 6# 153# happyReduction_401 -happyReduction_401 (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 happyOut159 happy_x_3 of { (HappyWrap159 happy_var_3) -> - case happyOutTok happy_x_4 of { happy_var_4 -> - case happyOut173 happy_x_5 of { (HappyWrap173 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 (happyIn169 r)) - -happyReduce_402 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_402 = happyMonadReduce 4# 153# happyReduction_402 -happyReduction_402 (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 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 (happyIn169 r)) - -happyReduce_403 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_403 = happyMonadReduce 2# 153# 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 happyOut298 happy_x_2 of { (HappyWrap298 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 (happyIn169 r)) - -happyReduce_404 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_404 = happyMonadReduce 5# 153# happyReduction_404 -happyReduction_404 (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 happyOut159 happy_x_2 of { (HappyWrap159 happy_var_2) -> - case happyOutTok happy_x_3 of { happy_var_3 -> - case happyOut173 happy_x_4 of { (HappyWrap173 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 (happyIn169 r)) - -happyReduce_405 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_405 = happySpecReduce_1 153# happyReduction_405 -happyReduction_405 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn169 - (reLocA $ sLL happy_var_1 happy_var_1 $ HsTyLit noExtField $ HsNumTy (getINTEGERs happy_var_1) - (il_value (getINTEGER happy_var_1)) - )} - -happyReduce_406 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_406 = happySpecReduce_1 153# happyReduction_406 -happyReduction_406 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn169 - (reLocA $ sLL happy_var_1 happy_var_1 $ HsTyLit noExtField $ HsCharTy (getCHARs happy_var_1) - (getCHAR happy_var_1) - )} - -happyReduce_407 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_407 = happySpecReduce_1 153# happyReduction_407 -happyReduction_407 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn169 - (reLocA $ sLL happy_var_1 happy_var_1 $ HsTyLit noExtField $ HsStrTy (getSTRINGs happy_var_1) - (getSTRING happy_var_1) - )} - -happyReduce_408 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_408 = happySpecReduce_1 153# happyReduction_408 -happyReduction_408 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn169 - (reLocA $ sL1 happy_var_1 $ mkAnonWildCardTy - )} - -happyReduce_409 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_409 = happySpecReduce_1 154# happyReduction_409 -happyReduction_409 happy_x_1 - = case happyOut154 happy_x_1 of { (HappyWrap154 happy_var_1) -> - happyIn170 - (happy_var_1 - )} - -happyReduce_410 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_410 = happySpecReduce_1 155# happyReduction_410 -happyReduction_410 happy_x_1 - = case happyOut153 happy_x_1 of { (HappyWrap153 happy_var_1) -> - happyIn171 - ([happy_var_1] - )} - -happyReduce_411 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_411 = happyMonadReduce 3# 155# happyReduction_411 -happyReduction_411 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut153 happy_x_1 of { (HappyWrap153 happy_var_1) -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut171 happy_x_3 of { (HappyWrap171 happy_var_3) -> - ( do { h <- addTrailingCommaA happy_var_1 (gl happy_var_2) - ; return (h : happy_var_3) })}}}) - ) (\r -> happyReturn (happyIn171 r)) - -happyReduce_412 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_412 = happySpecReduce_1 156# happyReduction_412 -happyReduction_412 happy_x_1 - = case happyOut173 happy_x_1 of { (HappyWrap173 happy_var_1) -> - happyIn172 - (happy_var_1 - )} - -happyReduce_413 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_413 = happySpecReduce_0 156# happyReduction_413 -happyReduction_413 = happyIn172 - ([] - ) - -happyReduce_414 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_414 = happySpecReduce_1 157# happyReduction_414 -happyReduction_414 happy_x_1 - = case happyOut159 happy_x_1 of { (HappyWrap159 happy_var_1) -> - happyIn173 - ([happy_var_1] - )} - -happyReduce_415 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_415 = happyMonadReduce 3# 157# happyReduction_415 -happyReduction_415 (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 happyOut173 happy_x_3 of { (HappyWrap173 happy_var_3) -> - ( do { h <- addTrailingCommaA happy_var_1 (gl happy_var_2) - ; return (h : happy_var_3) })}}}) - ) (\r -> happyReturn (happyIn173 r)) - -happyReduce_416 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_416 = happyMonadReduce 3# 158# happyReduction_416 -happyReduction_416 (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 happyOut159 happy_x_3 of { (HappyWrap159 happy_var_3) -> - ( do { h <- addTrailingVbarA happy_var_1 (gl happy_var_2) - ; return [h,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 3# 158# happyReduction_417 -happyReduction_417 (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 happyOut174 happy_x_3 of { (HappyWrap174 happy_var_3) -> - ( do { h <- addTrailingVbarA happy_var_1 (gl happy_var_2) - ; return (h : happy_var_3) })}}}) - ) (\r -> happyReturn (happyIn174 r)) - -happyReduce_418 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_418 = happySpecReduce_2 159# happyReduction_418 -happyReduction_418 happy_x_2 - happy_x_1 - = case happyOut176 happy_x_1 of { (HappyWrap176 happy_var_1) -> - case happyOut175 happy_x_2 of { (HappyWrap175 happy_var_2) -> - happyIn175 - (happy_var_1 : happy_var_2 - )}} - -happyReduce_419 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_419 = happySpecReduce_0 159# happyReduction_419 -happyReduction_419 = happyIn175 - ([] - ) - -happyReduce_420 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_420 = happySpecReduce_1 160# happyReduction_420 -happyReduction_420 happy_x_1 - = case happyOut177 happy_x_1 of { (HappyWrap177 happy_var_1) -> - happyIn176 - (happy_var_1 - )} - -happyReduce_421 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_421 = happyMonadReduce 3# 160# 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 happyOut295 happy_x_2 of { (HappyWrap295 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 (happyIn176 r)) - -happyReduce_422 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_422 = happyMonadReduce 5# 160# happyReduction_422 -happyReduction_422 (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 happyOut295 happy_x_2 of { (HappyWrap295 happy_var_2) -> - case happyOutTok happy_x_3 of { happy_var_3 -> - case happyOut182 happy_x_4 of { (HappyWrap182 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 (happyIn176 r)) - -happyReduce_423 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_423 = happyMonadReduce 1# 161# happyReduction_423 -happyReduction_423 (happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut295 happy_x_1 of { (HappyWrap295 happy_var_1) -> - ( acsA (\cs -> (sL1 (reLocN happy_var_1) (UserTyVar (EpAnn (glNR happy_var_1) [] cs) SpecifiedSpec happy_var_1))))}) - ) (\r -> happyReturn (happyIn177 r)) - -happyReduce_424 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_424 = happyMonadReduce 5# 161# happyReduction_424 -happyReduction_424 (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 happyOut295 happy_x_2 of { (HappyWrap295 happy_var_2) -> - case happyOutTok happy_x_3 of { happy_var_3 -> - case happyOut182 happy_x_4 of { (HappyWrap182 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 (happyIn177 r)) - -happyReduce_425 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_425 = happySpecReduce_0 162# happyReduction_425 -happyReduction_425 = happyIn178 - (noLoc ([],[]) - ) - -happyReduce_426 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_426 = happySpecReduce_2 162# happyReduction_426 -happyReduction_426 happy_x_2 - happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut179 happy_x_2 of { (HappyWrap179 happy_var_2) -> - happyIn178 - ((sLL happy_var_1 happy_var_2 ([mj AnnVbar happy_var_1] - ,reverse (unLoc happy_var_2))) - )}} - -happyReduce_427 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_427 = happyMonadReduce 3# 163# happyReduction_427 -happyReduction_427 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut179 happy_x_1 of { (HappyWrap179 happy_var_1) -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut180 happy_x_3 of { (HappyWrap180 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 (happyIn179 r)) - -happyReduce_428 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_428 = happySpecReduce_1 163# happyReduction_428 -happyReduction_428 happy_x_1 - = case happyOut180 happy_x_1 of { (HappyWrap180 happy_var_1) -> - happyIn179 - (sL1A happy_var_1 [happy_var_1] - )} - -happyReduce_429 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_429 = happyMonadReduce 3# 164# happyReduction_429 -happyReduction_429 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut181 happy_x_1 of { (HappyWrap181 happy_var_1) -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut181 happy_x_3 of { (HappyWrap181 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 (happyIn180 r)) - -happyReduce_430 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_430 = happySpecReduce_0 165# happyReduction_430 -happyReduction_430 = happyIn181 - (noLoc [] - ) - -happyReduce_431 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_431 = happySpecReduce_2 165# happyReduction_431 -happyReduction_431 happy_x_2 - happy_x_1 - = case happyOut181 happy_x_1 of { (HappyWrap181 happy_var_1) -> - case happyOut295 happy_x_2 of { (HappyWrap295 happy_var_2) -> - happyIn181 - (sLL happy_var_1 (reLocN happy_var_2) (happy_var_2 : (unLoc 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 166# happyReduction_432 -happyReduction_432 happy_x_1 - = case happyOut160 happy_x_1 of { (HappyWrap160 happy_var_1) -> - happyIn182 - (happy_var_1 - )} - -happyReduce_433 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_433 = happyMonadReduce 4# 167# happyReduction_433 -happyReduction_433 (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 happyOut184 happy_x_3 of { (HappyWrap184 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 (happyIn183 r)) - -happyReduce_434 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_434 = happyMonadReduce 4# 167# happyReduction_434 -happyReduction_434 (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 happyOut184 happy_x_3 of { (HappyWrap184 happy_var_3) -> - ( checkEmptyGADTs $ - L (comb2 happy_var_1 happy_var_3) - ([mj AnnWhere happy_var_1] - , unLoc happy_var_3))}}) - ) (\r -> happyReturn (happyIn183 r)) - -happyReduce_435 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_435 = happySpecReduce_0 167# happyReduction_435 -happyReduction_435 = happyIn183 - (noLoc ([],[]) - ) - -happyReduce_436 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_436 = happyMonadReduce 3# 168# happyReduction_436 -happyReduction_436 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut185 happy_x_1 of { (HappyWrap185 happy_var_1) -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut184 happy_x_3 of { (HappyWrap184 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 (happyIn184 r)) - -happyReduce_437 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_437 = happySpecReduce_1 168# happyReduction_437 -happyReduction_437 happy_x_1 - = case happyOut185 happy_x_1 of { (HappyWrap185 happy_var_1) -> - happyIn184 - (L (glA happy_var_1) [happy_var_1] - )} - -happyReduce_438 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_438 = happySpecReduce_0 168# happyReduction_438 -happyReduction_438 = happyIn184 - (noLoc [] - ) - -happyReduce_439 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_439 = happyMonadReduce 4# 169# happyReduction_439 -happyReduction_439 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut272 happy_x_2 of { (HappyWrap272 happy_var_2) -> - case happyOutTok happy_x_3 of { happy_var_3 -> - case happyOut154 happy_x_4 of { (HappyWrap154 happy_var_4) -> - ( mkGadtDecl (comb2A happy_var_2 happy_var_4) (unLoc happy_var_2) (hsUniTok happy_var_3) happy_var_4)}}}) - ) (\r -> happyReturn (happyIn185 r)) - -happyReduce_440 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_440 = happySpecReduce_2 170# happyReduction_440 -happyReduction_440 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) -> - happyIn186 - (sLL happy_var_1 happy_var_2 ([mj AnnEqual happy_var_1],unLoc happy_var_2) - )}} - -happyReduce_441 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_441 = happyMonadReduce 3# 171# happyReduction_441 -happyReduction_441 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut187 happy_x_1 of { (HappyWrap187 happy_var_1) -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut188 happy_x_3 of { (HappyWrap188 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 (happyIn187 r)) - -happyReduce_442 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_442 = happySpecReduce_1 171# happyReduction_442 -happyReduction_442 happy_x_1 - = case happyOut188 happy_x_1 of { (HappyWrap188 happy_var_1) -> - happyIn187 - (sL1A happy_var_1 [happy_var_1] - )} - -happyReduce_443 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_443 = happyMonadReduce 4# 172# happyReduction_443 -happyReduction_443 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut189 happy_x_1 of { (HappyWrap189 happy_var_1) -> - case happyOut161 happy_x_2 of { (HappyWrap161 happy_var_2) -> - case happyOutTok happy_x_3 of { happy_var_3 -> - case happyOut190 happy_x_4 of { (HappyWrap190 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 (happyIn188 r)) - -happyReduce_444 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_444 = happyMonadReduce 2# 172# happyReduction_444 -happyReduction_444 (happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut189 happy_x_1 of { (HappyWrap189 happy_var_1) -> - case happyOut190 happy_x_2 of { (HappyWrap190 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 (happyIn188 r)) - -happyReduce_445 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_445 = happySpecReduce_3 173# happyReduction_445 -happyReduction_445 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut175 happy_x_2 of { (HappyWrap175 happy_var_2) -> - case happyOutTok happy_x_3 of { happy_var_3 -> - happyIn189 - (sLL happy_var_1 happy_var_3 ([mu AnnForall happy_var_1,mj AnnDot happy_var_3], Just happy_var_2) - )}}} - -happyReduce_446 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_446 = happySpecReduce_0 173# happyReduction_446 -happyReduction_446 = happyIn189 - (noLoc ([], Nothing) - ) - -happyReduce_447 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_447 = happyMonadReduce 1# 174# happyReduction_447 -happyReduction_447 (happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut165 happy_x_1 of { (HappyWrap165 happy_var_1) -> - ( fmap (reLoc. (fmap (\b -> (dataConBuilderCon b, - dataConBuilderDetails b)))) - (runPV happy_var_1))}) - ) (\r -> happyReturn (happyIn190 r)) - -happyReduce_448 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_448 = happySpecReduce_0 175# happyReduction_448 -happyReduction_448 = happyIn191 - ([] - ) - -happyReduce_449 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_449 = happySpecReduce_1 175# happyReduction_449 -happyReduction_449 happy_x_1 - = case happyOut192 happy_x_1 of { (HappyWrap192 happy_var_1) -> - happyIn191 - (happy_var_1 - )} - -happyReduce_450 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_450 = happyMonadReduce 3# 176# happyReduction_450 -happyReduction_450 (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 happyOut192 happy_x_3 of { (HappyWrap192 happy_var_3) -> - ( do { h <- addTrailingCommaA happy_var_1 (gl happy_var_2) - ; return (h : happy_var_3) })}}}) - ) (\r -> happyReturn (happyIn192 r)) - -happyReduce_451 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_451 = happySpecReduce_1 176# happyReduction_451 -happyReduction_451 happy_x_1 - = case happyOut193 happy_x_1 of { (HappyWrap193 happy_var_1) -> - happyIn192 - ([happy_var_1] - )} - -happyReduce_452 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_452 = happyMonadReduce 3# 177# happyReduction_452 -happyReduction_452 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut155 happy_x_1 of { (HappyWrap155 happy_var_1) -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut160 happy_x_3 of { (HappyWrap160 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 (happyIn193 r)) - -happyReduce_453 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_453 = happySpecReduce_0 178# happyReduction_453 -happyReduction_453 = happyIn194 - (noLoc [] - ) - -happyReduce_454 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_454 = happySpecReduce_1 178# happyReduction_454 -happyReduction_454 happy_x_1 - = case happyOut195 happy_x_1 of { (HappyWrap195 happy_var_1) -> - happyIn194 - (happy_var_1 - )} - -happyReduce_455 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_455 = happySpecReduce_2 179# happyReduction_455 -happyReduction_455 happy_x_2 - happy_x_1 - = case happyOut195 happy_x_1 of { (HappyWrap195 happy_var_1) -> - case happyOut196 happy_x_2 of { (HappyWrap196 happy_var_2) -> - happyIn195 - (sLL happy_var_1 (reLoc happy_var_2) (happy_var_2 : unLoc 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 179# happyReduction_456 -happyReduction_456 happy_x_1 - = case happyOut196 happy_x_1 of { (HappyWrap196 happy_var_1) -> - happyIn195 - (sL1 (reLoc happy_var_1) [happy_var_1] - )} - -happyReduce_457 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_457 = happyMonadReduce 2# 180# happyReduction_457 -happyReduction_457 (happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut197 happy_x_2 of { (HappyWrap197 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 (happyIn196 r)) - -happyReduce_458 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_458 = happyMonadReduce 3# 180# happyReduction_458 -happyReduction_458 (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 happyOut85 happy_x_2 of { (HappyWrap85 happy_var_2) -> - case happyOut197 happy_x_3 of { (HappyWrap197 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 (happyIn196 r)) - -happyReduce_459 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_459 = happyMonadReduce 3# 180# happyReduction_459 -happyReduction_459 (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 happyOut197 happy_x_2 of { (HappyWrap197 happy_var_2) -> - case happyOut86 happy_x_3 of { (HappyWrap86 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 (happyIn196 r)) - -happyReduce_460 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_460 = happySpecReduce_1 181# happyReduction_460 -happyReduction_460 happy_x_1 - = case happyOut283 happy_x_1 of { (HappyWrap283 happy_var_1) -> - happyIn197 - (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_461 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_461 = happyMonadReduce 2# 181# happyReduction_461 -happyReduction_461 (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 (happyIn197 r)) - -happyReduce_462 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_462 = happyMonadReduce 3# 181# happyReduction_462 -happyReduction_462 (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 happyOut171 happy_x_2 of { (HappyWrap171 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 (happyIn197 r)) - -happyReduce_463 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_463 = happySpecReduce_1 182# happyReduction_463 -happyReduction_463 happy_x_1 - = case happyOut203 happy_x_1 of { (HappyWrap203 happy_var_1) -> - happyIn198 - (happy_var_1 - )} - -happyReduce_464 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_464 = happyMonadReduce 3# 182# happyReduction_464 -happyReduction_464 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut208 happy_x_1 of { (HappyWrap208 happy_var_1) -> - case happyOut151 happy_x_2 of { (HappyWrap151 happy_var_2) -> - case happyOut200 happy_x_3 of { (HappyWrap200 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 (happyIn198 r)) - -happyReduce_465 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_465 = happySpecReduce_1 182# happyReduction_465 -happyReduction_465 happy_x_1 - = case happyOut113 happy_x_1 of { (HappyWrap113 happy_var_1) -> - happyIn198 - (happy_var_1 - )} - -happyReduce_466 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_466 = happySpecReduce_1 183# happyReduction_466 -happyReduction_466 happy_x_1 - = case happyOut198 happy_x_1 of { (HappyWrap198 happy_var_1) -> - happyIn199 - (happy_var_1 - )} - -happyReduce_467 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_467 = happyMonadReduce 1# 183# happyReduction_467 -happyReduction_467 (happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut218 happy_x_1 of { (HappyWrap218 happy_var_1) -> - ( mkSpliceDecl happy_var_1)}) - ) (\r -> happyReturn (happyIn199 r)) - -happyReduce_468 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_468 = happyMonadReduce 3# 184# happyReduction_468 -happyReduction_468 (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 happyOut207 happy_x_2 of { (HappyWrap207 happy_var_2) -> - case happyOut131 happy_x_3 of { (HappyWrap131 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 (happyIn200 r)) - -happyReduce_469 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_469 = happyMonadReduce 2# 184# happyReduction_469 -happyReduction_469 (happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut201 happy_x_1 of { (HappyWrap201 happy_var_1) -> - case happyOut131 happy_x_2 of { (HappyWrap131 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 (happyIn200 r)) - -happyReduce_470 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_470 = happySpecReduce_2 185# happyReduction_470 -happyReduction_470 happy_x_2 - happy_x_1 - = case happyOut201 happy_x_1 of { (HappyWrap201 happy_var_1) -> - case happyOut202 happy_x_2 of { (HappyWrap202 happy_var_2) -> - happyIn201 - (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 185# happyReduction_471 -happyReduction_471 happy_x_1 - = case happyOut202 happy_x_1 of { (HappyWrap202 happy_var_1) -> - happyIn201 - (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 4# 186# happyReduction_472 -happyReduction_472 (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 happyOut235 happy_x_2 of { (HappyWrap235 happy_var_2) -> - case happyOutTok happy_x_3 of { happy_var_3 -> - case happyOut207 happy_x_4 of { (HappyWrap207 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 (happyIn202 r)) - -happyReduce_473 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_473 = happyMonadReduce 3# 187# happyReduction_473 -happyReduction_473 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut208 happy_x_1 of { (HappyWrap208 happy_var_1) -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut154 happy_x_3 of { (HappyWrap154 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 (happyIn203 r)) - -happyReduce_474 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_474 = happyMonadReduce 5# 187# happyReduction_474 -happyReduction_474 (happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut298 happy_x_1 of { (HappyWrap298 happy_var_1) -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut155 happy_x_3 of { (HappyWrap155 happy_var_3) -> - case happyOutTok happy_x_4 of { happy_var_4 -> - case happyOut154 happy_x_5 of { (HappyWrap154 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 (happyIn203 r)) - -happyReduce_475 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_475 = happyMonadReduce 3# 187# happyReduction_475 -happyReduction_475 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut71 happy_x_1 of { (HappyWrap71 happy_var_1) -> - case happyOut70 happy_x_2 of { (HappyWrap70 happy_var_2) -> - case happyOut72 happy_x_3 of { (HappyWrap72 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 (happyIn203 r)) - -happyReduce_476 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_476 = happySpecReduce_1 187# happyReduction_476 -happyReduction_476 happy_x_1 - = case happyOut118 happy_x_1 of { (HappyWrap118 happy_var_1) -> - happyIn203 - (sL1 happy_var_1 . SigD noExtField . unLoc $ happy_var_1 - )} - -happyReduce_477 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_477 = happyMonadReduce 4# 187# happyReduction_477 -happyReduction_477 (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 happyOut273 happy_x_2 of { (HappyWrap273 happy_var_2) -> - case happyOut152 happy_x_3 of { (HappyWrap152 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 (happyIn203 r)) - -happyReduce_478 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_478 = happyMonadReduce 4# 187# happyReduction_478 -happyReduction_478 (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 happyOut204 happy_x_2 of { (HappyWrap204 happy_var_2) -> - case happyOut119 happy_x_3 of { (HappyWrap119 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 (happyIn203 r)) - -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 happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut299 happy_x_2 of { (HappyWrap299 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 (happyIn203 r)) - -happyReduce_480 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_480 = happyMonadReduce 3# 187# 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 happyOut299 happy_x_2 of { (HappyWrap299 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 (happyIn203 r)) - -happyReduce_481 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_481 = happyMonadReduce 4# 187# happyReduction_481 -happyReduction_481 (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 happyOut299 happy_x_2 of { (HappyWrap299 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 (happyIn203 r)) - -happyReduce_482 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_482 = happyMonadReduce 6# 187# happyReduction_482 -happyReduction_482 (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 happyOut204 happy_x_2 of { (HappyWrap204 happy_var_2) -> - case happyOut299 happy_x_3 of { (HappyWrap299 happy_var_3) -> - case happyOutTok happy_x_4 of { happy_var_4 -> - case happyOut156 happy_x_5 of { (HappyWrap156 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 (happyIn203 r)) - -happyReduce_483 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_483 = happyMonadReduce 6# 187# happyReduction_483 -happyReduction_483 (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 happyOut204 happy_x_2 of { (HappyWrap204 happy_var_2) -> - case happyOut299 happy_x_3 of { (HappyWrap299 happy_var_3) -> - case happyOutTok happy_x_4 of { happy_var_4 -> - case happyOut156 happy_x_5 of { (HappyWrap156 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 (happyIn203 r)) - -happyReduce_484 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_484 = happyMonadReduce 4# 187# happyReduction_484 -happyReduction_484 (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 happyOut170 happy_x_3 of { (HappyWrap170 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 (happyIn203 r)) - -happyReduce_485 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_485 = happyMonadReduce 3# 187# happyReduction_485 -happyReduction_485 (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 happyOut261 happy_x_2 of { (HappyWrap261 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 (happyIn203 r)) - -happyReduce_486 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_486 = happySpecReduce_0 188# happyReduction_486 -happyReduction_486 = happyIn204 - (([],Nothing) - ) - -happyReduce_487 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_487 = happySpecReduce_1 188# happyReduction_487 -happyReduction_487 happy_x_1 - = case happyOut205 happy_x_1 of { (HappyWrap205 happy_var_1) -> - happyIn204 - ((fst happy_var_1,Just (snd happy_var_1)) - )} - -happyReduce_488 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_488 = happySpecReduce_3 189# happyReduction_488 -happyReduction_488 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 -> - happyIn205 - (([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_489 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_489 = happyReduce 4# 189# happyReduction_489 -happyReduction_489 (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 happyOut135 happy_x_2 of { (HappyWrap135 happy_var_2) -> - case happyOutTok happy_x_3 of { happy_var_3 -> - case happyOutTok happy_x_4 of { happy_var_4 -> - happyIn205 - ((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_490 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_490 = happySpecReduce_1 190# happyReduction_490 -happyReduction_490 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn206 - (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_491 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_491 = happySpecReduce_1 190# happyReduction_491 -happyReduction_491 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn206 - (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_492 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_492 = happySpecReduce_3 191# happyReduction_492 -happyReduction_492 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut208 happy_x_1 of { (HappyWrap208 happy_var_1) -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut160 happy_x_3 of { (HappyWrap160 happy_var_3) -> - happyIn207 - (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_493 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_493 = happyMonadReduce 3# 191# happyReduction_493 -happyReduction_493 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut208 happy_x_1 of { (HappyWrap208 happy_var_1) -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut207 happy_x_3 of { (HappyWrap207 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 (happyIn207 r)) - -happyReduce_494 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_494 = happyMonadReduce 3# 191# happyReduction_494 -happyReduction_494 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut208 happy_x_1 of { (HappyWrap208 happy_var_1) -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut207 happy_x_3 of { (HappyWrap207 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 (happyIn207 r)) - -happyReduce_495 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_495 = happyMonadReduce 3# 191# happyReduction_495 -happyReduction_495 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut208 happy_x_1 of { (HappyWrap208 happy_var_1) -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut207 happy_x_3 of { (HappyWrap207 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 (happyIn207 r)) - -happyReduce_496 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_496 = happyMonadReduce 3# 191# happyReduction_496 -happyReduction_496 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut208 happy_x_1 of { (HappyWrap208 happy_var_1) -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut207 happy_x_3 of { (HappyWrap207 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 (happyIn207 r)) - -happyReduce_497 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_497 = happySpecReduce_1 191# happyReduction_497 -happyReduction_497 happy_x_1 - = case happyOut208 happy_x_1 of { (HappyWrap208 happy_var_1) -> - happyIn207 - (happy_var_1 - )} - -happyReduce_498 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_498 = happySpecReduce_1 191# happyReduction_498 -happyReduction_498 happy_x_1 - = case happyOut322 happy_x_1 of { (HappyWrap322 happy_var_1) -> - happyIn207 - (happy_var_1 - )} - -happyReduce_499 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_499 = happySpecReduce_1 192# happyReduction_499 -happyReduction_499 happy_x_1 - = case happyOut210 happy_x_1 of { (HappyWrap210 happy_var_1) -> - happyIn208 - (happy_var_1 - )} - -happyReduce_500 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_500 = happySpecReduce_3 192# happyReduction_500 -happyReduction_500 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut208 happy_x_1 of { (HappyWrap208 happy_var_1) -> - case happyOut290 happy_x_2 of { (HappyWrap290 happy_var_2) -> - case happyOut209 happy_x_3 of { (HappyWrap209 happy_var_3) -> - happyIn208 - (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_501 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_501 = happySpecReduce_1 193# happyReduction_501 -happyReduction_501 happy_x_1 - = case happyOut210 happy_x_1 of { (HappyWrap210 happy_var_1) -> - happyIn209 - (happy_var_1 - )} - -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 happyOut323 happy_x_1 of { (HappyWrap323 happy_var_1) -> - happyIn209 - (happy_var_1 - )} - -happyReduce_503 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_503 = happySpecReduce_2 194# happyReduction_503 -happyReduction_503 happy_x_2 - happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut213 happy_x_2 of { (HappyWrap213 happy_var_2) -> - happyIn210 - (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_504 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_504 = happySpecReduce_1 194# happyReduction_504 -happyReduction_504 happy_x_1 - = case happyOut213 happy_x_1 of { (HappyWrap213 happy_var_1) -> - happyIn210 - (happy_var_1 - )} - -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 - ((msemim happy_var_1,True) - )} - -happyReduce_506 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_506 = happySpecReduce_0 195# happyReduction_506 -happyReduction_506 = happyIn211 - ((Nothing,False) - ) - -happyReduce_507 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_507 = happyMonadReduce 3# 196# happyReduction_507 -happyReduction_507 (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 (happyIn212 r)) - -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 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 (happyIn212 r)) - -happyReduce_509 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_509 = happySpecReduce_2 197# happyReduction_509 -happyReduction_509 happy_x_2 - happy_x_1 - = case happyOut213 happy_x_1 of { (HappyWrap213 happy_var_1) -> - case happyOut214 happy_x_2 of { (HappyWrap214 happy_var_2) -> - happyIn213 - (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_510 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_510 = happySpecReduce_3 197# happyReduction_510 -happyReduction_510 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 happyOut169 happy_x_3 of { (HappyWrap169 happy_var_3) -> - happyIn213 - (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_511 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_511 = happyMonadReduce 2# 197# happyReduction_511 -happyReduction_511 (happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut214 happy_x_2 of { (HappyWrap214 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 (happyIn213 r)) - -happyReduce_512 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_512 = happySpecReduce_1 197# happyReduction_512 -happyReduction_512 happy_x_1 - = case happyOut214 happy_x_1 of { (HappyWrap214 happy_var_1) -> - happyIn213 - (happy_var_1 - )} - -happyReduce_513 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_513 = happySpecReduce_3 198# happyReduction_513 -happyReduction_513 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut299 happy_x_1 of { (HappyWrap299 happy_var_1) -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut214 happy_x_3 of { (HappyWrap214 happy_var_3) -> - happyIn214 - (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_514 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_514 = happySpecReduce_2 198# happyReduction_514 -happyReduction_514 happy_x_2 - happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut214 happy_x_2 of { (HappyWrap214 happy_var_2) -> - happyIn214 - (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_515 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_515 = happySpecReduce_2 198# happyReduction_515 -happyReduction_515 happy_x_2 - happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut214 happy_x_2 of { (HappyWrap214 happy_var_2) -> - happyIn214 - (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_516 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_516 = happySpecReduce_2 198# happyReduction_516 -happyReduction_516 happy_x_2 - happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut214 happy_x_2 of { (HappyWrap214 happy_var_2) -> - happyIn214 - (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_517 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_517 = happyReduce 4# 198# happyReduction_517 -happyReduction_517 (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 happyOut246 happy_x_2 of { (HappyWrap246 happy_var_2) -> - case happyOutTok happy_x_3 of { happy_var_3 -> - case happyOut207 happy_x_4 of { (HappyWrap207 happy_var_4) -> - happyIn214 - (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_518 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_518 = happyReduce 4# 198# happyReduction_518 -happyReduction_518 (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 happyOut130 happy_x_2 of { (HappyWrap130 happy_var_2) -> - case happyOutTok happy_x_3 of { happy_var_3 -> - case happyOut207 happy_x_4 of { (HappyWrap207 happy_var_4) -> - happyIn214 - (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_519 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_519 = happySpecReduce_3 198# happyReduction_519 -happyReduction_519 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 happyOut321 happy_x_3 of { (HappyWrap321 happy_var_3) -> - happyIn214 - (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_520 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_520 = happySpecReduce_3 198# happyReduction_520 -happyReduction_520 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 happyOut320 happy_x_3 of { (HappyWrap320 happy_var_3) -> - happyIn214 - (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_521 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_521 = happyMonadReduce 8# 198# happyReduction_521 -happyReduction_521 (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 happyOut207 happy_x_2 of { (HappyWrap207 happy_var_2) -> - case happyOut211 happy_x_3 of { (HappyWrap211 happy_var_3) -> - case happyOutTok happy_x_4 of { happy_var_4 -> - case happyOut207 happy_x_5 of { (HappyWrap207 happy_var_5) -> - case happyOut211 happy_x_6 of { (HappyWrap211 happy_var_6) -> - case happyOutTok happy_x_7 of { happy_var_7 -> - case happyOut207 happy_x_8 of { (HappyWrap207 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 (happyIn214 r)) - -happyReduce_522 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_522 = happyMonadReduce 2# 198# happyReduction_522 -happyReduction_522 (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) -> - ( 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 (happyIn214 r)) - -happyReduce_523 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_523 = happyMonadReduce 4# 198# happyReduction_523 -happyReduction_523 (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 happyOut207 happy_x_2 of { (HappyWrap207 happy_var_2) -> - case happyOutTok happy_x_3 of { happy_var_3 -> - case happyOut321 happy_x_4 of { (HappyWrap321 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 (happyIn214 r)) - -happyReduce_524 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_524 = happyMonadReduce 2# 198# happyReduction_524 -happyReduction_524 (happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut247 happy_x_2 of { (HappyWrap247 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 (happyIn214 r)) - -happyReduce_525 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_525 = happyMonadReduce 2# 198# happyReduction_525 -happyReduction_525 (happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut247 happy_x_2 of { (HappyWrap247 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 (happyIn214 r)) - -happyReduce_526 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_526 = happyMonadReduce 4# 198# happyReduction_526 -happyReduction_526 (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 happyOut214 happy_x_2 of { (HappyWrap214 happy_var_2) -> - case happyOutTok happy_x_3 of { happy_var_3 -> - case happyOut207 happy_x_4 of { (HappyWrap207 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 (happyIn214 r)) - -happyReduce_527 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_527 = happySpecReduce_1 198# happyReduction_527 -happyReduction_527 happy_x_1 - = case happyOut215 happy_x_1 of { (HappyWrap215 happy_var_1) -> - happyIn214 - (happy_var_1 - )} - -happyReduce_528 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_528 = happyReduce 4# 199# happyReduction_528 -happyReduction_528 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut215 happy_x_1 of { (HappyWrap215 happy_var_1) -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut253 happy_x_3 of { (HappyWrap253 happy_var_3) -> - case happyOutTok happy_x_4 of { happy_var_4 -> - happyIn215 - (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_529 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_529 = happyMonadReduce 3# 199# happyReduction_529 -happyReduction_529 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut215 happy_x_1 of { (HappyWrap215 happy_var_1) -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut300 happy_x_3 of { (HappyWrap300 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 (happyIn215 r)) - -happyReduce_530 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_530 = happySpecReduce_1 199# happyReduction_530 -happyReduction_530 happy_x_1 - = case happyOut216 happy_x_1 of { (HappyWrap216 happy_var_1) -> - happyIn215 - (happy_var_1 - )} - -happyReduce_531 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_531 = happySpecReduce_1 200# happyReduction_531 -happyReduction_531 happy_x_1 - = case happyOut299 happy_x_1 of { (HappyWrap299 happy_var_1) -> - happyIn216 - (ECP $ mkHsVarPV $! 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 200# happyReduction_532 -happyReduction_532 happy_x_1 - = case happyOut269 happy_x_1 of { (HappyWrap269 happy_var_1) -> - happyIn216 - (ECP $ mkHsVarPV $! happy_var_1 - )} - -happyReduce_533 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_533 = happyMonadReduce 1# 200# happyReduction_533 -happyReduction_533 (happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut259 happy_x_1 of { (HappyWrap259 happy_var_1) -> - ( acsExpr (\cs -> sL1a happy_var_1 (HsIPVar (comment (glRR happy_var_1) cs) $! unLoc happy_var_1)))}) - ) (\r -> happyReturn (happyIn216 r)) - -happyReduce_534 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_534 = happyMonadReduce 1# 200# happyReduction_534 -happyReduction_534 (happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut260 happy_x_1 of { (HappyWrap260 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 (happyIn216 r)) - -happyReduce_535 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_535 = happySpecReduce_1 200# happyReduction_535 -happyReduction_535 happy_x_1 - = case happyOut314 happy_x_1 of { (HappyWrap314 happy_var_1) -> - happyIn216 - (ECP $ pvA (mkHsLitPV $! happy_var_1) - )} - -happyReduce_536 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_536 = happySpecReduce_1 200# happyReduction_536 -happyReduction_536 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn216 - (ECP $ mkHsOverLitPV (sL1a happy_var_1 $ mkHsIntegral (getINTEGER happy_var_1)) - )} - -happyReduce_537 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_537 = happySpecReduce_1 200# happyReduction_537 -happyReduction_537 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn216 - (ECP $ mkHsOverLitPV (sL1a happy_var_1 $ mkHsFractional (getRATIONAL happy_var_1)) - )} - -happyReduce_538 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_538 = happySpecReduce_3 200# happyReduction_538 -happyReduction_538 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut225 happy_x_2 of { (HappyWrap225 happy_var_2) -> - case happyOutTok happy_x_3 of { happy_var_3 -> - happyIn216 - (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_539 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_539 = happySpecReduce_3 200# happyReduction_539 -happyReduction_539 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut226 happy_x_2 of { (HappyWrap226 happy_var_2) -> - case happyOutTok happy_x_3 of { happy_var_3 -> - happyIn216 - (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_540 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_540 = happySpecReduce_3 200# happyReduction_540 -happyReduction_540 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut217 happy_x_2 of { (HappyWrap217 happy_var_2) -> - case happyOutTok happy_x_3 of { happy_var_3 -> - happyIn216 - (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_541 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_541 = happySpecReduce_3 200# happyReduction_541 -happyReduction_541 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut225 happy_x_2 of { (HappyWrap225 happy_var_2) -> - case happyOutTok happy_x_3 of { happy_var_3 -> - happyIn216 - (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_542 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_542 = happySpecReduce_3 200# happyReduction_542 -happyReduction_542 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut226 happy_x_2 of { (HappyWrap226 happy_var_2) -> - case happyOutTok happy_x_3 of { happy_var_3 -> - happyIn216 - (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_543 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_543 = happySpecReduce_3 200# happyReduction_543 -happyReduction_543 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 -> - happyIn216 - (ECP $ happy_var_2 (comb2 happy_var_1 happy_var_3) (mos happy_var_1,mcs happy_var_3) - )}}} - -happyReduce_544 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_544 = happySpecReduce_1 200# happyReduction_544 -happyReduction_544 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn216 - (ECP $ pvA $ mkHsWildCardPV (getLoc 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 200# happyReduction_545 -happyReduction_545 happy_x_1 - = case happyOut219 happy_x_1 of { (HappyWrap219 happy_var_1) -> - happyIn216 - (ECP $ pvA $ mkHsSplicePV 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 200# happyReduction_546 -happyReduction_546 happy_x_1 - = case happyOut220 happy_x_1 of { (HappyWrap220 happy_var_1) -> - happyIn216 - (ecpFromExp $ fmap (uncurry HsTypedSplice) (reLocA happy_var_1) - )} - -happyReduce_547 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_547 = happyMonadReduce 2# 200# happyReduction_547 -happyReduction_547 (happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut299 happy_x_2 of { (HappyWrap299 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 (happyIn216 r)) - -happyReduce_548 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_548 = happyMonadReduce 2# 200# happyReduction_548 -happyReduction_548 (happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut269 happy_x_2 of { (HappyWrap269 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 (happyIn216 r)) - -happyReduce_549 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_549 = happyMonadReduce 2# 200# happyReduction_549 -happyReduction_549 (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) -> - ( 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 (happyIn216 r)) - -happyReduce_550 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_550 = happyMonadReduce 2# 200# happyReduction_550 -happyReduction_550 (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) -> - ( 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 (happyIn216 r)) - -happyReduce_551 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_551 = happyMonadReduce 1# 200# happyReduction_551 -happyReduction_551 (happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - ( reportEmptyDoubleQuotes (getLoc happy_var_1))}) - ) (\r -> happyReturn (happyIn216 r)) - -happyReduce_552 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_552 = happyMonadReduce 3# 200# happyReduction_552 -happyReduction_552 (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 happyOut207 happy_x_2 of { (HappyWrap207 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 (happyIn216 r)) - -happyReduce_553 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_553 = happyMonadReduce 3# 200# happyReduction_553 -happyReduction_553 (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 happyOut207 happy_x_2 of { (HappyWrap207 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 (happyIn216 r)) - -happyReduce_554 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_554 = happyMonadReduce 3# 200# happyReduction_554 -happyReduction_554 (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 happyOut159 happy_x_2 of { (HappyWrap159 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 (happyIn216 r)) - -happyReduce_555 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_555 = happyMonadReduce 3# 200# happyReduction_555 -happyReduction_555 (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 happyOut208 happy_x_2 of { (HappyWrap208 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 (happyIn216 r)) - -happyReduce_556 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_556 = happyMonadReduce 3# 200# happyReduction_556 -happyReduction_556 (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 happyOut223 happy_x_2 of { (HappyWrap223 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 (happyIn216 r)) - -happyReduce_557 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_557 = happySpecReduce_1 200# happyReduction_557 -happyReduction_557 happy_x_1 - = case happyOut206 happy_x_1 of { (HappyWrap206 happy_var_1) -> - happyIn216 - (ECP $ pvA $ mkHsSplicePV happy_var_1 - )} - -happyReduce_558 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_558 = happyMonadReduce 4# 200# happyReduction_558 -happyReduction_558 (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 happyOut214 happy_x_2 of { (HappyWrap214 happy_var_2) -> - case happyOut221 happy_x_3 of { (HappyWrap221 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 (happyIn216 r)) - -happyReduce_559 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_559 = happyMonadReduce 3# 201# happyReduction_559 -happyReduction_559 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut217 happy_x_1 of { (HappyWrap217 happy_var_1) -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut300 happy_x_3 of { (HappyWrap300 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 (happyIn217 r)) - -happyReduce_560 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_560 = happyMonadReduce 2# 201# happyReduction_560 -happyReduction_560 (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) -> - ( 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 (happyIn217 r)) - -happyReduce_561 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_561 = happySpecReduce_1 202# happyReduction_561 -happyReduction_561 happy_x_1 - = case happyOut219 happy_x_1 of { (HappyWrap219 happy_var_1) -> - happyIn218 - (fmap (HsUntypedSplice noAnn) (reLocA happy_var_1) - )} - -happyReduce_562 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_562 = happySpecReduce_1 202# happyReduction_562 -happyReduction_562 happy_x_1 - = case happyOut220 happy_x_1 of { (HappyWrap220 happy_var_1) -> - happyIn218 - (fmap (uncurry HsTypedSplice) (reLocA happy_var_1) - )} - -happyReduce_563 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_563 = happyMonadReduce 2# 203# 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 happyOut216 happy_x_2 of { (HappyWrap216 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 (happyIn219 r)) - -happyReduce_564 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_564 = happyMonadReduce 2# 204# 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 happyOut216 happy_x_2 of { (HappyWrap216 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 (happyIn220 r)) - -happyReduce_565 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_565 = happySpecReduce_2 205# happyReduction_565 -happyReduction_565 happy_x_2 - happy_x_1 - = case happyOut221 happy_x_1 of { (HappyWrap221 happy_var_1) -> - case happyOut222 happy_x_2 of { (HappyWrap222 happy_var_2) -> - happyIn221 - (happy_var_2 : happy_var_1 - )}} - -happyReduce_566 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_566 = happySpecReduce_0 205# happyReduction_566 -happyReduction_566 = happyIn221 - ([] - ) - -happyReduce_567 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_567 = happyMonadReduce 1# 206# happyReduction_567 -happyReduction_567 (happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut214 happy_x_1 of { (HappyWrap214 happy_var_1) -> - ( runPV (unECP happy_var_1) >>= \ (cmd :: LHsCmd GhcPs) -> - runPV (checkCmdBlockArguments cmd) >>= \ _ -> - return (sL1a (reLoc cmd) $ HsCmdTop noExtField cmd))}) - ) (\r -> happyReturn (happyIn222 r)) - -happyReduce_568 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_568 = happySpecReduce_3 207# happyReduction_568 -happyReduction_568 happy_x_3 - happy_x_2 - happy_x_1 - = 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 -> - happyIn223 - (([mj AnnOpenC happy_var_1 - ,mj AnnCloseC happy_var_3],happy_var_2) - )}}} - -happyReduce_569 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_569 = happySpecReduce_3 207# happyReduction_569 -happyReduction_569 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut224 happy_x_2 of { (HappyWrap224 happy_var_2) -> - happyIn223 - (([],happy_var_2) - )} - -happyReduce_570 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_570 = happySpecReduce_1 208# happyReduction_570 -happyReduction_570 happy_x_1 - = case happyOut74 happy_x_1 of { (HappyWrap74 happy_var_1) -> - happyIn224 - (cvTopDecls 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 208# happyReduction_571 -happyReduction_571 happy_x_1 - = case happyOut73 happy_x_1 of { (HappyWrap73 happy_var_1) -> - happyIn224 - (cvTopDecls 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 209# happyReduction_572 -happyReduction_572 happy_x_1 - = case happyOut207 happy_x_1 of { (HappyWrap207 happy_var_1) -> - happyIn225 - (happy_var_1 - )} - -happyReduce_573 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_573 = happyMonadReduce 2# 209# happyReduction_573 -happyReduction_573 (happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut208 happy_x_1 of { (HappyWrap208 happy_var_1) -> - case happyOut290 happy_x_2 of { (HappyWrap290 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 (happyIn225 r)) - -happyReduce_574 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_574 = happySpecReduce_2 209# happyReduction_574 -happyReduction_574 happy_x_2 - happy_x_1 - = case happyOut291 happy_x_1 of { (HappyWrap291 happy_var_1) -> - case happyOut208 happy_x_2 of { (HappyWrap208 happy_var_2) -> - happyIn225 - (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_575 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_575 = happySpecReduce_3 209# happyReduction_575 -happyReduction_575 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut207 happy_x_1 of { (HappyWrap207 happy_var_1) -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut225 happy_x_3 of { (HappyWrap225 happy_var_3) -> - happyIn225 - (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_576 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_576 = happySpecReduce_2 210# happyReduction_576 -happyReduction_576 happy_x_2 - happy_x_1 - = case happyOut225 happy_x_1 of { (HappyWrap225 happy_var_1) -> - case happyOut227 happy_x_2 of { (HappyWrap227 happy_var_2) -> - happyIn226 - (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_577 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_577 = happySpecReduce_2 210# happyReduction_577 -happyReduction_577 happy_x_2 - happy_x_1 - = case happyOut317 happy_x_1 of { (HappyWrap317 happy_var_1) -> - case happyOut228 happy_x_2 of { (HappyWrap228 happy_var_2) -> - happyIn226 - (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_578 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_578 = happySpecReduce_2 210# happyReduction_578 -happyReduction_578 happy_x_2 - happy_x_1 - = case happyOut225 happy_x_1 of { (HappyWrap225 happy_var_1) -> - case happyOut319 happy_x_2 of { (HappyWrap319 happy_var_2) -> - happyIn226 - (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_579 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_579 = happySpecReduce_3 210# happyReduction_579 -happyReduction_579 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut319 happy_x_1 of { (HappyWrap319 happy_var_1) -> - case happyOut225 happy_x_2 of { (HappyWrap225 happy_var_2) -> - case happyOut318 happy_x_3 of { (HappyWrap318 happy_var_3) -> - happyIn226 - (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_580 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_580 = happySpecReduce_2 211# happyReduction_580 -happyReduction_580 happy_x_2 - happy_x_1 - = case happyOut317 happy_x_1 of { (HappyWrap317 happy_var_1) -> - case happyOut228 happy_x_2 of { (HappyWrap228 happy_var_2) -> - happyIn227 - (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_581 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_581 = happySpecReduce_2 212# happyReduction_581 -happyReduction_581 happy_x_2 - happy_x_1 - = case happyOut225 happy_x_1 of { (HappyWrap225 happy_var_1) -> - case happyOut227 happy_x_2 of { (HappyWrap227 happy_var_2) -> - happyIn228 - (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_582 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_582 = happySpecReduce_1 212# happyReduction_582 -happyReduction_582 happy_x_1 - = case happyOut225 happy_x_1 of { (HappyWrap225 happy_var_1) -> - happyIn228 - (unECP happy_var_1 >>= \ happy_var_1 -> - return [Right happy_var_1] - )} - -happyReduce_583 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_583 = happySpecReduce_0 212# happyReduction_583 -happyReduction_583 = happyIn228 - (return [Left noAnn] - ) - -happyReduce_584 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_584 = happySpecReduce_1 213# happyReduction_584 -happyReduction_584 happy_x_1 - = case happyOut225 happy_x_1 of { (HappyWrap225 happy_var_1) -> - happyIn229 - (\loc (ao,ac) -> unECP happy_var_1 >>= \ happy_var_1 -> - mkHsExplicitListPV loc [happy_var_1] (AnnList Nothing (Just ao) (Just ac) [] []) - )} - -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 happyOut230 happy_x_1 of { (HappyWrap230 happy_var_1) -> - happyIn229 - (\loc (ao,ac) -> happy_var_1 >>= \ happy_var_1 -> - mkHsExplicitListPV loc (reverse happy_var_1) (AnnList Nothing (Just ao) (Just ac) [] []) - )} - -happyReduce_586 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_586 = happySpecReduce_2 213# happyReduction_586 -happyReduction_586 happy_x_2 - happy_x_1 - = case happyOut225 happy_x_1 of { (HappyWrap225 happy_var_1) -> - case happyOutTok happy_x_2 of { happy_var_2 -> - happyIn229 - (\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_587 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_587 = happyReduce 4# 213# happyReduction_587 -happyReduction_587 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut225 happy_x_1 of { (HappyWrap225 happy_var_1) -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut207 happy_x_3 of { (HappyWrap207 happy_var_3) -> - case happyOutTok happy_x_4 of { happy_var_4 -> - happyIn229 - (\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_588 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_588 = happySpecReduce_3 213# happyReduction_588 -happyReduction_588 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut225 happy_x_1 of { (HappyWrap225 happy_var_1) -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut207 happy_x_3 of { (HappyWrap207 happy_var_3) -> - happyIn229 - (\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_589 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_589 = happyReduce 5# 213# happyReduction_589 -happyReduction_589 (happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut225 happy_x_1 of { (HappyWrap225 happy_var_1) -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut207 happy_x_3 of { (HappyWrap207 happy_var_3) -> - case happyOutTok happy_x_4 of { happy_var_4 -> - case happyOut207 happy_x_5 of { (HappyWrap207 happy_var_5) -> - happyIn229 - (\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_590 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_590 = happySpecReduce_3 213# happyReduction_590 -happyReduction_590 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut225 happy_x_1 of { (HappyWrap225 happy_var_1) -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut231 happy_x_3 of { (HappyWrap231 happy_var_3) -> - happyIn229 - (\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_591 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_591 = happySpecReduce_3 214# happyReduction_591 -happyReduction_591 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 happyOut225 happy_x_3 of { (HappyWrap225 happy_var_3) -> - happyIn230 - (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_592 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_592 = happySpecReduce_3 214# happyReduction_592 -happyReduction_592 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut225 happy_x_1 of { (HappyWrap225 happy_var_1) -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut225 happy_x_3 of { (HappyWrap225 happy_var_3) -> - happyIn230 - (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_593 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_593 = happySpecReduce_1 215# happyReduction_593 -happyReduction_593 happy_x_1 - = case happyOut232 happy_x_1 of { (HappyWrap232 happy_var_1) -> - happyIn231 - (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_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 happyOut233 happy_x_1 of { (HappyWrap233 happy_var_1) -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut232 happy_x_3 of { (HappyWrap232 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 (happyIn232 r)) - -happyReduce_595 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_595 = happySpecReduce_1 216# happyReduction_595 -happyReduction_595 happy_x_1 - = case happyOut233 happy_x_1 of { (HappyWrap233 happy_var_1) -> - happyIn232 - (L (getLoc happy_var_1) [reverse (unLoc happy_var_1)] - )} - -happyReduce_596 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_596 = happyMonadReduce 3# 217# happyReduction_596 -happyReduction_596 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut233 happy_x_1 of { (HappyWrap233 happy_var_1) -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut234 happy_x_3 of { (HappyWrap234 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 (happyIn233 r)) - -happyReduce_597 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_597 = happyMonadReduce 3# 217# happyReduction_597 -happyReduction_597 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut233 happy_x_1 of { (HappyWrap233 happy_var_1) -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut252 happy_x_3 of { (HappyWrap252 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 (happyIn233 r)) - -happyReduce_598 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_598 = happyMonadReduce 1# 217# happyReduction_598 -happyReduction_598 (happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut234 happy_x_1 of { (HappyWrap234 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 (happyIn233 r)) - -happyReduce_599 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_599 = happyMonadReduce 1# 217# happyReduction_599 -happyReduction_599 (happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut252 happy_x_1 of { (HappyWrap252 happy_var_1) -> - ( runPV happy_var_1 >>= \ happy_var_1 -> - return $ sL1A happy_var_1 [happy_var_1])}) - ) (\r -> happyReturn (happyIn233 r)) - -happyReduce_600 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_600 = happyMonadReduce 2# 218# happyReduction_600 -happyReduction_600 (happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut207 happy_x_2 of { (HappyWrap207 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 (happyIn234 r)) - -happyReduce_601 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_601 = happyMonadReduce 4# 218# happyReduction_601 -happyReduction_601 (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 happyOut207 happy_x_2 of { (HappyWrap207 happy_var_2) -> - case happyOutTok happy_x_3 of { happy_var_3 -> - case happyOut207 happy_x_4 of { (HappyWrap207 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 (happyIn234 r)) - -happyReduce_602 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_602 = happyMonadReduce 4# 218# happyReduction_602 -happyReduction_602 (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 happyOut207 happy_x_4 of { (HappyWrap207 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 (happyIn234 r)) - -happyReduce_603 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_603 = happyMonadReduce 6# 218# happyReduction_603 -happyReduction_603 (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 happyOut207 happy_x_4 of { (HappyWrap207 happy_var_4) -> - case happyOutTok happy_x_5 of { happy_var_5 -> - case happyOut207 happy_x_6 of { (HappyWrap207 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 (happyIn234 r)) - -happyReduce_604 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_604 = happySpecReduce_1 219# happyReduction_604 -happyReduction_604 happy_x_1 - = case happyOut236 happy_x_1 of { (HappyWrap236 happy_var_1) -> - happyIn235 - (L (getLoc happy_var_1) (reverse (unLoc happy_var_1)) - )} - -happyReduce_605 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_605 = happyMonadReduce 3# 220# happyReduction_605 -happyReduction_605 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut236 happy_x_1 of { (HappyWrap236 happy_var_1) -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut252 happy_x_3 of { (HappyWrap252 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 (happyIn236 r)) - -happyReduce_606 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_606 = happyMonadReduce 1# 220# happyReduction_606 -happyReduction_606 (happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut252 happy_x_1 of { (HappyWrap252 happy_var_1) -> - ( runPV happy_var_1 >>= \ happy_var_1 -> - return $ sL1A happy_var_1 [happy_var_1])}) - ) (\r -> happyReturn (happyIn236 r)) - -happyReduce_607 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_607 = happySpecReduce_2 221# happyReduction_607 -happyReduction_607 happy_x_2 - happy_x_1 - = case happyOut238 happy_x_1 of { (HappyWrap238 happy_var_1) -> - case happyOut131 happy_x_2 of { (HappyWrap131 happy_var_2) -> - happyIn237 - (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_608 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_608 = happySpecReduce_2 222# happyReduction_608 -happyReduction_608 happy_x_2 - happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut207 happy_x_2 of { (HappyWrap207 happy_var_2) -> - happyIn238 - (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_609 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_609 = happySpecReduce_1 222# happyReduction_609 -happyReduction_609 happy_x_1 - = case happyOut239 happy_x_1 of { (HappyWrap239 happy_var_1) -> - happyIn238 - (happy_var_1 >>= \gdpats -> - return $ sL1 gdpats (reverse (unLoc gdpats)) - )} - -happyReduce_610 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_610 = happySpecReduce_2 223# happyReduction_610 -happyReduction_610 happy_x_2 - happy_x_1 - = case happyOut239 happy_x_1 of { (HappyWrap239 happy_var_1) -> - case happyOut241 happy_x_2 of { (HappyWrap241 happy_var_2) -> - happyIn239 - (happy_var_1 >>= \gdpats -> - happy_var_2 >>= \gdpat -> - return $ sLL gdpats (reLoc gdpat) (gdpat : unLoc gdpats) - )}} - -happyReduce_611 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_611 = happySpecReduce_1 223# happyReduction_611 -happyReduction_611 happy_x_1 - = case happyOut241 happy_x_1 of { (HappyWrap241 happy_var_1) -> - happyIn239 - (happy_var_1 >>= \gdpat -> return $ sL1A gdpat [gdpat] - )} - -happyReduce_612 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_612 = happyMonadReduce 3# 224# happyReduction_612 -happyReduction_612 (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 -> - ( 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 (happyIn240 r)) - -happyReduce_613 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_613 = happyMonadReduce 2# 224# happyReduction_613 -happyReduction_613 (happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut239 happy_x_1 of { (HappyWrap239 happy_var_1) -> - ( runPV happy_var_1 >>= \ happy_var_1 -> - return $ sL1 happy_var_1 ([],unLoc happy_var_1))}) - ) (\r -> happyReturn (happyIn240 r)) - -happyReduce_614 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_614 = happyReduce 4# 225# happyReduction_614 -happyReduction_614 (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 happyOut235 happy_x_2 of { (HappyWrap235 happy_var_2) -> - case happyOutTok happy_x_3 of { happy_var_3 -> - case happyOut207 happy_x_4 of { (HappyWrap207 happy_var_4) -> - happyIn241 - (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_615 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_615 = happyMonadReduce 1# 226# happyReduction_615 -happyReduction_615 (happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut207 happy_x_1 of { (HappyWrap207 happy_var_1) -> - ( (checkPattern <=< runPV) (unECP happy_var_1))}) - ) (\r -> happyReturn (happyIn242 r)) - -happyReduce_616 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_616 = happySpecReduce_1 227# happyReduction_616 -happyReduction_616 happy_x_1 - = case happyOut242 happy_x_1 of { (HappyWrap242 happy_var_1) -> - happyIn243 - ([ happy_var_1 ] - )} - -happyReduce_617 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_617 = happyMonadReduce 1# 228# happyReduction_617 -happyReduction_617 (happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut207 happy_x_1 of { (HappyWrap207 happy_var_1) -> - ( -- See Note [Parser-Validator Details] in GHC.Parser.PostProcess - checkPattern_details incompleteDoBlock - (unECP happy_var_1))}) - ) (\r -> happyReturn (happyIn244 r)) - -happyReduce_618 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_618 = happyMonadReduce 1# 229# happyReduction_618 -happyReduction_618 (happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut214 happy_x_1 of { (HappyWrap214 happy_var_1) -> - ( (checkPattern <=< runPV) (unECP happy_var_1))}) - ) (\r -> happyReturn (happyIn245 r)) - -happyReduce_619 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_619 = happySpecReduce_2 230# happyReduction_619 -happyReduction_619 happy_x_2 - happy_x_1 - = case happyOut245 happy_x_1 of { (HappyWrap245 happy_var_1) -> - case happyOut246 happy_x_2 of { (HappyWrap246 happy_var_2) -> - happyIn246 - (happy_var_1 : happy_var_2 - )}} - -happyReduce_620 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_620 = happySpecReduce_0 230# happyReduction_620 -happyReduction_620 = happyIn246 - ([] - ) - -happyReduce_621 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_621 = happySpecReduce_3 231# happyReduction_621 -happyReduction_621 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut248 happy_x_2 of { (HappyWrap248 happy_var_2) -> - case happyOutTok happy_x_3 of { happy_var_3 -> - happyIn247 - (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_622 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_622 = happySpecReduce_3 231# happyReduction_622 -happyReduction_622 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut248 happy_x_2 of { (HappyWrap248 happy_var_2) -> - happyIn247 - (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_623 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_623 = happySpecReduce_3 232# happyReduction_623 -happyReduction_623 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut248 happy_x_1 of { (HappyWrap248 happy_var_1) -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut251 happy_x_3 of { (HappyWrap251 happy_var_3) -> - happyIn248 - (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_624 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_624 = happySpecReduce_2 232# happyReduction_624 -happyReduction_624 happy_x_2 - happy_x_1 - = case happyOut248 happy_x_1 of { (HappyWrap248 happy_var_1) -> - case happyOutTok happy_x_2 of { happy_var_2 -> - happyIn248 - (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_625 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_625 = happySpecReduce_1 232# happyReduction_625 -happyReduction_625 happy_x_1 - = case happyOut251 happy_x_1 of { (HappyWrap251 happy_var_1) -> - happyIn248 - (happy_var_1 >>= \ happy_var_1 -> - return $ sL1A happy_var_1 (nilOL,[happy_var_1]) - )} - -happyReduce_626 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_626 = happySpecReduce_0 232# happyReduction_626 -happyReduction_626 = happyIn248 - (return $ noLoc (nilOL,[]) - ) - -happyReduce_627 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_627 = happyMonadReduce 1# 233# happyReduction_627 -happyReduction_627 (happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut251 happy_x_1 of { (HappyWrap251 happy_var_1) -> - ( fmap Just (runPV happy_var_1))}) - ) (\r -> happyReturn (happyIn249 r)) - -happyReduce_628 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_628 = happySpecReduce_0 233# happyReduction_628 -happyReduction_628 = happyIn249 - (Nothing - ) - -happyReduce_629 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_629 = happyMonadReduce 1# 234# happyReduction_629 -happyReduction_629 (happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut251 happy_x_1 of { (HappyWrap251 happy_var_1) -> - ( runPV happy_var_1)}) - ) (\r -> happyReturn (happyIn250 r)) - -happyReduce_630 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_630 = happySpecReduce_1 235# happyReduction_630 -happyReduction_630 happy_x_1 - = case happyOut252 happy_x_1 of { (HappyWrap252 happy_var_1) -> - happyIn251 - (happy_var_1 - )} - -happyReduce_631 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_631 = happySpecReduce_2 235# happyReduction_631 -happyReduction_631 happy_x_2 - happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut247 happy_x_2 of { (HappyWrap247 happy_var_2) -> - happyIn251 - (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_632 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_632 = happySpecReduce_3 236# happyReduction_632 -happyReduction_632 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut244 happy_x_1 of { (HappyWrap244 happy_var_1) -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut207 happy_x_3 of { (HappyWrap207 happy_var_3) -> - happyIn252 - (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_633 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_633 = happySpecReduce_1 236# happyReduction_633 -happyReduction_633 happy_x_1 - = case happyOut207 happy_x_1 of { (HappyWrap207 happy_var_1) -> - happyIn252 - (unECP happy_var_1 >>= \ happy_var_1 -> - return $ sL1 happy_var_1 $ mkBodyStmt happy_var_1 - )} - -happyReduce_634 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_634 = happySpecReduce_2 236# happyReduction_634 -happyReduction_634 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) -> - happyIn252 - (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_635 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_635 = happySpecReduce_1 237# happyReduction_635 -happyReduction_635 happy_x_1 - = case happyOut254 happy_x_1 of { (HappyWrap254 happy_var_1) -> - happyIn253 - (happy_var_1 - )} - -happyReduce_636 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_636 = happySpecReduce_0 237# happyReduction_636 -happyReduction_636 = happyIn253 - (return ([], Nothing) - ) - -happyReduce_637 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_637 = happySpecReduce_3 238# happyReduction_637 -happyReduction_637 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut255 happy_x_1 of { (HappyWrap255 happy_var_1) -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut254 happy_x_3 of { (HappyWrap254 happy_var_3) -> - happyIn254 - (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_638 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_638 = happySpecReduce_1 238# happyReduction_638 -happyReduction_638 happy_x_1 - = case happyOut255 happy_x_1 of { (HappyWrap255 happy_var_1) -> - happyIn254 - (happy_var_1 >>= \ happy_var_1 -> - return ([happy_var_1], Nothing) - )} - -happyReduce_639 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_639 = happySpecReduce_1 238# happyReduction_639 -happyReduction_639 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn254 - (return ([], Just (getLoc happy_var_1)) - )} - -happyReduce_640 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_640 = happySpecReduce_3 239# happyReduction_640 -happyReduction_640 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut299 happy_x_1 of { (HappyWrap299 happy_var_1) -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut225 happy_x_3 of { (HappyWrap225 happy_var_3) -> - happyIn255 - (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_641 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_641 = happySpecReduce_1 239# happyReduction_641 -happyReduction_641 happy_x_1 - = case happyOut299 happy_x_1 of { (HappyWrap299 happy_var_1) -> - happyIn255 - (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_642 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_642 = happyReduce 5# 239# happyReduction_642 -happyReduction_642 (happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut300 happy_x_1 of { (HappyWrap300 happy_var_1) -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut256 happy_x_3 of { (HappyWrap256 happy_var_3) -> - case happyOutTok happy_x_4 of { happy_var_4 -> - case happyOut225 happy_x_5 of { (HappyWrap225 happy_var_5) -> - happyIn255 - (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_643 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_643 = happySpecReduce_3 239# happyReduction_643 -happyReduction_643 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut300 happy_x_1 of { (HappyWrap300 happy_var_1) -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut256 happy_x_3 of { (HappyWrap256 happy_var_3) -> - happyIn255 - (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_644 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_644 = happyMonadReduce 3# 240# happyReduction_644 -happyReduction_644 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut256 happy_x_1 of { (HappyWrap256 happy_var_1) -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut300 happy_x_3 of { (HappyWrap300 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 (happyIn256 r)) - -happyReduce_645 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_645 = happyMonadReduce 1# 240# happyReduction_645 -happyReduction_645 (happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut300 happy_x_1 of { (HappyWrap300 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 (happyIn256 r)) - -happyReduce_646 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_646 = happyMonadReduce 3# 241# happyReduction_646 -happyReduction_646 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut257 happy_x_1 of { (HappyWrap257 happy_var_1) -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut258 happy_x_3 of { (HappyWrap258 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 (happyIn257 r)) - -happyReduce_647 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_647 = happyMonadReduce 2# 241# happyReduction_647 -happyReduction_647 (happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut257 happy_x_1 of { (HappyWrap257 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 (happyIn257 r)) - -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 happyOut258 happy_x_1 of { (HappyWrap258 happy_var_1) -> - happyIn257 - (let this = happy_var_1 in this `seq` (sL1 (reLoc happy_var_1) [this]) - )} - -happyReduce_649 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_649 = happyMonadReduce 3# 242# happyReduction_649 -happyReduction_649 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut259 happy_x_1 of { (HappyWrap259 happy_var_1) -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut207 happy_x_3 of { (HappyWrap207 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 (happyIn258 r)) - -happyReduce_650 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_650 = happySpecReduce_1 243# happyReduction_650 -happyReduction_650 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn259 - (sL1 happy_var_1 (HsIPName (getIPDUPVARID happy_var_1)) - )} - -happyReduce_651 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_651 = happySpecReduce_1 244# happyReduction_651 -happyReduction_651 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn260 - (sL1 happy_var_1 (getLABELVARIDs happy_var_1, getLABELVARID happy_var_1) - )} - -happyReduce_652 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_652 = happySpecReduce_1 245# happyReduction_652 -happyReduction_652 happy_x_1 - = case happyOut262 happy_x_1 of { (HappyWrap262 happy_var_1) -> - happyIn261 - (happy_var_1 - )} - -happyReduce_653 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_653 = happySpecReduce_0 245# happyReduction_653 -happyReduction_653 = happyIn261 - (noLocA mkTrue - ) - -happyReduce_654 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_654 = happySpecReduce_1 246# happyReduction_654 -happyReduction_654 happy_x_1 - = case happyOut263 happy_x_1 of { (HappyWrap263 happy_var_1) -> - happyIn262 - (happy_var_1 - )} - -happyReduce_655 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_655 = happyMonadReduce 3# 246# happyReduction_655 -happyReduction_655 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut263 happy_x_1 of { (HappyWrap263 happy_var_1) -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut262 happy_x_3 of { (HappyWrap262 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 (happyIn262 r)) - -happyReduce_656 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_656 = happySpecReduce_1 247# happyReduction_656 -happyReduction_656 happy_x_1 - = case happyOut264 happy_x_1 of { (HappyWrap264 happy_var_1) -> - happyIn263 - (reLocA $ sLLAA (head happy_var_1) (last happy_var_1) (And (happy_var_1)) - )} - -happyReduce_657 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_657 = happySpecReduce_1 248# happyReduction_657 -happyReduction_657 happy_x_1 - = case happyOut265 happy_x_1 of { (HappyWrap265 happy_var_1) -> - happyIn264 - ([happy_var_1] - )} - -happyReduce_658 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_658 = happyMonadReduce 3# 248# happyReduction_658 -happyReduction_658 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut265 happy_x_1 of { (HappyWrap265 happy_var_1) -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut264 happy_x_3 of { (HappyWrap264 happy_var_3) -> - ( do { h <- addTrailingCommaL happy_var_1 (gl happy_var_2) - ; return (h : happy_var_3) })}}}) - ) (\r -> happyReturn (happyIn264 r)) - -happyReduce_659 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_659 = happyMonadReduce 3# 249# happyReduction_659 -happyReduction_659 (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 -> - ( 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 (happyIn265 r)) - -happyReduce_660 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_660 = happySpecReduce_1 249# happyReduction_660 -happyReduction_660 happy_x_1 - = case happyOut267 happy_x_1 of { (HappyWrap267 happy_var_1) -> - happyIn265 - (reLocA $ sL1N happy_var_1 (Var happy_var_1) - )} - -happyReduce_661 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_661 = happySpecReduce_1 250# happyReduction_661 -happyReduction_661 happy_x_1 - = case happyOut267 happy_x_1 of { (HappyWrap267 happy_var_1) -> - happyIn266 - (sL1N happy_var_1 [happy_var_1] - )} - -happyReduce_662 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_662 = happyMonadReduce 3# 250# happyReduction_662 -happyReduction_662 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut267 happy_x_1 of { (HappyWrap267 happy_var_1) -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut266 happy_x_3 of { (HappyWrap266 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 (happyIn266 r)) - -happyReduce_663 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_663 = happySpecReduce_1 251# happyReduction_663 -happyReduction_663 happy_x_1 - = case happyOut298 happy_x_1 of { (HappyWrap298 happy_var_1) -> - happyIn267 - (happy_var_1 - )} - -happyReduce_664 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_664 = happySpecReduce_1 251# happyReduction_664 -happyReduction_664 happy_x_1 - = case happyOut271 happy_x_1 of { (HappyWrap271 happy_var_1) -> - happyIn267 - (happy_var_1 - )} - -happyReduce_665 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_665 = happySpecReduce_1 252# happyReduction_665 -happyReduction_665 happy_x_1 - = case happyOut270 happy_x_1 of { (HappyWrap270 happy_var_1) -> - happyIn268 - (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 252# happyReduction_666 -happyReduction_666 happy_x_1 - = case happyOut274 happy_x_1 of { (HappyWrap274 happy_var_1) -> - happyIn268 - (L (getLoc happy_var_1) $ nameRdrName (dataConName (unLoc 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 253# happyReduction_667 -happyReduction_667 happy_x_1 - = case happyOut270 happy_x_1 of { (HappyWrap270 happy_var_1) -> - happyIn269 - (happy_var_1 - )} - -happyReduce_668 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_668 = happySpecReduce_1 253# happyReduction_668 -happyReduction_668 happy_x_1 - = case happyOut275 happy_x_1 of { (HappyWrap275 happy_var_1) -> - happyIn269 - (L (getLoc happy_var_1) $ nameRdrName (dataConName (unLoc happy_var_1)) - )} - -happyReduce_669 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_669 = happySpecReduce_1 254# happyReduction_669 -happyReduction_669 happy_x_1 - = case happyOut310 happy_x_1 of { (HappyWrap310 happy_var_1) -> - happyIn270 - (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# 254# happyReduction_670 -happyReduction_670 (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 happyOut312 happy_x_2 of { (HappyWrap312 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 (happyIn270 r)) - -happyReduce_671 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_671 = happySpecReduce_1 255# happyReduction_671 -happyReduction_671 happy_x_1 - = case happyOut311 happy_x_1 of { (HappyWrap311 happy_var_1) -> - happyIn271 - (happy_var_1 - )} - -happyReduce_672 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_672 = happyMonadReduce 3# 255# happyReduction_672 -happyReduction_672 (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 -> - ( 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 (happyIn271 r)) - -happyReduce_673 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_673 = happySpecReduce_1 255# happyReduction_673 -happyReduction_673 happy_x_1 - = case happyOut275 happy_x_1 of { (HappyWrap275 happy_var_1) -> - happyIn271 - (L (getLoc happy_var_1) $ nameRdrName (dataConName (unLoc happy_var_1)) - )} - -happyReduce_674 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_674 = happySpecReduce_1 256# happyReduction_674 -happyReduction_674 happy_x_1 - = case happyOut271 happy_x_1 of { (HappyWrap271 happy_var_1) -> - happyIn272 - (sL1N happy_var_1 (pure happy_var_1) - )} - -happyReduce_675 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_675 = happyMonadReduce 3# 256# happyReduction_675 -happyReduction_675 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut271 happy_x_1 of { (HappyWrap271 happy_var_1) -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut272 happy_x_3 of { (HappyWrap272 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 (happyIn272 r)) - -happyReduce_676 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_676 = happySpecReduce_1 257# happyReduction_676 -happyReduction_676 happy_x_1 - = case happyOut269 happy_x_1 of { (HappyWrap269 happy_var_1) -> - happyIn273 - (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# 257# happyReduction_677 -happyReduction_677 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut269 happy_x_1 of { (HappyWrap269 happy_var_1) -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut273 happy_x_3 of { (HappyWrap273 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 (happyIn273 r)) - -happyReduce_678 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_678 = happyMonadReduce 2# 258# happyReduction_678 -happyReduction_678 (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 (happyIn274 r)) - -happyReduce_679 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_679 = happyMonadReduce 3# 258# happyReduction_679 -happyReduction_679 (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 $ 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 (happyIn274 r)) - -happyReduce_680 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_680 = happyMonadReduce 2# 258# happyReduction_680 -happyReduction_680 (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 (happyIn274 r)) - -happyReduce_681 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_681 = happyMonadReduce 3# 258# happyReduction_681 -happyReduction_681 (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 $ 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 (happyIn274 r)) - -happyReduce_682 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_682 = happySpecReduce_1 259# happyReduction_682 -happyReduction_682 happy_x_1 - = case happyOut274 happy_x_1 of { (HappyWrap274 happy_var_1) -> - happyIn275 - (happy_var_1 - )} - -happyReduce_683 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_683 = happyMonadReduce 2# 259# happyReduction_683 -happyReduction_683 (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 (happyIn275 r)) - -happyReduce_684 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_684 = happySpecReduce_1 260# happyReduction_684 -happyReduction_684 happy_x_1 - = case happyOut313 happy_x_1 of { (HappyWrap313 happy_var_1) -> - happyIn276 - (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# 260# 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 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 NameBackquotes (glAA happy_var_1) (glNRR happy_var_2) (glAA happy_var_3) []))}}}) - ) (\r -> happyReturn (happyIn276 r)) - -happyReduce_686 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_686 = happySpecReduce_1 261# happyReduction_686 -happyReduction_686 happy_x_1 - = case happyOut312 happy_x_1 of { (HappyWrap312 happy_var_1) -> - happyIn277 - (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# 261# 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 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 NameBackquotes (glAA happy_var_1) (glNRR happy_var_2) (glAA happy_var_3) []))}}}) - ) (\r -> happyReturn (happyIn277 r)) - -happyReduce_688 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_688 = happySpecReduce_1 262# happyReduction_688 -happyReduction_688 happy_x_1 - = case happyOut279 happy_x_1 of { (HappyWrap279 happy_var_1) -> - happyIn278 - (happy_var_1 - )} - -happyReduce_689 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_689 = happyMonadReduce 2# 262# happyReduction_689 -happyReduction_689 (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 (happyIn278 r)) - -happyReduce_690 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_690 = happyMonadReduce 2# 262# happyReduction_690 -happyReduction_690 (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 (happyIn278 r)) - -happyReduce_691 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_691 = happySpecReduce_1 263# happyReduction_691 -happyReduction_691 happy_x_1 - = case happyOut280 happy_x_1 of { (HappyWrap280 happy_var_1) -> - happyIn279 - (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# 263# happyReduction_692 -happyReduction_692 (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 $ 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 (happyIn279 r)) - -happyReduce_693 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_693 = happyMonadReduce 3# 263# happyReduction_693 -happyReduction_693 (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 $ 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 (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 happyOut319 happy_x_2 of { (HappyWrap319 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 (happyIn279 r)) - -happyReduce_695 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_695 = happyMonadReduce 3# 263# happyReduction_695 -happyReduction_695 (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) - (NameAnn NameParens (glAA happy_var_1) (glAA happy_var_2) (glAA happy_var_3) []))}}}) - ) (\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 2# 263# happyReduction_696 -happyReduction_696 (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 (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 happyOut283 happy_x_1 of { (HappyWrap283 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 happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut285 happy_x_2 of { (HappyWrap285 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 (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 happyOut283 happy_x_1 of { (HappyWrap283 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 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 (happyIn281 r)) - -happyReduce_701 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_701 = happyMonadReduce 3# 265# happyReduction_701 -happyReduction_701 (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 (happyIn281 r)) - -happyReduce_702 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_702 = happyMonadReduce 3# 265# 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 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 (happyIn281 r)) - -happyReduce_703 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_703 = happySpecReduce_1 266# happyReduction_703 -happyReduction_703 happy_x_1 - = case happyOut285 happy_x_1 of { (HappyWrap285 happy_var_1) -> - happyIn282 - (happy_var_1 - )} - -happyReduce_704 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_704 = happyMonadReduce 3# 266# happyReduction_704 -happyReduction_704 (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 happyOut283 happy_x_2 of { (HappyWrap283 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_705 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_705 = happySpecReduce_1 267# happyReduction_705 -happyReduction_705 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn283 - (sL1n happy_var_1 $! mkQual tcClsName (getQCONID happy_var_1) - )} - -happyReduce_706 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_706 = happySpecReduce_1 267# happyReduction_706 -happyReduction_706 happy_x_1 - = case happyOut284 happy_x_1 of { (HappyWrap284 happy_var_1) -> - happyIn283 - (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 268# happyReduction_707 -happyReduction_707 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn284 - (sL1n happy_var_1 $! mkUnqual tcClsName (getCONID 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 269# happyReduction_708 -happyReduction_708 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn285 - (sL1n happy_var_1 $! mkQual tcClsName (getQCONSYM 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 269# happyReduction_709 -happyReduction_709 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn285 - (sL1n happy_var_1 $! mkQual tcClsName (getQVARSYM 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 269# happyReduction_710 -happyReduction_710 happy_x_1 - = case happyOut286 happy_x_1 of { (HappyWrap286 happy_var_1) -> - happyIn285 - (happy_var_1 - )} - -happyReduce_711 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_711 = happySpecReduce_1 270# happyReduction_711 -happyReduction_711 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn286 - (sL1n happy_var_1 $! mkUnqual tcClsName (getCONSYM happy_var_1) - )} - -happyReduce_712 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_712 = happySpecReduce_1 270# happyReduction_712 -happyReduction_712 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn286 - (sL1n happy_var_1 $! mkUnqual tcClsName (getVARSYM happy_var_1) - )} - -happyReduce_713 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_713 = happySpecReduce_1 270# happyReduction_713 -happyReduction_713 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn286 - (sL1n happy_var_1 $! consDataCon_RDR - )} - -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 happyOutTok happy_x_1 of { happy_var_1 -> - happyIn286 - (sL1n happy_var_1 $! mkUnqual tcClsName (fsLit "-") - )} - -happyReduce_715 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_715 = happySpecReduce_1 270# happyReduction_715 -happyReduction_715 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn286 - (sL1n happy_var_1 $! mkUnqual tcClsName (fsLit ".") - )} - -happyReduce_716 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_716 = happySpecReduce_1 271# happyReduction_716 -happyReduction_716 happy_x_1 - = case happyOut284 happy_x_1 of { (HappyWrap284 happy_var_1) -> - happyIn287 - (happy_var_1 - )} - -happyReduce_717 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_717 = happyMonadReduce 3# 271# 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 happyOut286 happy_x_2 of { (HappyWrap286 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 (happyIn287 r)) - -happyReduce_718 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_718 = happySpecReduce_1 272# happyReduction_718 -happyReduction_718 happy_x_1 - = case happyOut289 happy_x_1 of { (HappyWrap289 happy_var_1) -> - happyIn288 - (happy_var_1 - )} - -happyReduce_719 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_719 = happySpecReduce_1 272# happyReduction_719 -happyReduction_719 happy_x_1 - = case happyOut276 happy_x_1 of { (HappyWrap276 happy_var_1) -> - happyIn288 - (happy_var_1 - )} - -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 $ getRdrName unrestrictedFunTyCon - )} - -happyReduce_721 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_721 = happySpecReduce_1 273# happyReduction_721 -happyReduction_721 happy_x_1 - = case happyOut306 happy_x_1 of { (HappyWrap306 happy_var_1) -> - happyIn289 - (happy_var_1 - )} - -happyReduce_722 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_722 = happyMonadReduce 3# 273# happyReduction_722 -happyReduction_722 (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 (happyIn289 r)) - -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 happyOut293 happy_x_1 of { (HappyWrap293 happy_var_1) -> - happyIn290 - (mkHsVarOpPV 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 happyOut277 happy_x_1 of { (HappyWrap277 happy_var_1) -> - happyIn290 - (mkHsConOpPV 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 happyOut292 happy_x_1 of { (HappyWrap292 happy_var_1) -> - happyIn290 - (pvN 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 happyOut294 happy_x_1 of { (HappyWrap294 happy_var_1) -> - happyIn291 - (mkHsVarOpPV 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 happyOut277 happy_x_1 of { (HappyWrap277 happy_var_1) -> - happyIn291 - (mkHsConOpPV 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 happyOut292 happy_x_1 of { (HappyWrap292 happy_var_1) -> - happyIn291 - (pvN happy_var_1 - )} - -happyReduce_729 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_729 = happySpecReduce_3 276# happyReduction_729 -happyReduction_729 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 -> - happyIn292 - (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_730 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_730 = happySpecReduce_1 277# happyReduction_730 -happyReduction_730 happy_x_1 - = case happyOut303 happy_x_1 of { (HappyWrap303 happy_var_1) -> - happyIn293 - (happy_var_1 - )} - -happyReduce_731 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_731 = happyMonadReduce 3# 277# happyReduction_731 -happyReduction_731 (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 -> - ( 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 (happyIn293 r)) - -happyReduce_732 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_732 = happySpecReduce_1 278# happyReduction_732 -happyReduction_732 happy_x_1 - = case happyOut304 happy_x_1 of { (HappyWrap304 happy_var_1) -> - happyIn294 - (happy_var_1 - )} - -happyReduce_733 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_733 = happyMonadReduce 3# 278# happyReduction_733 -happyReduction_733 (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 -> - ( 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_734 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_734 = happySpecReduce_1 279# happyReduction_734 -happyReduction_734 happy_x_1 - = case happyOut297 happy_x_1 of { (HappyWrap297 happy_var_1) -> - happyIn295 - (happy_var_1 - )} - -happyReduce_735 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_735 = happyMonadReduce 3# 280# happyReduction_735 -happyReduction_735 (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 happyOut297 happy_x_2 of { (HappyWrap297 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 (happyIn296 r)) - -happyReduce_736 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_736 = happySpecReduce_1 281# happyReduction_736 -happyReduction_736 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn297 - (sL1n happy_var_1 $! mkUnqual tvName (getVARID happy_var_1) - )} - -happyReduce_737 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_737 = happySpecReduce_1 281# happyReduction_737 -happyReduction_737 happy_x_1 - = case happyOut308 happy_x_1 of { (HappyWrap308 happy_var_1) -> - happyIn297 - (sL1n happy_var_1 $! mkUnqual tvName (unLoc happy_var_1) - )} - -happyReduce_738 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_738 = happySpecReduce_1 281# happyReduction_738 -happyReduction_738 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn297 - (sL1n happy_var_1 $! mkUnqual tvName (fsLit "unsafe") - )} - -happyReduce_739 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_739 = happySpecReduce_1 281# happyReduction_739 -happyReduction_739 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn297 - (sL1n happy_var_1 $! mkUnqual tvName (fsLit "safe") - )} - -happyReduce_740 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_740 = happySpecReduce_1 281# happyReduction_740 -happyReduction_740 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn297 - (sL1n happy_var_1 $! mkUnqual tvName (fsLit "interruptible") - )} - -happyReduce_741 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_741 = happySpecReduce_1 282# happyReduction_741 -happyReduction_741 happy_x_1 - = case happyOut302 happy_x_1 of { (HappyWrap302 happy_var_1) -> - happyIn298 - (happy_var_1 - )} - -happyReduce_742 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_742 = happyMonadReduce 3# 282# happyReduction_742 -happyReduction_742 (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 NameParens (glAA happy_var_1) (glNRR happy_var_2) (glAA happy_var_3) []))}}}) - ) (\r -> happyReturn (happyIn298 r)) - -happyReduce_743 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_743 = happySpecReduce_1 283# happyReduction_743 -happyReduction_743 happy_x_1 - = case happyOut301 happy_x_1 of { (HappyWrap301 happy_var_1) -> - happyIn299 - (happy_var_1 - )} - -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 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 NameParens (glAA happy_var_1) (glNRR happy_var_2) (glAA happy_var_3) []))}}}) - ) (\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 happyOut305 happy_x_2 of { (HappyWrap305 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 (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 happyOut302 happy_x_1 of { (HappyWrap302 happy_var_1) -> - happyIn300 - (fmap (FieldLabelString . occNameFS . rdrNameOcc) happy_var_1 - )} - -happyReduce_747 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_747 = happySpecReduce_1 285# happyReduction_747 -happyReduction_747 happy_x_1 - = case happyOut302 happy_x_1 of { (HappyWrap302 happy_var_1) -> - happyIn301 - (happy_var_1 - )} - -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 varName (getQVARID 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 286# happyReduction_749 -happyReduction_749 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn302 - (sL1n happy_var_1 $! mkUnqual varName (getVARID 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 happyOut308 happy_x_1 of { (HappyWrap308 happy_var_1) -> - happyIn302 - (sL1n happy_var_1 $! mkUnqual varName (unLoc 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 286# happyReduction_751 -happyReduction_751 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn302 - (sL1n happy_var_1 $! mkUnqual varName (fsLit "unsafe") - )} - -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 happyOutTok happy_x_1 of { happy_var_1 -> - happyIn302 - (sL1n happy_var_1 $! mkUnqual varName (fsLit "safe") - )} - -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 varName (fsLit "interruptible") - )} - -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 varName (fsLit "forall") - )} - -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 varName (fsLit "family") - )} - -happyReduce_756 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_756 = happySpecReduce_1 286# happyReduction_756 -happyReduction_756 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn302 - (sL1n happy_var_1 $! mkUnqual varName (fsLit "role") - )} - -happyReduce_757 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_757 = happySpecReduce_1 287# happyReduction_757 -happyReduction_757 happy_x_1 - = case happyOut306 happy_x_1 of { (HappyWrap306 happy_var_1) -> - happyIn303 - (happy_var_1 - )} - -happyReduce_758 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_758 = happySpecReduce_1 287# happyReduction_758 -happyReduction_758 happy_x_1 - = case happyOut305 happy_x_1 of { (HappyWrap305 happy_var_1) -> - happyIn303 - (happy_var_1 - )} - -happyReduce_759 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_759 = happySpecReduce_1 288# happyReduction_759 -happyReduction_759 happy_x_1 - = case happyOut307 happy_x_1 of { (HappyWrap307 happy_var_1) -> - happyIn304 - (happy_var_1 - )} - -happyReduce_760 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_760 = happySpecReduce_1 288# happyReduction_760 -happyReduction_760 happy_x_1 - = case happyOut305 happy_x_1 of { (HappyWrap305 happy_var_1) -> - happyIn304 - (happy_var_1 - )} - -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 happyOutTok happy_x_1 of { happy_var_1 -> - happyIn305 - (sL1n happy_var_1 $ mkQual varName (getQVARSYM 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 $ mkUnqual varName (fsLit "-") - )} - -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 (getVARSYM 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 happyOut309 happy_x_1 of { (HappyWrap309 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 292# happyReduction_766 -happyReduction_766 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn308 - (sL1 happy_var_1 (fsLit "as") - )} - -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 happyOutTok happy_x_1 of { happy_var_1 -> - happyIn308 - (sL1 happy_var_1 (fsLit "qualified") - )} - -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 happyOutTok happy_x_1 of { happy_var_1 -> - happyIn308 - (sL1 happy_var_1 (fsLit "hiding") - )} - -happyReduce_769 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_769 = happySpecReduce_1 292# happyReduction_769 -happyReduction_769 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn308 - (sL1 happy_var_1 (fsLit "export") - )} - -happyReduce_770 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_770 = happySpecReduce_1 292# happyReduction_770 -happyReduction_770 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn308 - (sL1 happy_var_1 (fsLit "label") - )} - -happyReduce_771 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_771 = happySpecReduce_1 292# happyReduction_771 -happyReduction_771 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn308 - (sL1 happy_var_1 (fsLit "dynamic") - )} - -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 happyOutTok happy_x_1 of { happy_var_1 -> - happyIn308 - (sL1 happy_var_1 (fsLit "stdcall") - )} - -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 happyOutTok happy_x_1 of { happy_var_1 -> - happyIn308 - (sL1 happy_var_1 (fsLit "ccall") - )} - -happyReduce_774 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_774 = happySpecReduce_1 292# happyReduction_774 -happyReduction_774 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn308 - (sL1 happy_var_1 (fsLit "capi") - )} - -happyReduce_775 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_775 = happySpecReduce_1 292# happyReduction_775 -happyReduction_775 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn308 - (sL1 happy_var_1 (fsLit "prim") - )} - -happyReduce_776 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_776 = happySpecReduce_1 292# happyReduction_776 -happyReduction_776 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn308 - (sL1 happy_var_1 (fsLit "javascript") - )} - -happyReduce_777 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_777 = happySpecReduce_1 292# happyReduction_777 -happyReduction_777 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn308 - (sL1 happy_var_1 (fsLit "group") - )} - -happyReduce_778 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_778 = happySpecReduce_1 292# happyReduction_778 -happyReduction_778 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn308 - (sL1 happy_var_1 (fsLit "stock") - )} - -happyReduce_779 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_779 = happySpecReduce_1 292# happyReduction_779 -happyReduction_779 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn308 - (sL1 happy_var_1 (fsLit "anyclass") - )} - -happyReduce_780 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_780 = happySpecReduce_1 292# happyReduction_780 -happyReduction_780 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn308 - (sL1 happy_var_1 (fsLit "via") - )} - -happyReduce_781 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_781 = happySpecReduce_1 292# happyReduction_781 -happyReduction_781 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn308 - (sL1 happy_var_1 (fsLit "unit") - )} - -happyReduce_782 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_782 = happySpecReduce_1 292# happyReduction_782 -happyReduction_782 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn308 - (sL1 happy_var_1 (fsLit "dependency") - )} - -happyReduce_783 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_783 = happySpecReduce_1 292# happyReduction_783 -happyReduction_783 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn308 - (sL1 happy_var_1 (fsLit "signature") - )} - -happyReduce_784 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_784 = happySpecReduce_1 293# happyReduction_784 -happyReduction_784 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn309 - (sL1 happy_var_1 (fsLit ".") - )} - -happyReduce_785 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_785 = happySpecReduce_1 293# happyReduction_785 -happyReduction_785 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn309 - (sL1 happy_var_1 (starSym (isUnicode happy_var_1)) - )} - -happyReduce_786 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_786 = happySpecReduce_1 294# happyReduction_786 -happyReduction_786 happy_x_1 - = case happyOut311 happy_x_1 of { (HappyWrap311 happy_var_1) -> - happyIn310 - (happy_var_1 - )} - -happyReduce_787 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_787 = happySpecReduce_1 294# happyReduction_787 -happyReduction_787 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn310 - (sL1n happy_var_1 $! mkQual dataName (getQCONID happy_var_1) - )} - -happyReduce_788 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_788 = happySpecReduce_1 295# happyReduction_788 -happyReduction_788 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn311 - (sL1n happy_var_1 $ mkUnqual dataName (getCONID happy_var_1) - )} - -happyReduce_789 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_789 = happySpecReduce_1 296# happyReduction_789 -happyReduction_789 happy_x_1 - = case happyOut313 happy_x_1 of { (HappyWrap313 happy_var_1) -> - happyIn312 - (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 296# happyReduction_790 -happyReduction_790 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn312 - (sL1n happy_var_1 $ mkQual dataName (getQCONSYM 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 297# happyReduction_791 -happyReduction_791 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn313 - (sL1n happy_var_1 $ mkUnqual dataName (getCONSYM 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 297# happyReduction_792 -happyReduction_792 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn313 - (sL1n happy_var_1 $ consDataCon_RDR - )} - -happyReduce_793 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_793 = happySpecReduce_1 298# happyReduction_793 -happyReduction_793 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn314 - (sL1 happy_var_1 $ HsChar (getCHARs happy_var_1) $ getCHAR 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 298# happyReduction_794 -happyReduction_794 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn314 - (sL1 happy_var_1 $ HsString (getSTRINGs happy_var_1) - $ getSTRING happy_var_1 - )} - -happyReduce_795 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_795 = happySpecReduce_1 298# happyReduction_795 -happyReduction_795 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn314 - (sL1 happy_var_1 $ HsIntPrim (getPRIMINTEGERs happy_var_1) - $ getPRIMINTEGER happy_var_1 - )} - -happyReduce_796 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_796 = happySpecReduce_1 298# happyReduction_796 -happyReduction_796 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn314 - (sL1 happy_var_1 $ HsWordPrim (getPRIMWORDs happy_var_1) - $ getPRIMWORD happy_var_1 - )} - -happyReduce_797 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_797 = happySpecReduce_1 298# happyReduction_797 -happyReduction_797 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn314 - (sL1 happy_var_1 $ HsCharPrim (getPRIMCHARs happy_var_1) - $ getPRIMCHAR happy_var_1 - )} - -happyReduce_798 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_798 = happySpecReduce_1 298# happyReduction_798 -happyReduction_798 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn314 - (sL1 happy_var_1 $ HsStringPrim (getPRIMSTRINGs happy_var_1) - $ getPRIMSTRING happy_var_1 - )} - -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 $ HsFloatPrim noExtField $ getPRIMFLOAT 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 298# happyReduction_800 -happyReduction_800 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn314 - (sL1 happy_var_1 $ HsDoublePrim noExtField $ getPRIMDOUBLE 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 - = happyIn315 - (() - ) - -happyReduce_802 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_802 = happyMonadReduce 1# 299# happyReduction_802 -happyReduction_802 (happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((( popContext)) - ) (\r -> happyReturn (happyIn315 r)) - -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 - (sL1a happy_var_1 $ mkModuleNameFS (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 300# happyReduction_804 -happyReduction_804 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn316 - (sL1a happy_var_1 $ let (mod,c) = getQCONID happy_var_1 in - mkModuleNameFS - (concatFS [mod, fsLit ".", c]) - )} - -happyReduce_805 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_805 = happySpecReduce_2 301# happyReduction_805 -happyReduction_805 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 -> - happyIn317 - (((fst happy_var_1)++[gl happy_var_2],snd happy_var_1 + 1) - )}} - -happyReduce_806 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_806 = happySpecReduce_1 301# happyReduction_806 -happyReduction_806 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn317 - (([gl happy_var_1],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 happyOut319 happy_x_1 of { (HappyWrap319 happy_var_1) -> - happyIn318 - (happy_var_1 - )} - -happyReduce_808 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_808 = happySpecReduce_0 302# happyReduction_808 -happyReduction_808 = happyIn318 - (([], 0) - ) - -happyReduce_809 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_809 = happySpecReduce_2 303# happyReduction_809 -happyReduction_809 happy_x_2 - happy_x_1 - = case happyOut319 happy_x_1 of { (HappyWrap319 happy_var_1) -> - case happyOutTok happy_x_2 of { happy_var_2 -> - happyIn319 - (((fst happy_var_1)++[gl happy_var_2],snd happy_var_1 + 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 - (([gl happy_var_1],1) - )} - -happyReduce_811 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_811 = happySpecReduce_3 304# happyReduction_811 -happyReduction_811 happy_x_3 - happy_x_2 - happy_x_1 - = 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 -> - happyIn320 - (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_812 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_812 = happySpecReduce_3 304# happyReduction_812 -happyReduction_812 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut324 happy_x_2 of { (HappyWrap324 happy_var_2) -> - happyIn320 - (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_813 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_813 = happySpecReduce_2 304# happyReduction_813 -happyReduction_813 happy_x_2 - happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOutTok happy_x_2 of { happy_var_2 -> - happyIn320 - (amsrl (sLL happy_var_1 happy_var_2 []) (AnnList Nothing (Just $ moc happy_var_1) (Just $ mcc happy_var_2) [] []) - )}} - -happyReduce_814 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_814 = happySpecReduce_2 304# happyReduction_814 -happyReduction_814 happy_x_2 - happy_x_1 - = happyIn320 - (return $ noLocA [] - ) - -happyReduce_815 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_815 = happySpecReduce_3 305# happyReduction_815 -happyReduction_815 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut325 happy_x_2 of { (HappyWrap325 happy_var_2) -> - case happyOutTok happy_x_3 of { happy_var_3 -> - happyIn321 - (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_816 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_816 = happySpecReduce_3 305# happyReduction_816 -happyReduction_816 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut325 happy_x_2 of { (HappyWrap325 happy_var_2) -> - happyIn321 - (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_817 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_817 = happySpecReduce_2 305# happyReduction_817 -happyReduction_817 happy_x_2 - happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOutTok happy_x_2 of { happy_var_2 -> - happyIn321 - (amsrl (sLL happy_var_1 happy_var_2 []) (AnnList Nothing (Just $ moc happy_var_1) (Just $ mcc happy_var_2) [] []) - )}} - -happyReduce_818 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_818 = happySpecReduce_2 305# happyReduction_818 -happyReduction_818 happy_x_2 - happy_x_1 - = happyIn321 - (return $ noLocA [] - ) - -happyReduce_819 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_819 = happyMonadReduce 2# 306# happyReduction_819 -happyReduction_819 (happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut212 happy_x_1 of { (HappyWrap212 happy_var_1) -> - case happyOut207 happy_x_2 of { (HappyWrap207 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 (happyIn322 r)) - -happyReduce_820 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_820 = happyMonadReduce 2# 307# happyReduction_820 -happyReduction_820 (happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut212 happy_x_1 of { (HappyWrap212 happy_var_1) -> - case happyOut209 happy_x_2 of { (HappyWrap209 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 (happyIn323 r)) - -happyReduce_821 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_821 = happySpecReduce_1 308# happyReduction_821 -happyReduction_821 happy_x_1 - = case happyOut326 happy_x_1 of { (HappyWrap326 happy_var_1) -> - happyIn324 - (happy_var_1 >>= \ happy_var_1 -> return $ - sL1 happy_var_1 (fst $ unLoc happy_var_1,snd $ unLoc happy_var_1) - )} - -happyReduce_822 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_822 = happySpecReduce_2 308# happyReduction_822 -happyReduction_822 happy_x_2 - happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut324 happy_x_2 of { (HappyWrap324 happy_var_2) -> - happyIn324 - (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_823 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_823 = happySpecReduce_1 309# happyReduction_823 -happyReduction_823 happy_x_1 - = case happyOut327 happy_x_1 of { (HappyWrap327 happy_var_1) -> - happyIn325 - (happy_var_1 >>= \ happy_var_1 -> return $ - sL1 happy_var_1 (fst $ unLoc happy_var_1,snd $ unLoc happy_var_1) - )} - -happyReduce_824 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_824 = happySpecReduce_2 309# happyReduction_824 -happyReduction_824 happy_x_2 - happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut325 happy_x_2 of { (HappyWrap325 happy_var_2) -> - happyIn325 - (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_825 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_825 = happySpecReduce_3 310# happyReduction_825 -happyReduction_825 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut326 happy_x_1 of { (HappyWrap326 happy_var_1) -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut328 happy_x_3 of { (HappyWrap328 happy_var_3) -> - happyIn326 - (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_826 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_826 = happySpecReduce_2 310# happyReduction_826 -happyReduction_826 happy_x_2 - happy_x_1 - = case happyOut326 happy_x_1 of { (HappyWrap326 happy_var_1) -> - case happyOutTok happy_x_2 of { happy_var_2 -> - happyIn326 - (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_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 happyOut328 happy_x_1 of { (HappyWrap328 happy_var_1) -> - happyIn326 - (happy_var_1 >>= \ happy_var_1 -> return $ sL1 (reLoc happy_var_1) ([],[happy_var_1]) - )} - -happyReduce_828 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_828 = happySpecReduce_3 311# happyReduction_828 -happyReduction_828 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut327 happy_x_1 of { (HappyWrap327 happy_var_1) -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut329 happy_x_3 of { (HappyWrap329 happy_var_3) -> - happyIn327 - (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_829 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_829 = happySpecReduce_2 311# happyReduction_829 -happyReduction_829 happy_x_2 - happy_x_1 - = case happyOut327 happy_x_1 of { (HappyWrap327 happy_var_1) -> - case happyOutTok happy_x_2 of { happy_var_2 -> - happyIn327 - (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_830 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_830 = happySpecReduce_1 311# happyReduction_830 -happyReduction_830 happy_x_1 - = case happyOut329 happy_x_1 of { (HappyWrap329 happy_var_1) -> - happyIn327 - (happy_var_1 >>= \ happy_var_1 -> return $ sL1 (reLoc happy_var_1) ([],[happy_var_1]) - )} - -happyReduce_831 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_831 = happySpecReduce_2 312# happyReduction_831 -happyReduction_831 happy_x_2 - happy_x_1 - = case happyOut246 happy_x_1 of { (HappyWrap246 happy_var_1) -> - case happyOut237 happy_x_2 of { (HappyWrap237 happy_var_2) -> - happyIn328 - (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_832 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_832 = happySpecReduce_2 313# happyReduction_832 -happyReduction_832 happy_x_2 - happy_x_1 - = case happyOut243 happy_x_1 of { (HappyWrap243 happy_var_1) -> - case happyOut237 happy_x_2 of { (HappyWrap237 happy_var_2) -> - happyIn329 - (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 150# 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 _ (ITprimfloat _) -> cont 136#; - L _ (ITprimdouble _) -> cont 137#; - L _ (ITopenExpQuote _ _) -> cont 138#; - L _ ITopenPatQuote -> cont 139#; - L _ ITopenTypQuote -> cont 140#; - L _ ITopenDecQuote -> cont 141#; - L _ (ITcloseQuote _) -> cont 142#; - L _ (ITopenTExpQuote _) -> cont 143#; - L _ ITcloseTExpQuote -> cont 144#; - L _ ITdollar -> cont 145#; - L _ ITdollardollar -> cont 146#; - L _ ITtyQuote -> cont 147#; - L _ (ITquasiQuote _) -> cont 148#; - L _ (ITqQuasiQuote _) -> cont 149#; - _ -> happyError' (tk, []) - }) - -happyError_ explist 150# 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 {(HappyWrap62 x') = happyOut62 x} in x')) - -parseStatement = happySomeParser where - happySomeParser = happyThen (happyParse 3#) (\x -> happyReturn (let {(HappyWrap250 x') = happyOut250 x} in x')) - -parseDeclaration = happySomeParser where - happySomeParser = happyThen (happyParse 4#) (\x -> happyReturn (let {(HappyWrap78 x') = happyOut78 x} in x')) - -parseExpression = happySomeParser where - happySomeParser = happyThen (happyParse 5#) (\x -> happyReturn (let {(HappyWrap207 x') = happyOut207 x} in x')) - -parsePattern = happySomeParser where - happySomeParser = happyThen (happyParse 6#) (\x -> happyReturn (let {(HappyWrap242 x') = happyOut242 x} in x')) - -parseTypeSignature = happySomeParser where - happySomeParser = happyThen (happyParse 7#) (\x -> happyReturn (let {(HappyWrap203 x') = happyOut203 x} in x')) - -parseStmt = happySomeParser where - happySomeParser = happyThen (happyParse 8#) (\x -> happyReturn (let {(HappyWrap249 x') = happyOut249 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 {(HappyWrap159 x') = happyOut159 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 -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 - -getLABELVARIDs (L _ (ITlabelvarid src _)) = src - --- See Note [Pragma source text] in "GHC.Types.Basic" 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)) - -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 - -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 -> Located a) -> P (Located a) -acsFinal a = do - let (L l _) = a emptyComments - cs <- getCommentsFor l - csf <- getFinalCommentsFor l - meof <- getEofPos - let ce = case meof of - Strict.Nothing -> EpaComments [] - Strict.Just (pos `Strict.And` gap) -> - EpaCommentsBalanced [] [L (realSpanAsAnchor pos) (EpaComment EpaEofComment gap)] - return (a (cs Semi.<> csf Semi.<> 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 - -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,1297 +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(..), - 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) - -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_name :: 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 "foo") (-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 n t) - = text "NameAnnRArrow" <+> ppr n <+> 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,27 +23,28 @@ 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 - defaultDiagnosticOpts = NoDiagnosticOpts - diagnosticMessage _ = \case - PsUnknownMessage (UnknownDiagnostic @e m) - -> diagnosticMessage (defaultDiagnosticOpts @e) m + diagnosticMessage opts = \case + PsUnknownMessage (UnknownDiagnostic f _ m) + -> diagnosticMessage (f opts) m PsHeaderMessage m -> psHeaderMessageDiagnostic m @@ -121,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 @@ -129,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" @@ -202,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)" @@ -248,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 @@ -262,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" @@ -328,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 @@ -348,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 @@ -370,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 @@ -395,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 @@ -430,14 +455,6 @@ -> mkSimpleDecorated $ text "Malformed" <+> what <+> text "declaration for" <+> quotes (ppr for) - PsErrUnexpectedTypeAppInDecl ki what for - -> mkSimpleDecorated $ - vcat [ text "Unexpected type application" - <+> text "@" <> ppr ki - , text "In the" <+> what - <+> text "declaration for" - <+> quotes (ppr for) - ] PsErrNotADataCon name -> mkSimpleDecorated $ text "Not a data constructor:" <+> quotes (ppr name) PsErrInferredTypeVarNotAllowed @@ -451,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) @@ -471,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) @@ -523,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 @@ -538,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 @@ -568,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 @@ -593,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 @@ -611,7 +666,6 @@ PsErrMDoInFunAppExpr{} -> ErrorWithoutFlag PsErrLambdaInFunAppExpr{} -> ErrorWithoutFlag PsErrCaseInFunAppExpr{} -> ErrorWithoutFlag - PsErrLambdaCaseInFunAppExpr{} -> ErrorWithoutFlag PsErrLetInFunAppExpr{} -> ErrorWithoutFlag PsErrIfInFunAppExpr{} -> ErrorWithoutFlag PsErrProcInFunAppExpr{} -> ErrorWithoutFlag @@ -626,7 +680,6 @@ PsErrAtInPatPos -> ErrorWithoutFlag PsErrParseErrorOnInput{} -> ErrorWithoutFlag PsErrMalformedDecl{} -> ErrorWithoutFlag - PsErrUnexpectedTypeAppInDecl{} -> ErrorWithoutFlag PsErrNotADataCon{} -> ErrorWithoutFlag PsErrInferredTypeVarNotAllowed -> ErrorWithoutFlag PsErrIllegalTraditionalRecordSyntax{} -> ErrorWithoutFlag @@ -641,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 @@ -663,6 +722,7 @@ PsWarnMisplacedPragma{} -> [SuggestPlacePragmaInHeader] PsWarnImportPreQualified -> [ SuggestQualifiedAfterModuleName , suggestExtension LangExt.ImportQualifiedPost] + PsWarnViewPatternSignatures{} -> [SuggestParenthesizePatternRHS] PsErrLexer{} -> noHints PsErrCmmLexer -> noHints PsErrCmmParser{} -> noHints @@ -694,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 @@ -706,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 @@ -732,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 @@ -750,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 @@ -767,7 +821,6 @@ PsErrAtInPatPos -> noHints PsErrParseErrorOnInput{} -> noHints PsErrMalformedDecl{} -> noHints - PsErrUnexpectedTypeAppInDecl{} -> noHints PsErrNotADataCon{} -> noHints PsErrInferredTypeVarNotAllowed -> noHints PsErrIllegalTraditionalRecordSyntax{} -> [suggestExtension LangExt.TraditionalRecordSyntax] @@ -784,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 @@ -812,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 + 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) @@ -367,9 +379,6 @@ -- | Malformed ... declaration for ... | PsErrMalformedDecl !SDoc !RdrName - -- | Unexpected type application in a declaration - | PsErrUnexpectedTypeAppInDecl !(LHsType GhcPs) !SDoc !RdrName - -- | Not a data constructor | PsErrNotADataCon !RdrName @@ -401,7 +410,7 @@ | PsErrIllegalRoleName !FastString [Role] -- | Invalid type signature - | PsErrInvalidTypeSignature !(LHsExpr GhcPs) + | PsErrInvalidTypeSignature !PsInvalidTypeSignature !(LHsExpr GhcPs) -- | Unexpected type in declaration | PsErrUnexpectedTypeInDecl !(LHsType GhcPs) @@ -460,7 +469,7 @@ | PsErrParseRightOpSectionInPat !RdrName !(PatBuilder GhcPs) -- | Illegal linear arrow or multiplicity annotation in GADT record syntax - | PsErrIllegalGadtRecordMultiplicity !(HsArrow GhcPs) + | PsErrIllegalGadtRecordMultiplicity !(HsMultAnn GhcPs) | PsErrInvalidCApiImport @@ -471,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 @@ -490,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 @@ -514,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 @@ -536,6 +601,7 @@ | NumUnderscore_Float deriving (Show,Eq,Ord) + data LexErrKind = LexErrKind_EOF -- ^ End of input | LexErrKind_UTF8 -- ^ UTF-8 decoding error @@ -547,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.6.7-src/ghc-9.6.7/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,13 +11,13 @@ 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 import GHC.Data.StringBuffer import qualified GHC.Data.Strict as Strict import GHC.Types.Name.Reader -import GHC.Utils.Outputable import GHC.Utils.Error import GHC.Utils.Encoding import GHC.Hs.Extension @@ -110,120 +108,6 @@ , (0,alex_action_1) ] -{-# LINE 87 "_build/source-dist/ghc-9.6.7-src/ghc-9.6.7/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 = DiagOpts - { diag_warning_flags = EnumSet.empty - , diag_fatal_warning_flags = EnumSet.empty - , diag_warn_is_error = False - , diag_reverse_errors = False - , diag_max_errors = Nothing - , diag_ppr_ctx = defaultSDocContext - } - 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 @@ -393,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 @@ -468,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,4011 +1,4028 @@ {-# OPTIONS_GHC -fno-warn-unused-binds -fno-warn-missing-signatures #-} {-# LANGUAGE CPP #-} {-# LANGUAGE MagicHash #-} -{-# LINE 43 "_build/source-dist/ghc-9.6.7-src/ghc-9.6.7/compiler/GHC/Parser/Lexer.x" #-} -{-# LANGUAGE BangPatterns #-} -{-# 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\x00\x00\x00\x00\x00\x00\x00\x00\x85\xff\xff\xff\x00\x00\x00\x00\x03\x02\x00\x00\xd7\xff\xff\xff\xc3\x00\x00\x00\x7d\x02\x00\x00\x8b\xff\xff\xff\xd7\x02\x00\x00\x00\x00\x00\x00\x17\x03\x00\x00\x91\x03\x00\x00\xcb\x03\x00\x00\x25\x04\x00\x00\x9f\x04\x00\x00\x64\x01\x00\x00\xfc\x00\x00\x00\x15\x05\x00\x00\xdc\xff\xff\xff\x2e\x05\x00\x00\x92\xff\xff\xff\x00\x00\x00\x00\xe3\xff\xff\xff\x94\xff\xff\xff\x61\x00\x00\x00\x00\x00\x00\x00\x85\x01\x00\x00\xa4\x05\x00\x00\x39\x01\x00\x00\xe4\x05\x00\x00\x62\x06\x00\x00\x81\x00\x00\x00\x82\x00\x00\x00\x6a\x01\x00\x00\x08\x00\x00\x00\x09\x00\x00\x00\xe0\x06\x00\x00\xe1\x01\x00\x00\x56\x07\x00\x00\xa0\x01\x00\x00\x96\x07\x00\x00\x14\x08\x00\x00\x92\x08\x00\x00\x0c\x09\x00\x00\x86\x09\x00\x00\x00\x0a\x00\x00\x7a\x0a\x00\x00\x28\x01\x00\x00\xf4\x0a\x00\x00\x6e\x0b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe7\xff\xff\xff\xe8\x0b\x00\x00\x62\x0c\x00\x00\x1f\x02\x00\x00\xf4\xff\xff\xff\x0c\x00\x00\x00\x00\x00\x00\x00\x0d\x00\x00\x00\x00\x00\x00\x00\xa6\xff\xff\xff\xbc\x0c\x00\x00\xb8\xff\xff\xff\xb3\xff\xff\xff\xae\xff\xff\xff\xbb\xff\xff\xff\x13\x00\x00\x00\x00\x00\x00\x00\x71\x00\x00\x00\xb5\xff\xff\xff\xb1\xff\xff\xff\x6c\x03\x00\x00\x5b\x02\x00\x00\x8a\x05\x00\x00\x7a\x04\x00\x00\x36\x07\x00\x00\x6e\x02\x00\x00\x14\x0d\x00\x00\x4c\x07\x00\x00\x1d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf7\x02\x00\x00\x00\x00\x00\x00\x16\x00\x00\x00\x00\x00\x00\x00\x21\x04\x00\x00\xf0\x00\x00\x00\x49\x01\x00\x00\x51\x0d\x00\x00\x79\x0d\x00\x00\xbc\x0d\x00\x00\xe4\x0d\x00\x00\x56\x00\x00\x00\x27\x0e\x00\x00\x4f\x0e\x00\x00\x89\x00\x00\x00\x8a\x00\x00\x00\x8b\x00\x00\x00\x8c\x00\x00\x00\x8d\x00\x00\x00\x8e\x00\x00\x00\x8f\x00\x00\x00\x6d\x00\x00\x00\x05\x02\x00\x00\x00\x00\x00\x00\xec\x00\x00\x00\x8f\x0e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x79\x00\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\x7c\x00\x00\x00\x7d\x00\x00\x00\x7e\x00\x00\x00\x7f\x00\x00\x00\xf6\x04\x00\x00\xdc\x0e\x00\x00\x08\x03\x00\x00\x1d\x0f\x00\x00\x90\x04\x00\x00\x47\x0b\x00\x00\x5e\x0f\x00\x00\x0a\x05\x00\x00\x9f\x0f\x00\x00\x76\x03\x00\x00\xe0\x0f\x00\x00\x45\x05\x00\x00\xc1\x0b\x00\x00\x21\x10\x00\x00\x95\x05\x00\x00\x2b\x04\x00\x00\x4f\x05\x00\x00\x55\x0a\x00\x00\xbe\x06\x00\x00\x3d\x0c\x00\x00\xc5\x05\x00\x00\x73\x08\x00\x00\x3a\x06\x00\x00\xea\x08\x00\x00\xd1\x06\x00\x00\x65\x10\x00\x00\xa6\x10\x00\x00\x67\x09\x00\x00\x2f\x05\x00\x00\xbf\x00\x00\x00\xba\x00\x00\x00\x33\x0d\x00\x00\xbf\x10\x00\x00\x08\x11\x00\x00\x49\x11\x00\x00\xe1\x09\x00\x00\xd2\x0a\x00\x00\x79\x02\x00\x00\xc4\x00\x00\x00\x62\x11\x00\x00\x83\x11\x00\x00\xc6\x11\x00\x00\xfb\x11\x00\x00\x41\x12\x00\x00\x64\x12\x00\x00\x87\x12\x00\x00\x80\x00\x00\x00\x90\x00\x00\x00\x9b\x00\x00\x00\x9c\x00\x00\x00\xa1\x00\x00\x00\xa9\x00\x00\x00\xc7\x12\x00\x00\x41\x13\x00\x00\xbb\x13\x00\x00\x35\x14\x00\x00\xaf\x14\x00\x00\x29\x15\x00\x00\xa3\x15\x00\x00\x1d\x16\x00\x00\x97\x16\x00\x00\x11\x17\x00\x00\x4b\x17\x00\x00\xc5\x17\x00\x00\x3f\x18\x00\x00\xb9\x18\x00\x00\x42\x00\x00\x00\x67\x00\x00\x00\x47\x00\x00\x00\x6a\x00\x00\x00\x33\x19\x00\x00\xad\x19\x00\x00\x27\x1a\x00\x00\xa1\x1a\x00\x00\x1b\x1b\x00\x00\x95\x1b\x00\x00\x0f\x1c\x00\x00\x89\x1c\x00\x00\x03\x1d\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\x7d\x1d\x00\x00\x00\x00\x00\x00\xbd\x00\x00\x00\x00\x00\x00\x00\xfb\x1d\x00\x00\x75\x1e\x00\x00\x00\x00\x00\x00\xcf\x1e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0f\x1f\x00\x00\x00\x00\x00\x00\x8b\x1f\x00\x00\x23\x01\x00\x00\xb7\x00\x00\x00\x00\x00\x00\x00\x07\x20\x00\x00\x00\x00\x00\x00\x83\x20\x00\x00\x00\x00\x00\x00\xff\x20\x00\x00\x00\x00\x00\x00\x70\x00\x00\x00\x00\x00\x00\x00\x59\x21\x00\x00"# - -alex_table :: AlexAddr -alex_table = AlexA# - "\x00\x00\x0d\x00\xc2\x00\x44\x00\x12\x00\xb9\x00\x7a\x00\x63\x00\x16\x00\x21\x00\x79\x00\x3f\x00\x7a\x00\x7a\x00\x7a\x00\x22\x00\x24\x00\x26\x00\xff\xff\xff\xff\x3c\x00\x48\x00\x49\x00\x4b\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x56\x00\x5f\x00\xff\xff\x7a\x00\xb9\x00\x7c\x00\xe7\x00\xb9\x00\xb9\x00\xb9\x00\x7d\x00\xe9\x00\xe4\x00\xb9\x00\xb9\x00\xe1\x00\xb8\x00\xb9\x00\xb9\x00\xb6\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb7\x00\xe0\x00\xb9\x00\xb9\x00\xb9\x00\x20\x00\xb9\x00\xc2\x00\xc2\x00\xc2\x00\xc2\x00\xc2\x00\xc2\x00\xc2\x00\xc2\x00\xc2\x00\xc2\x00\xc2\x00\xc2\x00\xc2\x00\xc2\x00\xc2\x00\xc2\x00\xc2\x00\xc2\x00\xc2\x00\xc2\x00\xc2\x00\xc2\x00\xc2\x00\xc2\x00\xc2\x00\xc2\x00\x19\x00\xb9\x00\xe2\x00\xb9\x00\xc5\x00\xdf\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x11\x00\xee\x00\xdd\x00\xb9\x00\x7a\x00\x65\x00\x60\x00\x6e\x00\x79\x00\x61\x00\x7a\x00\x7a\x00\x7a\x00\x7a\x00\x65\x00\xff\xff\xff\xff\x79\x00\x6e\x00\x7a\x00\x7a\x00\x7a\x00\x4a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3c\x00\x46\x00\x7e\x00\x80\x00\x54\x00\x82\x00\x83\x00\x84\x00\x85\x00\xbc\x00\x7a\x00\x7a\x00\x65\x00\x41\x00\x6d\x00\x79\x00\x42\x00\x7a\x00\x7a\x00\x7a\x00\x76\x00\x6b\x00\xd1\x00\x6d\x00\x31\x00\xbf\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\xbd\x00\xbf\x00\x7a\x00\x7a\x00\x65\x00\xd3\x00\xc0\x00\x79\x00\x42\x00\x7a\x00\x7a\x00\x7a\x00\x7a\x00\x65\x00\xc1\x00\x6d\x00\x79\x00\x42\x00\x7a\x00\x7a\x00\x7a\x00\x7a\x00\x65\x00\xd0\x00\xd2\x00\x79\x00\x78\x00\x7a\x00\x7a\x00\x7a\x00\x7a\x00\x55\x00\x26\x00\xd3\x00\xe8\x00\x4c\x00\x88\x00\xf4\x00\x14\x00\x7a\x00\x13\x00\x0f\x00\xd3\x00\x6d\x00\xab\x00\xab\x00\xfc\x00\x0f\x00\x7a\x00\xab\x00\xab\x00\x7a\x00\x6d\x00\x00\x00\xb3\x00\xb3\x00\x77\x00\x7a\x00\x7a\x00\x7a\x00\xff\xff\x6d\x00\x7a\x00\x65\x00\x00\x00\x77\x00\x79\x00\x1d\x00\x7a\x00\x7a\x00\x7a\x00\x00\x00\x1d\x00\x1d\x00\x1d\x00\x1d\x00\x2e\x00\x64\x00\x7a\x00\x00\x00\x2f\x00\xff\xff\x2e\x00\x2e\x00\x2e\x00\x00\x00\x72\x00\x00\x00\x00\x00\x7a\x00\x00\x00\xac\x00\x72\x00\x43\x00\x1d\x00\x00\x00\xac\x00\x1f\x00\x00\x00\x0f\x00\x00\x00\xb4\x00\x6d\x00\x2e\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\x2d\x00\x00\x00\x7a\x00\x65\x00\x00\x00\x43\x00\x79\x00\xef\x00\x7a\x00\x7a\x00\x7a\x00\x00\x00\x29\x00\x0f\x00\x43\x00\x40\x00\x00\x00\x00\x00\x29\x00\x29\x00\x29\x00\x0f\x00\xf4\x00\x77\x00\x00\x00\x3d\x00\x0f\x00\x0f\x00\x72\x00\x7a\x00\x7a\x00\x65\x00\x0f\x00\xff\xff\x79\x00\x00\x00\x7a\x00\x7a\x00\x7a\x00\x29\x00\x00\x00\x2a\x00\x6d\x00\x00\x00\x00\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x00\x00\x00\x00\x7a\x00\x72\x00\x71\x00\x23\x00\x2e\x00\x00\x00\x00\x00\x77\x00\x71\x00\xff\xff\x2e\x00\x2e\x00\x2e\x00\x25\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2c\x00\x0f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0f\x00\xc3\x00\xc4\x00\x00\x00\x2e\x00\x7a\x00\x65\x00\x00\x00\x00\x00\x79\x00\x3f\x00\x7a\x00\x7a\x00\x7a\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x00\x00\x0f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0f\x00\x34\x00\x7a\x00\x71\x00\x00\x00\xf5\x00\x77\x00\x34\x00\x34\x00\x34\x00\xe5\x00\xe4\x00\x00\x00\x00\x00\xe1\x00\x6d\x00\x00\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x00\x00\x34\x00\xe0\x00\x35\x00\x1c\x00\x00\x00\x71\x00\x77\x00\xc3\x00\xc3\x00\xc3\x00\xc3\x00\xc3\x00\xc3\x00\xc3\x00\xc3\x00\xc3\x00\xc3\x00\xc3\x00\xc3\x00\xc3\x00\xc3\x00\xc3\x00\xc3\x00\xc3\x00\xc3\x00\xc3\x00\xc3\x00\xc3\x00\xc3\x00\xc3\x00\xc3\x00\xc3\x00\xc3\x00\xe3\x00\x00\x00\xe2\x00\x27\x00\xc4\x00\xdf\x00\xc4\x00\xc4\x00\xc4\x00\xc4\x00\xc4\x00\xc4\x00\xc4\x00\xc4\x00\xc4\x00\xc4\x00\xc4\x00\xc4\x00\xc4\x00\xc4\x00\xc4\x00\xc4\x00\xc4\x00\xc4\x00\xc4\x00\xc4\x00\xc4\x00\xc4\x00\xc4\x00\xc4\x00\xc4\x00\xc4\x00\xde\x00\x00\x00\xdd\x00\x3a\x00\x3a\x00\x3a\x00\x00\x00\x39\x00\x00\x00\x3a\x00\x00\x00\x00\x00\x39\x00\x39\x00\x39\x00\x39\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\x00\x00\x00\x00\x00\x00\x39\x00\x7a\x00\xf4\x00\x00\x00\x00\x00\x10\x00\x0f\x00\x7a\x00\x7a\x00\x7a\x00\x00\x00\x00\x00\x0f\x00\x00\x00\x00\x00\x00\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x00\x00\x00\x00\x7a\x00\x32\x00\x00\x00\x47\x00\x00\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\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\x3a\x00\x0f\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x38\x00\x38\x00\x38\x00\x0f\x00\x37\x00\x00\x00\x38\x00\x00\x00\x00\x00\x37\x00\x37\x00\x37\x00\x37\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x8c\x00\x37\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x00\x00\xb3\x00\xb3\x00\x00\x00\x00\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\xb4\x00\x00\x00\x00\x00\xb9\x00\x38\x00\x00\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\xb9\x00\x00\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\x00\x00\x00\x00\x00\x00\xb9\x00\xb9\x00\x00\x00\xb9\x00\xb9\x00\xb9\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb9\x00\x00\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\x1b\x00\x1b\x00\x1b\x00\x00\x00\x17\x00\x00\x00\x1b\x00\x00\x00\x00\x00\x17\x00\x17\x00\x17\x00\x17\x00\x00\x00\x00\x00\x95\x00\x95\x00\x95\x00\x95\x00\x95\x00\x95\x00\x95\x00\x95\x00\x95\x00\x95\x00\x00\x00\x00\x00\xb9\x00\x00\x00\xb9\x00\x00\x00\x17\x00\x8e\x00\x8e\x00\x8e\x00\x8e\x00\x8e\x00\x8e\x00\x8e\x00\x8e\x00\x8e\x00\x8e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1b\x00\x1b\x00\x1b\x00\x1b\x00\x1b\x00\x1b\x00\x1b\x00\x1b\x00\x1b\x00\x1b\x00\x00\x00\x00\x00\xb9\x00\x16\x00\xb9\x00\x62\x00\x00\x00\x1b\x00\x1b\x00\x1b\x00\x1b\x00\x1b\x00\x1b\x00\x1b\x00\x1b\x00\x1b\x00\x1b\x00\x1b\x00\x1b\x00\x1b\x00\x1b\x00\x1b\x00\x1b\x00\x1b\x00\x1b\x00\x1b\x00\x1b\x00\x1b\x00\x1b\x00\x1b\x00\x1b\x00\x1b\x00\x1b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1b\x00\x00\x00\x1b\x00\x1b\x00\x1b\x00\x1b\x00\x1b\x00\x1b\x00\x1b\x00\x1b\x00\x1b\x00\x1b\x00\x1b\x00\x1b\x00\x1b\x00\x1b\x00\x1b\x00\x1b\x00\x1b\x00\x1b\x00\x1b\x00\x1b\x00\x1b\x00\x1b\x00\x1b\x00\x1b\x00\x1b\x00\x1b\x00\x18\x00\x18\x00\x18\x00\x00\x00\x00\x00\x00\x00\x18\x00\x00\x00\x00\x00\x00\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x95\x00\x95\x00\x95\x00\x95\x00\x95\x00\x95\x00\x95\x00\x95\x00\x95\x00\x95\x00\x00\x00\xa6\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\x1a\x00\x00\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x57\x00\x18\x00\xf3\x00\x00\x00\x00\x00\x00\x00\xa6\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x00\x00\x00\x00\x00\x00\x00\x00\x18\x00\x00\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\xf1\x00\x00\x00\x00\x00\xf3\x00\x00\x00\xf3\x00\xf3\x00\xf3\x00\xf9\x00\x7b\x00\xf3\x00\xf3\x00\xf3\x00\xf3\x00\xf3\x00\xf3\x00\xf3\x00\xf3\x00\xf3\x00\xf3\x00\xfb\x00\xf3\x00\xf3\x00\xf3\x00\xf7\x00\xf3\x00\xf3\x00\xf3\x00\xf3\x00\xf3\x00\xf3\x00\x00\x00\x0e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x8e\x00\x8e\x00\x8e\x00\x8e\x00\x8e\x00\x8e\x00\x8e\x00\x8e\x00\x8e\x00\x8e\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x00\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x66\x00\x00\x00\x00\x00\x00\x00\xf1\x00\x00\x00\xf1\x00\xf1\x00\xf1\x00\xf1\x00\xf1\x00\xf1\x00\xf1\x00\xf1\x00\xf1\x00\xf1\x00\xf1\x00\xf1\x00\xf1\x00\xf1\x00\xf1\x00\xf1\x00\xf1\x00\xf1\x00\xf1\x00\xf1\x00\xf1\x00\xf1\x00\xf1\x00\xf1\x00\xf1\x00\xf1\x00\x1b\x00\x1b\x00\x1b\x00\x00\x00\x00\x00\x00\x00\x1b\x00\x00\x00\x00\x00\x00\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x00\x00\x90\x00\x00\x00\xa6\x00\x8e\x00\x8e\x00\x8e\x00\x8e\x00\x8e\x00\x8e\x00\x8e\x00\x8e\x00\x8e\x00\x8e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1b\x00\x1b\x00\x1b\x00\x1b\x00\x1b\x00\x1b\x00\x1b\x00\x1b\x00\x1b\x00\x1b\x00\x5a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa6\x00\x1b\x00\x1b\x00\x1b\x00\x1b\x00\x1b\x00\x1b\x00\x1b\x00\x1b\x00\x1b\x00\x1b\x00\x1b\x00\x1b\x00\x1b\x00\x1b\x00\x1b\x00\x1b\x00\x1b\x00\x1b\x00\x1b\x00\x1b\x00\x1b\x00\x1b\x00\x1b\x00\x1b\x00\x1b\x00\x1b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1b\x00\x00\x00\x1b\x00\x1b\x00\x1b\x00\x1b\x00\x1b\x00\x1b\x00\x1b\x00\x1b\x00\x1b\x00\x1b\x00\x1b\x00\x1b\x00\x1b\x00\x1b\x00\x1b\x00\x1b\x00\x1b\x00\x1b\x00\x1b\x00\x1b\x00\x1b\x00\x1b\x00\x1b\x00\x1b\x00\x1b\x00\x1b\x00\x1d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1d\x00\x1d\x00\x1d\x00\x1d\x00\x00\x00\x00\x00\x00\x00\x8e\x00\x8e\x00\x8e\x00\x8e\x00\x8e\x00\x8e\x00\x8e\x00\x8e\x00\x8e\x00\x8e\x00\xec\x00\x00\x00\xb9\x00\x00\x00\x00\x00\x1d\x00\x00\x00\x00\x00\x1f\x00\x00\x00\x95\x00\x95\x00\x95\x00\x95\x00\x95\x00\x95\x00\x95\x00\x95\x00\x95\x00\x95\x00\x00\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\xb9\x00\x00\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\x66\x00\x00\x00\x00\x00\xb9\x00\xb9\x00\x00\x00\xb9\x00\xb9\x00\xb9\x00\x00\x00\xa9\x00\xa9\x00\xa9\x00\xa9\x00\xa9\x00\xa9\x00\xa9\x00\xa9\x00\x00\x00\xb9\x00\x62\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\x00\x00\x97\x00\x00\x00\x97\x00\x00\x00\x1c\x00\x95\x00\x95\x00\x95\x00\x95\x00\x95\x00\x95\x00\x95\x00\x95\x00\x95\x00\x95\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x00\x00\xb9\x00\x00\x00\xb9\x00\xec\x00\xaa\x00\xec\x00\xec\x00\xec\x00\xec\x00\xec\x00\xec\x00\xec\x00\xec\x00\xec\x00\xec\x00\xec\x00\xec\x00\xec\x00\xec\x00\xec\x00\xec\x00\xec\x00\xec\x00\xec\x00\xec\x00\xec\x00\xec\x00\xec\x00\xec\x00\xec\x00\xec\x00\x29\x00\xb9\x00\x00\x00\xb9\x00\x81\x00\x9e\x00\x29\x00\x29\x00\x29\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7f\x00\x00\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x29\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\xa6\x00\x00\x00\x00\x00\x00\x00\x00\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x57\x00\x2a\x00\x2a\x00\x00\x00\x00\x00\x00\x00\xa6\x00\x9d\x00\x00\x00\x9d\x00\x00\x00\x9e\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\x27\x00\x2a\x00\x2a\x00\x2b\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x00\x00\x2a\x00\x2a\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2a\x00\x2a\x00\x2b\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x3b\x00\x3b\x00\x3b\x00\x00\x00\x31\x00\x00\x00\x3b\x00\x00\x00\x00\x00\x3d\x00\x31\x00\x31\x00\x31\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\xa4\x00\x00\x00\xa4\x00\x00\x00\x31\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\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x00\x00\x00\x00\x00\x00\xa0\x00\x00\x00\x00\x00\x00\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3b\x00\x00\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x34\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x34\x00\x34\x00\x34\x00\x00\x00\x00\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x34\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa2\x00\xad\x00\xad\x00\xad\x00\xad\x00\xad\x00\xad\x00\xad\x00\xad\x00\xad\x00\xad\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x00\x00\xa2\x00\x00\x00\x00\x00\x00\x00\x5b\x00\x00\x00\x35\x00\x35\x00\x35\x00\x35\x00\xa2\x00\x35\x00\x35\x00\x00\x00\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\xa2\x00\x00\x00\x00\x00\x00\x00\x32\x00\x35\x00\x35\x00\x36\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x00\x00\x35\x00\x35\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x35\x00\x35\x00\x36\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x38\x00\x38\x00\x38\x00\x81\x00\x37\x00\x00\x00\x38\x00\x00\x00\x00\x00\x37\x00\x37\x00\x37\x00\x37\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\x37\x00\x00\x00\x00\x00\x00\x00\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\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa5\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x00\x00\x00\x00\x00\x00\x00\x00\x38\x00\x00\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x00\x00\x17\x00\x00\x00\x38\x00\x00\x00\x00\x00\x17\x00\x17\x00\x17\x00\x17\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\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\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x00\x00\x00\x00\x00\x00\xa5\x00\x00\x00\x00\x00\x00\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x00\x00\x00\x00\x00\x00\x00\x00\x38\x00\x00\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x3a\x00\x3a\x00\x3a\x00\x87\x00\x39\x00\x00\x00\x3a\x00\x00\x00\x00\x00\x39\x00\x39\x00\x39\x00\x39\x00\x00\x00\x00\x00\x00\x00\xa9\x00\xa9\x00\xa9\x00\xa9\x00\xa9\x00\xa9\x00\xa9\x00\xa9\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x39\x00\x00\x00\x00\x00\x00\x00\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\x00\x3a\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\xaa\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\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\x3a\x00\x00\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x8b\x00\x17\x00\x00\x00\x3a\x00\x00\x00\x00\x00\x17\x00\x17\x00\x17\x00\x17\x00\x00\x00\x00\x00\x00\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\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\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\x3a\x00\x3a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb2\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\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\x3a\x00\x00\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3b\x00\x3b\x00\x3b\x00\x00\x00\x00\x00\x00\x00\x3b\x00\x00\x00\x5c\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\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\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\xa1\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa2\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3b\x00\x00\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3e\x00\x3e\x00\x3e\x00\x00\x00\x3d\x00\x00\x00\x3e\x00\x00\x00\x00\x00\x3d\x00\x3d\x00\x3d\x00\x3d\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3d\x00\x00\x00\x00\x00\x00\x00\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\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x00\x00\x00\x00\x00\x00\xb2\x00\x00\x00\x00\x00\x00\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3e\x00\x00\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x00\x00\x00\x00\x00\x00\x3e\x00\x00\x00\x8f\x00\x8f\x00\x8f\x00\x8f\x00\x8f\x00\x8f\x00\x8f\x00\x8f\x00\x8f\x00\x8f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x8f\x00\x8f\x00\x8f\x00\x8f\x00\x8f\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\x00\x00\x00\x00\x00\x00\x00\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x8f\x00\x8f\x00\x8f\x00\x8f\x00\x8f\x00\x8f\x00\x00\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3e\x00\x00\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x3e\x00\x44\x00\x44\x00\x44\x00\x00\x00\x00\x00\x00\x00\x44\x00\x00\x00\x96\x00\x96\x00\x96\x00\x96\x00\x96\x00\x96\x00\x96\x00\x96\x00\x96\x00\x96\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x96\x00\x96\x00\x96\x00\x96\x00\x96\x00\x96\x00\x00\x00\x00\x00\x00\x00\xbf\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\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x96\x00\x96\x00\x96\x00\x96\x00\x96\x00\x96\x00\x00\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x00\x00\x00\x00\x00\x00\x00\x00\x44\x00\x00\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x00\x00\x00\x00\x00\x00\x44\x00\x00\x00\x00\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa2\x00\x00\x00\x00\x00\xbf\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\xc8\x00\xc8\x00\xc8\x00\xc8\x00\xc8\x00\xc8\x00\xc8\x00\xc8\x00\xc8\x00\xc8\x00\xa1\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa2\x00\x44\x00\x44\x00\x44\x00\x44\x00\xc9\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\xca\x00\xd4\x00\x00\x00\xbb\x00\x45\x00\x00\x00\x44\x00\x44\x00\x44\x00\x44\x00\xc9\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\xbb\x00\x00\x00\xbb\x00\xbb\x00\xbb\x00\xbb\x00\x00\x00\x00\x00\x00\x00\xbb\x00\xbb\x00\x00\x00\xbb\x00\xbb\x00\xbb\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\xbb\x00\xbb\x00\xbb\x00\xbb\x00\xbb\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\xbb\x00\x00\x00\xbb\x00\xd4\x00\x00\x00\xd4\x00\xd4\x00\xd4\x00\xd5\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd6\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\x7f\x00\xbb\x00\x00\x00\xbb\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb9\x00\x89\x00\x00\x00\x00\x00\xa2\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5c\x00\x00\x00\xad\x00\xad\x00\xad\x00\xad\x00\xad\x00\xad\x00\xad\x00\xad\x00\xad\x00\xad\x00\x00\x00\x00\x00\x00\x00\x00\x00\x68\x00\xb9\x00\x5b\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\xa2\x00\xa2\x00\x00\x00\xb9\x00\xb9\x00\xb9\x00\x6a\x00\xb9\x00\xb9\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb9\x00\x00\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\x5e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa2\x00\x00\x00\xb9\x00\x00\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\x00\x00\x00\x00\x00\x00\xb9\x00\xb9\x00\x00\x00\x6a\x00\xb9\x00\xb9\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb9\x00\x00\x00\xb9\x00\x00\x00\x00\x00\x00\x00\xb9\x00\x00\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\xb9\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\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb9\x00\x00\x00\xb9\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb9\x00\x00\x00\xb9\x00\x00\x00\x00\x00\x00\x00\x00\x00\x67\x00\x30\x00\x00\x00\x30\x00\x30\x00\x30\x00\x30\x00\x00\x00\x00\x00\x00\x00\x30\x00\x30\x00\x30\x00\x6c\x00\x30\x00\x30\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb9\x00\x30\x00\xb9\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x30\x00\x00\x00\x30\x00\x30\x00\x30\x00\x30\x00\x00\x00\x00\x00\x00\x00\x30\x00\x30\x00\x00\x00\x6c\x00\x30\x00\x30\x00\x00\x00\x00\x00\x00\x00\x00\x00\x30\x00\x00\x00\x30\x00\x00\x00\x00\x00\x00\x00\x30\x00\x00\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\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\x30\x00\x00\x00\x30\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x30\x00\x00\x00\x30\x00\x00\x00\x00\x00\x00\x00\x00\x00\x68\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\x6f\x00\xff\xff\xff\xff\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x30\x00\xff\xff\x30\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\x6f\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\xf3\x00\xf3\x00\xf3\x00\x00\x00\x00\x00\x00\x00\xf3\x00\x00\x00\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\xf3\x00\xf3\x00\xf3\x00\xf3\x00\xf3\x00\xf3\x00\xf3\x00\xf3\x00\xf3\x00\xf3\x00\xf3\x00\xf3\x00\xf3\x00\xf3\x00\xf3\x00\xf3\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\xf3\x00\x00\x00\xf3\x00\xf3\x00\xf3\x00\xf3\x00\xf3\x00\xf3\x00\xf3\x00\xf3\x00\xf3\x00\xf3\x00\xf3\x00\xf3\x00\xf3\x00\xf3\x00\xf3\x00\xf3\x00\xf3\x00\xf3\x00\xf3\x00\xf3\x00\xf3\x00\xf3\x00\xf3\x00\xf3\x00\xf3\x00\xf3\x00\x00\x00\xfd\x00\x8f\x00\x8f\x00\x8f\x00\x8f\x00\x8f\x00\x8f\x00\x8f\x00\x8f\x00\x8f\x00\x8f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x8f\x00\x8f\x00\x8f\x00\x8f\x00\x8f\x00\x8f\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x94\x00\x00\x00\x8f\x00\x8f\x00\x8f\x00\x8f\x00\x8f\x00\x8f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x92\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\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x91\x00\x00\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\x00\x00\x00\x00\x92\x00\x8f\x00\x8f\x00\x8f\x00\x8f\x00\x8f\x00\x8f\x00\x8f\x00\x8f\x00\x8f\x00\x8f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x8f\x00\x8f\x00\x8f\x00\x8f\x00\x8f\x00\x8f\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x94\x00\x00\x00\x8f\x00\x8f\x00\x8f\x00\x8f\x00\x8f\x00\x8f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x92\x00\x96\x00\x96\x00\x96\x00\x96\x00\x96\x00\x96\x00\x96\x00\x96\x00\x96\x00\x96\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x96\x00\x96\x00\x96\x00\x96\x00\x96\x00\x96\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9b\x00\x00\x00\x96\x00\x96\x00\x96\x00\x96\x00\x96\x00\x96\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x99\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x98\x00\x00\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x99\x00\x96\x00\x96\x00\x96\x00\x96\x00\x96\x00\x96\x00\x96\x00\x96\x00\x96\x00\x96\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x96\x00\x96\x00\x96\x00\x96\x00\x96\x00\x96\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9b\x00\x00\x00\x96\x00\x96\x00\x96\x00\x96\x00\x96\x00\x96\x00\x86\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x99\x00\x00\x00\x93\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\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x91\x00\x00\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\x00\x00\x00\x00\x92\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\x89\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa7\x00\xa7\x00\xa7\x00\xa7\x00\xa7\x00\xa7\x00\x5c\x00\x00\x00\xad\x00\xad\x00\xad\x00\xad\x00\xad\x00\xad\x00\xad\x00\xad\x00\xad\x00\xad\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xac\x00\x00\x00\x00\x00\xa2\x00\xa8\x00\x00\x00\xa7\x00\xa7\x00\xa7\x00\xa7\x00\xa7\x00\xa7\x00\x00\x00\xaa\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\x00\x00\x5e\x00\x00\x00\x00\x00\xac\x00\x00\x00\x00\x00\xa2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x8a\x00\x00\x00\x00\x00\xaa\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9a\x00\xa8\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x98\x00\x00\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x99\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\x00\x00\x00\x00\x8d\x00\x00\x00\x00\x00\x00\x00\x00\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\x58\x00\x00\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x8d\x00\xa6\x00\xb0\x00\x00\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\x00\x00\x58\x00\x00\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5a\x00\x00\x00\x00\x00\x00\x00\xb4\x00\x00\x00\xa6\x00\xa6\x00\x00\x00\xb7\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\xb0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5a\x00\x00\x00\x00\x00\xb4\x00\x00\x00\xb7\x00\xa6\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\x00\x00\x00\x00\x00\x00\xb7\x00\xb7\x00\xb2\x00\xb7\x00\xb7\x00\xb7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb0\x00\x00\x00\x00\x00\x00\x00\xb9\x00\xb7\x00\x00\x00\xb7\x00\xb7\x00\xb7\x00\xb7\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb9\x00\x00\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\xb7\x00\x00\x00\xb7\x00\xb9\x00\xb9\x00\x00\x00\x69\x00\xb9\x00\xb9\x00\xae\x00\xad\x00\xad\x00\xad\x00\xad\x00\xad\x00\xad\x00\xad\x00\xad\x00\xad\x00\xb9\x00\x00\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb7\x00\x00\x00\xb7\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\xb9\x00\x00\x00\xb9\x00\xa0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb9\x00\x00\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\xba\x00\x00\x00\x00\x00\xb9\x00\xb9\x00\x00\x00\xb9\x00\xb9\x00\xb9\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb9\x00\x00\x00\xb9\x00\x00\x00\xb9\x00\x00\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\x00\x00\x00\x00\x00\x00\xba\x00\x00\x00\xba\x00\xba\x00\xba\x00\xba\x00\xbb\x00\x00\x00\x00\x00\xba\x00\xba\x00\x00\x00\xba\x00\xba\x00\xba\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb9\x00\xba\x00\xb9\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\x00\x00\x00\x00\x00\x00\xbb\x00\x00\x00\xbb\x00\xbb\x00\xbb\x00\xbb\x00\x00\x00\x00\x00\x00\x00\xbb\x00\xbb\x00\x00\x00\xbb\x00\xbb\x00\xbb\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb9\x00\x00\x00\xb9\x00\xba\x00\xbb\x00\xba\x00\xbb\x00\xbb\x00\xbb\x00\xbb\x00\xbb\x00\xc2\x00\xc2\x00\xc2\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\xba\x00\x00\x00\xba\x00\xbb\x00\x00\x00\xbb\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbc\x00\x00\x00\x00\x00\x00\x00\xc2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4d\x00\x00\x00\xc2\x00\xc2\x00\xc2\x00\xc2\x00\xc2\x00\xc2\x00\xc2\x00\xc2\x00\xc2\x00\xc2\x00\x00\x00\x00\x00\xbb\x00\x00\x00\xbb\x00\x00\x00\x00\x00\xc2\x00\xc2\x00\xc2\x00\xc2\x00\xc2\x00\xc2\x00\xc2\x00\xc2\x00\xc2\x00\xc2\x00\xc2\x00\xc2\x00\xc2\x00\xc2\x00\xc2\x00\xc2\x00\xc2\x00\xc2\x00\xc2\x00\xc2\x00\xc2\x00\xc2\x00\xc2\x00\xc2\x00\xc2\x00\xc2\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc2\x00\x00\x00\xc2\x00\xc2\x00\xc2\x00\xc2\x00\xc2\x00\xc2\x00\xc2\x00\xc2\x00\xc2\x00\xc2\x00\xc2\x00\xc2\x00\xc2\x00\xc2\x00\xc2\x00\xc2\x00\xc2\x00\xc2\x00\xc2\x00\xc2\x00\xc2\x00\xc2\x00\xc2\x00\xc2\x00\xc2\x00\xc2\x00\xc3\x00\xc3\x00\xc3\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xcc\x00\x00\x00\xc3\x00\xc3\x00\xc3\x00\xc3\x00\xc3\x00\xc3\x00\xc3\x00\xc3\x00\xc3\x00\xc3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc3\x00\xc3\x00\xc3\x00\xc3\x00\xc3\x00\xc3\x00\xc3\x00\xc3\x00\xc3\x00\xc3\x00\xc3\x00\xc3\x00\xc3\x00\xc3\x00\xc3\x00\xc3\x00\xc3\x00\xc3\x00\xc3\x00\xc3\x00\xc3\x00\xc3\x00\xc3\x00\xc3\x00\xc3\x00\xc3\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc3\x00\x00\x00\xc3\x00\xc3\x00\xc3\x00\xc3\x00\xc3\x00\xc3\x00\xc3\x00\xc3\x00\xc3\x00\xc3\x00\xc3\x00\xc3\x00\xc3\x00\xc3\x00\xc3\x00\xc3\x00\xc3\x00\xc3\x00\xc3\x00\xc3\x00\xc3\x00\xc3\x00\xc3\x00\xc3\x00\xc3\x00\xc3\x00\xc4\x00\xc4\x00\xc4\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\xc4\x00\xc4\x00\xc4\x00\xc4\x00\xc4\x00\xc4\x00\xc4\x00\xc4\x00\xc4\x00\xc4\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc4\x00\xc4\x00\xc4\x00\xc4\x00\xc4\x00\xc4\x00\xc4\x00\xc4\x00\xc4\x00\xc4\x00\xc4\x00\xc4\x00\xc4\x00\xc4\x00\xc4\x00\xc4\x00\xc4\x00\xc4\x00\xc4\x00\xc4\x00\xc4\x00\xc4\x00\xc4\x00\xc4\x00\xc4\x00\xc4\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc4\x00\x00\x00\xc4\x00\xc4\x00\xc4\x00\xc4\x00\xc4\x00\xc4\x00\xc4\x00\xc4\x00\xc4\x00\xc4\x00\xc4\x00\xc4\x00\xc4\x00\xc4\x00\xc4\x00\xc4\x00\xc4\x00\xc4\x00\xc4\x00\xc4\x00\xc4\x00\xc4\x00\xc4\x00\xc4\x00\xc4\x00\xc4\x00\x44\x00\x44\x00\x44\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\xbf\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\xc8\x00\xc8\x00\xc8\x00\xc8\x00\xc8\x00\xc8\x00\xc8\x00\xc8\x00\xc8\x00\xc8\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc5\x00\x00\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\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\xbe\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\xc6\x00\xc6\x00\xc6\x00\xc6\x00\xc6\x00\xc6\x00\xc6\x00\xc6\x00\xc6\x00\xc6\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc7\x00\x00\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\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\xbf\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\xc6\x00\xc6\x00\xc6\x00\xc6\x00\xc6\x00\xc6\x00\xc6\x00\xc6\x00\xc6\x00\xc6\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc7\x00\x00\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\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\xbf\x00\x00\x00\x00\x00\x00\x00\x44\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x58\x00\x00\x00\xc8\x00\xc8\x00\xc8\x00\xc8\x00\xc8\x00\xc8\x00\xc8\x00\xc8\x00\xc8\x00\xc8\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x44\x00\x44\x00\x44\x00\x44\x00\xc9\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x00\x00\x00\x00\x00\x00\x00\x00\x45\x00\x00\x00\x44\x00\x44\x00\x44\x00\x44\x00\xc9\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\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\xbf\x00\x00\x00\x00\x00\x00\x00\x44\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x00\x00\xa4\x00\x00\x00\x00\x00\xc6\x00\xc6\x00\xc6\x00\xc6\x00\xc6\x00\xc6\x00\xc6\x00\xc6\x00\xc6\x00\xc6\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x00\x00\x00\x00\x00\x00\x00\x00\x44\x00\x00\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\x44\x00\xca\x00\xca\x00\xca\x00\x00\x00\x00\x00\x00\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\x00\x00\x00\x00\x00\x00\xc0\x00\x00\x00\x00\x00\x00\x00\xca\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4d\x00\x00\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\x00\x00\x00\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\xca\x00\x00\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\xcb\x00\xcb\x00\xcb\x00\x00\x00\x00\x00\x00\x00\xcb\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\xcc\x00\x00\x00\xcb\x00\xcb\x00\xcb\x00\xcb\x00\xcb\x00\xcb\x00\xcb\x00\xcb\x00\xcb\x00\xcb\x00\x00\x00\xcb\x00\xcd\x00\x00\x00\x00\x00\x00\x00\x00\x00\xcb\x00\xcb\x00\xcb\x00\xcb\x00\xcb\x00\xcb\x00\xcb\x00\xcb\x00\xcb\x00\xcb\x00\xcb\x00\xcb\x00\xcb\x00\xcb\x00\xcb\x00\xcb\x00\xcb\x00\xcb\x00\xcb\x00\xcb\x00\xcb\x00\xcb\x00\xcb\x00\xcb\x00\xcb\x00\xcb\x00\x00\x00\x00\x00\x00\x00\x00\x00\xcb\x00\x00\x00\xcb\x00\xcb\x00\xcb\x00\xcb\x00\xcb\x00\xcb\x00\xcb\x00\xcb\x00\xcb\x00\xcb\x00\xcb\x00\xcb\x00\xcb\x00\xcb\x00\xcb\x00\xcb\x00\xcb\x00\xcb\x00\xcb\x00\xcb\x00\xcb\x00\xcb\x00\xcb\x00\xcb\x00\xcb\x00\xcb\x00\xcb\x00\xcb\x00\xcb\x00\xcb\x00\xcb\x00\xcb\x00\xcb\x00\xcb\x00\xcb\x00\xcb\x00\xcb\x00\xcb\x00\xcb\x00\xcb\x00\xcb\x00\xcb\x00\xcb\x00\xcb\x00\xcb\x00\xcb\x00\xcb\x00\xcb\x00\xcb\x00\xcb\x00\xcb\x00\xcb\x00\x00\x00\x00\x00\x00\x00\x00\x00\xcd\x00\x00\x00\xcd\x00\xcd\x00\xcd\x00\xce\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcf\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\x00\x00\x00\x00\x00\x00\x00\x00\xcd\x00\x00\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\x00\x00\x00\x00\x00\x00\x00\x00\xcd\x00\x00\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xdb\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\x00\x00\x00\x00\x00\x00\x00\x00\xcd\x00\x00\x00\xcd\x00\xcd\x00\xcd\x00\xd8\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xd4\x00\xd4\x00\xd4\x00\x00\x00\x00\x00\x00\x00\xd4\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\xd4\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd4\x00\x00\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\x00\x00\x00\x00\x00\x00\xd4\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\xd4\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd4\x00\x00\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xdc\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\x00\x00\x00\x00\x00\x00\xd4\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\xd4\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd4\x00\x00\x00\xd4\x00\xd4\x00\xd4\x00\xda\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xcd\x00\xcd\x00\xcd\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\x00\x00\x00\x00\x00\x00\x00\x00\xcd\x00\x00\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\x00\x00\x00\x00\x00\x00\x00\x00\xcd\x00\x00\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xd7\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xd4\x00\xd4\x00\xd4\x00\x00\x00\x00\x00\x00\x00\xd4\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\xd4\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd4\x00\x00\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\x00\x00\x00\x00\x00\x00\xd4\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\xd4\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd4\x00\x00\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd9\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xcd\x00\xcd\x00\xcd\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\x00\x00\x00\x00\x00\x00\x00\x00\xcd\x00\x00\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xd4\x00\xd4\x00\xd4\x00\x00\x00\x00\x00\x00\x00\xd4\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\xd4\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd4\x00\x00\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xeb\x00\xeb\x00\xeb\x00\xb9\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb9\x00\xea\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\xeb\x00\x00\x00\xe6\x00\xb9\x00\xb9\x00\x00\x00\x15\x00\xb9\x00\xb9\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xb9\x00\x00\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\x00\x00\xb9\x00\x00\x00\xb9\x00\xeb\x00\x00\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\x00\x00\xb9\x00\x00\x00\xb9\x00\xeb\x00\xeb\x00\xeb\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\x00\x00\x00\x00\x00\x00\x00\x00\xeb\x00\x00\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xec\x00\xec\x00\xec\x00\x00\x00\x00\x00\x00\x00\xec\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x00\x00\xec\x00\xec\x00\xec\x00\xec\x00\xec\x00\xec\x00\xec\x00\xec\x00\xec\x00\xec\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xec\x00\xec\x00\xec\x00\xec\x00\xec\x00\xec\x00\xec\x00\xec\x00\xec\x00\xec\x00\xec\x00\xec\x00\xec\x00\xec\x00\xec\x00\xec\x00\xec\x00\xec\x00\xec\x00\xec\x00\xec\x00\xec\x00\xec\x00\xec\x00\xec\x00\xec\x00\x00\x00\x00\x00\x00\x00\xb9\x00\xec\x00\x00\x00\xec\x00\xec\x00\xec\x00\xec\x00\xec\x00\xec\x00\xec\x00\xec\x00\xec\x00\xec\x00\xec\x00\xec\x00\xec\x00\xec\x00\xec\x00\xec\x00\xec\x00\xec\x00\xec\x00\xec\x00\xec\x00\xec\x00\xec\x00\xec\x00\xec\x00\xec\x00\xb9\x00\x00\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\x00\x00\x00\x00\xed\x00\xb9\x00\xb9\x00\x00\x00\xb9\x00\xb9\x00\xb9\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb9\x00\x00\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\xf1\x00\xf1\x00\xf1\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb9\x00\x0c\x00\xb9\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\xf1\x00\xf1\x00\xf1\x00\xf1\x00\xf1\x00\xf1\x00\xf1\x00\xf1\x00\xf1\x00\xf1\x00\x00\x00\x00\x00\xff\x00\x00\x00\xb9\x00\x00\x00\x00\x00\xf1\x00\xf1\x00\xf1\x00\xf1\x00\xf1\x00\xf1\x00\xf1\x00\xf1\x00\xf1\x00\xf1\x00\xf1\x00\xf1\x00\xf1\x00\xf1\x00\xf1\x00\xf1\x00\xf1\x00\xf1\x00\xf1\x00\xf1\x00\xf1\x00\xf1\x00\xf1\x00\xf1\x00\xf1\x00\xf1\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf1\x00\x00\x00\xf1\x00\xf1\x00\xf1\x00\xf1\x00\xf1\x00\xf1\x00\xf1\x00\xf1\x00\xf1\x00\xf1\x00\xf1\x00\xf1\x00\xf1\x00\xf1\x00\xf1\x00\xf1\x00\xf1\x00\xf1\x00\xf1\x00\xf1\x00\xf1\x00\xf1\x00\xf1\x00\xf1\x00\xf1\x00\xf1\x00\x00\x00\xf0\x00\xf3\x00\xf3\x00\xf3\x00\x00\x00\x00\x00\x00\x00\xf3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x00\x00\xf3\x00\xf3\x00\xf3\x00\xf3\x00\xf3\x00\xf3\x00\xf3\x00\xf3\x00\xf3\x00\xf3\x00\xf3\x00\xf3\x00\xf3\x00\xf3\x00\xf3\x00\xf3\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\xf3\x00\x00\x00\xf3\x00\xf3\x00\xf3\x00\xf3\x00\xf3\x00\xf3\x00\xf3\x00\xf3\x00\xf3\x00\xf3\x00\xf3\x00\xf3\x00\xf3\x00\xf3\x00\xf3\x00\xf3\x00\xf3\x00\xf3\x00\xf3\x00\xf3\x00\xf3\x00\xf3\x00\xf3\x00\xf3\x00\xf3\x00\xf3\x00\x00\x00\xf2\x00\xf3\x00\xf3\x00\xf3\x00\x00\x00\x00\x00\x00\x00\xf3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x00\x00\xf3\x00\xf3\x00\xf3\x00\xf3\x00\xf3\x00\xf3\x00\xf3\x00\xf3\x00\xf3\x00\xf3\x00\xf3\x00\xf3\x00\xf3\x00\xf3\x00\xf3\x00\xf3\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\xf3\x00\x00\x00\xf3\x00\xf3\x00\xf3\x00\xf3\x00\xf3\x00\xf3\x00\xf3\x00\xf3\x00\xf3\x00\xf3\x00\xf3\x00\xf3\x00\xf3\x00\xf3\x00\xf3\x00\xf3\x00\xf3\x00\xf3\x00\xf3\x00\xf3\x00\xf3\x00\xf3\x00\xf3\x00\xf3\x00\xf3\x00\xf3\x00\x00\x00\xf6\x00\xf3\x00\xf3\x00\xf3\x00\x00\x00\x00\x00\x00\x00\xf3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x00\x00\xf3\x00\xf3\x00\xf3\x00\xf3\x00\xf3\x00\xf3\x00\xf3\x00\xf3\x00\xf3\x00\xf3\x00\xf3\x00\xf3\x00\xf3\x00\xf3\x00\xf3\x00\xf3\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\xf3\x00\x00\x00\xf3\x00\xf3\x00\xf3\x00\xf3\x00\xf3\x00\xf3\x00\xf3\x00\xf3\x00\xf3\x00\xf3\x00\xf3\x00\xf3\x00\xf3\x00\xf3\x00\xf3\x00\xf3\x00\xf3\x00\xf3\x00\xf3\x00\xf3\x00\xf3\x00\xf3\x00\xf3\x00\xf3\x00\xf3\x00\xf3\x00\x00\x00\xf8\x00\xf3\x00\xf3\x00\xf3\x00\x00\x00\x00\x00\x00\x00\xf3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x00\x00\xf3\x00\xf3\x00\xf3\x00\xf3\x00\xf3\x00\xf3\x00\xf3\x00\xf3\x00\xf3\x00\xf3\x00\xf3\x00\xf3\x00\xf3\x00\xf3\x00\xf3\x00\xf3\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\xb9\x00\xf3\x00\x00\x00\xf3\x00\xf3\x00\xf3\x00\xf3\x00\xf3\x00\xf3\x00\xf3\x00\xf3\x00\xf3\x00\xf3\x00\xf3\x00\xf3\x00\xf3\x00\xf3\x00\xf3\x00\xf3\x00\xf3\x00\xf3\x00\xf3\x00\xf3\x00\xf3\x00\xf3\x00\xf3\x00\xf3\x00\xf3\x00\xf3\x00\xb9\x00\xfa\x00\xb9\x00\xb9\x00\xb9\x00\xb9\x00\x00\x00\x00\x00\x00\x00\xb9\x00\xb9\x00\x00\x00\xb9\x00\xb9\x00\xb9\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb9\x00\x00\x00\xb9\x00\xb9\x00\xb9\x00\xb9\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb9\x00\xfe\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb9\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x2d\x00\x04\x00\x05\x00\x06\x00\x7d\x00\x2d\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x7d\x00\x2d\x00\x7d\x00\x0a\x00\x0a\x00\x2d\x00\x21\x00\x0a\x00\x0a\x00\x72\x00\x61\x00\x67\x00\x6d\x00\x61\x00\x0a\x00\x69\x00\x6e\x00\x0a\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\x65\x00\x2d\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x05\x00\x06\x00\x0a\x00\x0a\x00\x09\x00\x2d\x00\x0b\x00\x0c\x00\x0d\x00\x21\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x2d\x00\x20\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x20\x00\x05\x00\x06\x00\x65\x00\x2d\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x2d\x00\x2d\x00\x69\x00\x2d\x00\x23\x00\x23\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x23\x00\x23\x00\x20\x00\x05\x00\x06\x00\x23\x00\x23\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x05\x00\x06\x00\x23\x00\x2d\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x05\x00\x06\x00\x6e\x00\x6c\x00\x09\x00\x2d\x00\x0b\x00\x0c\x00\x0d\x00\x20\x00\x6c\x00\x7d\x00\x23\x00\x23\x00\x70\x00\x23\x00\x20\x00\x2d\x00\x20\x00\x23\x00\x24\x00\x23\x00\x2d\x00\x30\x00\x31\x00\x7c\x00\x2a\x00\x20\x00\x30\x00\x31\x00\x05\x00\x2d\x00\xff\xff\x30\x00\x31\x00\x7b\x00\x0b\x00\x0c\x00\x0d\x00\x0a\x00\x2d\x00\x05\x00\x06\x00\xff\xff\x7b\x00\x09\x00\x05\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x05\x00\x06\x00\x20\x00\xff\xff\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\x24\x00\xff\xff\xff\xff\x20\x00\xff\xff\x5f\x00\x2a\x00\x7b\x00\x20\x00\xff\xff\x5f\x00\x23\x00\xff\xff\x5e\x00\xff\xff\x5f\x00\x2d\x00\x20\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\x2d\x00\xff\xff\x05\x00\x06\x00\xff\xff\x7b\x00\x09\x00\x7c\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\x05\x00\x7c\x00\x7b\x00\x7c\x00\xff\xff\xff\xff\x0b\x00\x0c\x00\x0d\x00\x24\x00\x20\x00\x7b\x00\xff\xff\x23\x00\x24\x00\x2a\x00\x5e\x00\x20\x00\x05\x00\x06\x00\x2a\x00\x0a\x00\x09\x00\xff\xff\x0b\x00\x0c\x00\x0d\x00\x20\x00\xff\xff\x22\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\x20\x00\x7c\x00\x24\x00\x23\x00\x05\x00\xff\xff\xff\xff\x7b\x00\x2a\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x2d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x5e\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5e\x00\x01\x00\x02\x00\xff\xff\x20\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\x7c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x7c\x00\x05\x00\x20\x00\x5e\x00\xff\xff\x23\x00\x7b\x00\x0b\x00\x0c\x00\x0d\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\x2d\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\x20\x00\x3b\x00\x22\x00\x5f\x00\xff\xff\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\xff\xff\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\xff\xff\x7d\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\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\x05\x00\x20\x00\xff\xff\xff\xff\x23\x00\x24\x00\x0b\x00\x0c\x00\x0d\x00\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\xff\xff\xff\xff\x20\x00\x5f\x00\xff\xff\x23\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\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\x05\x00\xff\xff\x07\x00\xff\xff\xff\xff\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\x23\x00\x20\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\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\x5f\x00\xff\xff\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\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\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\x5e\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\x7c\x00\x7d\x00\x7e\x00\x5f\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\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\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\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\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\x01\x00\x02\x00\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\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\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\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\x2b\x00\xff\xff\x2d\x00\xff\xff\x45\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\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\xff\xff\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\x02\x00\xff\xff\x04\x00\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\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\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x5f\x00\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\x5f\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\xff\xff\x2b\x00\xff\xff\x2d\x00\xff\xff\x5f\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\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\x23\x00\x5f\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x20\x00\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\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\x2b\x00\xff\xff\x2d\x00\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\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\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\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\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\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\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\x05\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0b\x00\x0c\x00\x0d\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\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\x45\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\x45\x00\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x01\x00\x02\x00\x03\x00\x04\x00\x65\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\x5f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\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\xff\xff\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\xff\xff\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\xff\xff\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\x23\x00\x05\x00\xff\xff\x07\x00\xff\xff\xff\xff\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\x2e\x00\x0a\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\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\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\x05\x00\xff\xff\x07\x00\xff\xff\xff\xff\x0a\x00\x0b\x00\x0c\x00\x0d\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\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\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\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\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\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\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\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\x23\x00\x7c\x00\xff\xff\x7e\x00\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\x04\x00\x23\x00\xff\xff\xff\xff\x45\x00\xff\xff\x0a\x00\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\x20\x00\x21\x00\x5f\x00\x23\x00\x24\x00\x25\x00\x26\x00\x45\x00\x65\x00\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\x5f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\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\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\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\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\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\xff\xff\x7c\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\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\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\x42\x00\xff\xff\xff\xff\x45\x00\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\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\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\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\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\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\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\x29\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\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\x5c\x00\x5d\x00\x5e\x00\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\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\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\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\x7c\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\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\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\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\x5d\x00\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\x7c\x00\xff\xff\x7e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\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\x30\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\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\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\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\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\xff\xff\xff\xff\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\xff\xff\xff\xff\x75\x00\x75\x00\x74\x00\x70\x00\x74\x00\x70\x00\xff\xff\x74\x00\x70\x00\x70\x00\x73\x00\x72\x00\x73\x00\x74\x00\x75\x00\x30\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\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, 255) - [ AlexAccNone - , AlexAcc 189 - , AlexAccNone - , AlexAcc 188 - , AlexAcc 187 - , AlexAcc 186 - , AlexAcc 185 - , AlexAcc 184 - , AlexAcc 183 - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAcc 182 - , AlexAcc 181 - , AlexAcc 180 - , AlexAccPred 179 (ifExtension HaddockBit)(AlexAccNone) - , AlexAcc 178 - , AlexAcc 177 - , AlexAccPred 176 (isNormalComment)(AlexAccNone) - , AlexAcc 175 - , AlexAccNone - , AlexAcc 174 - , AlexAcc 173 - , AlexAccNone - , AlexAccNone - , AlexAcc 172 - , AlexAccNone - , AlexAccPred 171 (known_pragma twoWordPrags)(AlexAccNone) - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAcc 170 - , AlexAccNone - , AlexAcc 169 - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAcc 168 - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAcc 167 - , AlexAcc 166 - , AlexAcc 165 - , AlexAccSkip - , AlexAcc 164 - , AlexAcc 163 - , AlexAcc 162 - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAcc 161 - , AlexAccNone - , AlexAccPred 160 (known_pragma linePrags)(AlexAccPred 159 (known_pragma oneWordPrags)(AlexAccPred 158 (known_pragma ignoredPrags)(AlexAccPred 157 (known_pragma fileHeaderPrags)(AlexAcc 156)))) - , AlexAccNone - , AlexAccPred 155 (known_pragma linePrags)(AlexAccPred 154 (known_pragma oneWordPrags)(AlexAccPred 153 (known_pragma ignoredPrags)(AlexAccPred 152 (known_pragma fileHeaderPrags)(AlexAcc 151)))) - , AlexAccPred 150 (known_pragma linePrags)(AlexAcc 149) - , AlexAccPred 148 (isNormalComment)(AlexAccNone) - , AlexAccNone - , AlexAccPred 147 (known_pragma linePrags)(AlexAccNone) - , AlexAcc 146 - , AlexAccPred 145 (notFollowedBySymbol)(AlexAccNone) - , AlexAccPred 144 (alexPrevCharMatches(\c -> c >= '\n' && c <= '\n' || False))(AlexAccNone) - , AlexAccSkip - , AlexAccPred 143 (notFollowedBy '-')(AlexAccNone) - , AlexAcc 142 - , AlexAcc 141 - , 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 - , AlexAccNone - , AlexAccSkipPred (alexPrevCharMatches(\c -> c >= '\n' && c <= '\n' || False))(AlexAccNone) - , AlexAccPred 140 (alexPrevCharMatches(\c -> c >= '\n' && c <= '\n' || False) `alexAndPred` followedByDigit)(AlexAccNone) - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAcc 139 - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccPred 138 (negLitPred)(AlexAccNone) - , AlexAccNone - , AlexAccNone - , AlexAccPred 137 (alexPrevCharMatches(\c -> c >= '\n' && c <= '\n' || False))(AlexAccNone) - , AlexAccSkip - , AlexAccNone - , AlexAccPred 136 (isSmartQuote)(AlexAccPred 135 (ifCurrentChar '⟦' `alexAndPred` - ifExtension UnicodeSyntaxBit `alexAndPred` - ifExtension ThQuotesBit)(AlexAccPred 134 (ifCurrentChar '⟧' `alexAndPred` - ifExtension UnicodeSyntaxBit `alexAndPred` - ifExtension ThQuotesBit)(AlexAccPred 133 (ifCurrentChar '⦇' `alexAndPred` - ifExtension UnicodeSyntaxBit `alexAndPred` - ifExtension ArrowsBit)(AlexAccPred 132 (ifCurrentChar '⦈' `alexAndPred` - ifExtension UnicodeSyntaxBit `alexAndPred` - ifExtension ArrowsBit)(AlexAccNone))))) - , AlexAccPred 131 (isSmartQuote)(AlexAcc 130) - , AlexAccPred 129 (isSmartQuote)(AlexAccNone) - , AlexAccNone - , AlexAccPred 128 (atEOL)(AlexAcc 127) - , AlexAccPred 126 (atEOL)(AlexAccNone) - , AlexAccPred 125 (atEOL)(AlexAcc 124) - , AlexAccPred 123 (atEOL)(AlexAcc 122) - , AlexAccPred 121 (atEOL)(AlexAcc 120) - , AlexAccPred 119 (atEOL)(AlexAcc 118) - , AlexAccNone - , AlexAccPred 117 (atEOL)(AlexAccNone) - , AlexAccPred 116 (atEOL)(AlexAccNone) - , AlexAcc 115 - , AlexAccPred 114 (alexNotPred (ifExtension HaddockBit))(AlexAccPred 113 (ifExtension HaddockBit)(AlexAccNone)) - , AlexAccPred 112 (alexNotPred (ifExtension HaddockBit))(AlexAcc 111) - , AlexAccPred 110 (alexNotPred (ifExtension HaddockBit))(AlexAccNone) - , AlexAcc 109 - , AlexAcc 108 - , AlexAccPred 107 (isNormalComment)(AlexAcc 106) - , AlexAccNone - , AlexAccPred 105 (isNormalComment)(AlexAccNone) - , AlexAcc 104 - , AlexAccSkip - , AlexAccNone - , AlexAcc 103 - , AlexAcc 102 - , AlexAccPred 101 (negHashLitPred)(AlexAccNone) - , AlexAccPred 100 (negHashLitPred)(AlexAccNone) - , AlexAccPred 99 (ifExtension MagicHashBit)(AlexAccNone) - , AlexAccPred 98 (ifExtension MagicHashBit)(AlexAccNone) - , AlexAccPred 97 (ifExtension MagicHashBit)(AlexAccNone) - , AlexAccPred 96 (ifExtension MagicHashBit)(AlexAccNone) - , AlexAccPred 95 (ifExtension MagicHashBit `alexAndPred` - ifExtension BinaryLiteralsBit)(AlexAccNone) - , AlexAccPred 94 (ifExtension MagicHashBit)(AlexAccNone) - , AlexAccPred 93 (negHashLitPred)(AlexAccNone) - , AlexAccPred 92 (negHashLitPred)(AlexAccNone) - , AlexAccPred 91 (negHashLitPred `alexAndPred` - ifExtension BinaryLiteralsBit)(AlexAccNone) - , AlexAccPred 90 (negHashLitPred)(AlexAccNone) - , AlexAccPred 89 (ifExtension MagicHashBit)(AlexAccNone) - , AlexAccPred 88 (ifExtension MagicHashBit)(AlexAccNone) - , AlexAccPred 87 (ifExtension MagicHashBit `alexAndPred` - ifExtension BinaryLiteralsBit)(AlexAccNone) - , AlexAccPred 86 (ifExtension MagicHashBit)(AlexAccNone) - , AlexAccPred 85 (ifExtension HexFloatLiteralsBit `alexAndPred` - negLitPred)(AlexAccNone) - , AlexAccPred 84 (ifExtension HexFloatLiteralsBit `alexAndPred` - negLitPred)(AlexAccNone) - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccPred 83 (ifExtension HexFloatLiteralsBit)(AlexAccNone) - , AlexAccPred 82 (ifExtension HexFloatLiteralsBit)(AlexAccNone) - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccPred 81 (negLitPred)(AlexAccNone) - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAcc 80 - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccPred 79 (negLitPred)(AlexAccNone) - , AlexAccNone - , AlexAccPred 78 (negLitPred)(AlexAccNone) - , AlexAccNone - , AlexAccPred 77 (negLitPred `alexAndPred` - ifExtension BinaryLiteralsBit)(AlexAccNone) - , AlexAccNone - , AlexAccPred 76 (negLitPred)(AlexAccNone) - , AlexAccPred 75 (negLitPred)(AlexAccNone) - , AlexAcc 74 - , AlexAccNone - , AlexAcc 73 - , AlexAccNone - , AlexAccPred 72 (ifExtension BinaryLiteralsBit)(AlexAccNone) - , AlexAccNone - , AlexAcc 71 - , AlexAcc 70 - , AlexAcc 69 - , AlexAcc 68 - , AlexAcc 67 - , AlexAcc 66 - , AlexAcc 65 - , AlexAccPred 64 (ifExtension MagicHashBit)(AlexAccNone) - , AlexAccPred 63 (ifExtension MagicHashBit)(AlexAccPred 62 (ifExtension MagicHashBit)(AlexAccNone)) - , AlexAccPred 61 (ifExtension MagicHashBit)(AlexAccPred 60 (ifExtension MagicHashBit)(AlexAccNone)) - , AlexAccPred 59 (ifExtension MagicHashBit)(AlexAccNone) - , AlexAccPred 58 (ifExtension MagicHashBit)(AlexAccNone) - , AlexAccPred 57 (ifExtension MagicHashBit)(AlexAccNone) - , AlexAcc 56 - , AlexAcc 55 - , AlexAcc 54 - , AlexAcc 53 - , AlexAcc 52 - , AlexAcc 51 - , AlexAcc 50 - , AlexAcc 49 - , AlexAcc 48 - , AlexAcc 47 - , AlexAccNone - , AlexAcc 46 - , AlexAcc 45 - , AlexAcc 44 - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccPred 43 (alexPrevCharMatches(\c -> c >= '\n' && c <= '\n' || False))(AlexAccNone) - , AlexAcc 42 - , AlexAcc 41 - , AlexAcc 40 - , AlexAccPred 39 (ifExtension RecursiveDoBit)(AlexAcc 38) - , AlexAcc 37 - , AlexAccPred 36 (ifExtension RecursiveDoBit)(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 - , AlexAccPred 22 (ifExtension UnboxedParensBit)(AlexAccNone) - , AlexAcc 21 - , AlexAccPred 20 (ifExtension UnboxedParensBit)(AlexAccNone) - , AlexAcc 19 - , AlexAccPred 18 (ifExtension OverloadedLabelsBit)(AlexAccNone) - , AlexAccPred 17 (ifExtension OverloadedLabelsBit)(AlexAccNone) - , AlexAccPred 16 (ifExtension IpBit)(AlexAccNone) - , AlexAccPred 15 (ifExtension ArrowsBit)(AlexAccNone) - , AlexAcc 14 - , AlexAccPred 13 (ifExtension ArrowsBit `alexAndPred` - notFollowedBySymbol)(AlexAccNone) - , AlexAccPred 12 (ifExtension QqBit)(AlexAccNone) - , AlexAccNone - , AlexAccPred 11 (ifExtension QqBit)(AlexAccNone) - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccPred 10 (ifExtension ThQuotesBit)(AlexAccPred 9 (ifExtension QqBit)(AlexAccNone)) - , AlexAccNone - , AlexAccPred 8 (ifExtension ThQuotesBit)(AlexAccPred 7 (ifExtension QqBit)(AlexAccNone)) - , AlexAccNone - , AlexAccPred 6 (ifExtension ThQuotesBit)(AlexAccPred 5 (ifExtension QqBit)(AlexAccNone)) - , AlexAccNone - , AlexAccPred 4 (ifExtension ThQuotesBit)(AlexAccNone) - , AlexAccPred 3 (ifExtension ThQuotesBit)(AlexAccPred 2 (ifExtension QqBit)(AlexAccNone)) - , AlexAcc 1 - , AlexAcc 0 - ] - -alex_actions = array (0 :: Int, 190) - [ (189,alex_action_16) - , (188,alex_action_22) - , (187,alex_action_23) - , (186,alex_action_21) - , (185,alex_action_24) - , (184,alex_action_28) - , (183,alex_action_29) - , (182,alex_action_45) - , (181,alex_action_44) - , (180,alex_action_43) - , (179,alex_action_42) - , (178,alex_action_40) - , (177,alex_action_72) - , (176,alex_action_2) - , (175,alex_action_40) - , (174,alex_action_86) - , (173,alex_action_36) - , (172,alex_action_67) - , (171,alex_action_33) - , (170,alex_action_86) - , (169,alex_action_32) - , (168,alex_action_31) - , (167,alex_action_30) - , (166,alex_action_29) - , (165,alex_action_29) - , (164,alex_action_1) - , (163,alex_action_29) - , (162,alex_action_29) - , (161,alex_action_27) - , (160,alex_action_26) - , (159,alex_action_34) - , (158,alex_action_35) - , (157,alex_action_38) - , (156,alex_action_39) - , (155,alex_action_26) - , (154,alex_action_34) - , (153,alex_action_35) - , (152,alex_action_37) - , (151,alex_action_39) - , (150,alex_action_26) - , (149,alex_action_29) - , (148,alex_action_2) - , (147,alex_action_26) - , (146,alex_action_25) - , (145,alex_action_20) - , (144,alex_action_19) - , (143,alex_action_17) - , (142,alex_action_78) - , (141,alex_action_78) - , (140,alex_action_12) - , (139,alex_action_96) - , (138,alex_action_97) - , (137,alex_action_11) - , (136,alex_action_9) - , (135,alex_action_54) - , (134,alex_action_55) - , (133,alex_action_58) - , (132,alex_action_59) - , (131,alex_action_9) - , (130,alex_action_29) - , (129,alex_action_9) - , (128,alex_action_8) - , (127,alex_action_29) - , (126,alex_action_8) - , (125,alex_action_7) - , (124,alex_action_86) - , (123,alex_action_7) - , (122,alex_action_86) - , (121,alex_action_7) - , (120,alex_action_29) - , (119,alex_action_7) - , (118,alex_action_29) - , (117,alex_action_7) - , (116,alex_action_7) - , (115,alex_action_6) - , (114,alex_action_5) - , (113,alex_action_41) - , (112,alex_action_5) - , (111,alex_action_29) - , (110,alex_action_5) - , (109,alex_action_4) - , (108,alex_action_3) - , (107,alex_action_2) - , (106,alex_action_29) - , (105,alex_action_2) - , (104,alex_action_1) - , (103,alex_action_117) - , (102,alex_action_116) - , (101,alex_action_115) - , (100,alex_action_114) - , (99,alex_action_113) - , (98,alex_action_112) - , (97,alex_action_111) - , (96,alex_action_110) - , (95,alex_action_109) - , (94,alex_action_108) - , (93,alex_action_107) - , (92,alex_action_106) - , (91,alex_action_105) - , (90,alex_action_104) - , (89,alex_action_103) - , (88,alex_action_102) - , (87,alex_action_101) - , (86,alex_action_100) - , (85,alex_action_99) - , (84,alex_action_99) - , (83,alex_action_98) - , (82,alex_action_98) - , (81,alex_action_97) - , (80,alex_action_96) - , (79,alex_action_95) - , (78,alex_action_94) - , (77,alex_action_93) - , (76,alex_action_92) - , (75,alex_action_92) - , (74,alex_action_91) - , (73,alex_action_90) - , (72,alex_action_89) - , (71,alex_action_88) - , (70,alex_action_88) - , (69,alex_action_87) - , (68,alex_action_86) - , (67,alex_action_86) - , (66,alex_action_85) - , (65,alex_action_84) - , (64,alex_action_83) - , (63,alex_action_82) - , (62,alex_action_113) - , (61,alex_action_82) - , (60,alex_action_112) - , (59,alex_action_82) - , (58,alex_action_81) - , (57,alex_action_80) - , (56,alex_action_79) - , (55,alex_action_79) - , (54,alex_action_78) - , (53,alex_action_78) - , (52,alex_action_78) - , (51,alex_action_78) - , (50,alex_action_78) - , (49,alex_action_78) - , (48,alex_action_77) - , (47,alex_action_77) - , (46,alex_action_76) - , (45,alex_action_76) - , (44,alex_action_76) - , (43,alex_action_19) - , (42,alex_action_76) - , (41,alex_action_76) - , (40,alex_action_76) - , (39,alex_action_75) - , (38,alex_action_76) - , (37,alex_action_76) - , (36,alex_action_75) - , (35,alex_action_76) - , (34,alex_action_76) - , (33,alex_action_74) - , (32,alex_action_74) - , (31,alex_action_73) - , (30,alex_action_72) - , (29,alex_action_71) - , (28,alex_action_70) - , (27,alex_action_69) - , (26,alex_action_68) - , (25,alex_action_67) - , (24,alex_action_66) - , (23,alex_action_65) - , (22,alex_action_64) - , (21,alex_action_86) - , (20,alex_action_63) - , (19,alex_action_65) - , (18,alex_action_62) - , (17,alex_action_61) - , (16,alex_action_60) - , (15,alex_action_57) - , (14,alex_action_86) - , (13,alex_action_56) - , (12,alex_action_53) - , (11,alex_action_52) - , (10,alex_action_51) - , (9,alex_action_52) - , (8,alex_action_50) - , (7,alex_action_52) - , (6,alex_action_49) - , (5,alex_action_52) - , (4,alex_action_48) - , (3,alex_action_47) - , (2,alex_action_52) - , (1,alex_action_46) - , (0,alex_action_86) - ] - -{-# LINE 704 "_build/source-dist/ghc-9.6.7-src/ghc-9.6.7/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.Basic" - | 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.Basic" - - | ITchar SourceText Char -- Note [Literal source text] in "GHC.Types.Basic" - | ITstring SourceText FastString -- Note [Literal source text] in "GHC.Types.Basic" - | ITinteger IntegralLit -- Note [Literal source text] in "GHC.Types.Basic" - | ITrational FractionalLit - - | ITprimchar SourceText Char -- Note [Literal source text] in "GHC.Types.Basic" - | ITprimstring SourceText ByteString -- Note [Literal source text] in "GHC.Types.Basic" - | ITprimint SourceText Integer -- Note [Literal source text] in "GHC.Types.Basic" - | ITprimword SourceText Integer -- Note [Literal source text] in "GHC.Types.Basic" - | 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. - -We also need to track the space before the end of file. The normal -mechanism of using the previous token does not work, as the ITeof is -synthesised to come at the same location of the last token, and the -normal previous token updating has by then updated the required -location. - -We track this using a 2-back location, prev_loc2. This adds extra -processing to every single token, which is a performance hit for -something needed only at the end of the file. This needs -improving. Perhaps a backward scan on eof? --} - -{- 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 $ lexemeToString (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)) - -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 :: AlexAccPred ExtsBitmap -negHashLitPred = prefix_minus `alexAndPred` magic_hash - where - magic_hash = ifExtension MagicHashBit - 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 <- getLastLocComment - 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 <- getLastLocComment - 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 <- getLastLocComment - 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 = lexemeToString 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 = lexemeToString 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 - let !src = lexemeToString buf len - if usePosPrags - then begin column_prag span buf len buf2 - else let !src = lexemeToString 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 = lexemeToString buf len - when ((not numericUnderscores) && ('_' `elem` 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 ('-':_)) -> 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) - --- 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 <- getLastLocComment - 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 = lexemeToString 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 = lexemeToString (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 = lexemeToString 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' = lexemeToString 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 token, including comments, - prev_loc2 :: PsSpan, -- pos of two back token, including comments, - -- see Note [PsSpan in 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 -> POk s { last_tk = Strict.Just tk - , prev_loc = l - , prev_loc2 = prev_loc s} () - -setLastComment :: PsLocated Token -> P () -setLastComment (L l _) = P $ \s -> POk s { prev_loc = l - , prev_loc2 = prev_loc s} () - -getLastTk :: P (Strict.Maybe (PsLocated Token)) -getLastTk = P $ \s@(PState { last_tk = last_tk }) -> POk s last_tk - --- see Note [PsSpan in Comments] -getLastLocComment :: P PsSpan -getLastLocComment = P $ \s@(PState { prev_loc = prev_loc }) -> POk s prev_loc - --- see Note [PsSpan in Comments] -getLastLocEof :: P PsSpan -getLastLocEof = P $ \s@(PState { prev_loc2 = prev_loc2 }) -> POk s prev_loc2 - -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 - - -- 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). - 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, - prev_loc2 = 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 - lt <- getLastLocEof - setEofPos (psRealSpan span) (psRealSpan lt) - 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", - strtoken (\s -> (ITinline_prag (SourceText s) (Inline (SourceText s)) FunLike))), - ("inlinable", - strtoken (\s -> (ITinline_prag (SourceText s) (Inlinable (SourceText s)) FunLike))), - ("inlineable", - strtoken (\s -> (ITinline_prag (SourceText s) (Inlinable (SourceText s)) FunLike))), - -- Spelling variant - ("notinline", - strtoken (\s -> (ITinline_prag (SourceText s) (NoInline (SourceText s)) FunLike))), - ("opaque", strtoken (\s -> ITopaque_prag (SourceText s))), - ("specialize", strtoken (\s -> ITspec_prag (SourceText s))), - ("source", strtoken (\s -> ITsource_prag (SourceText s))), - ("warning", strtoken (\s -> ITwarning_prag (SourceText s))), - ("deprecated", strtoken (\s -> ITdeprecated_prag (SourceText s))), - ("scc", strtoken (\s -> ITscc_prag (SourceText s))), - ("unpack", strtoken (\s -> ITunpack_prag (SourceText s))), - ("nounpack", strtoken (\s -> ITnounpack_prag (SourceText s))), - ("ann", strtoken (\s -> ITann_prag (SourceText s))), - ("minimal", strtoken (\s -> ITminimal_prag (SourceText s))), - ("overlaps", strtoken (\s -> IToverlaps_prag (SourceText s))), - ("overlappable", strtoken (\s -> IToverlappable_prag (SourceText s))), - ("overlapping", strtoken (\s -> IToverlapping_prag (SourceText s))), - ("incoherent", strtoken (\s -> ITincoherent_prag (SourceText s))), - ("ctype", strtoken (\s -> ITctype (SourceText s))), - ("complete", strtoken (\s -> ITcomplete_prag (SourceText s))), - ("column", columnPrag) - ] - -twoWordPrags = Map.fromList [ - ("inline conlike", - strtoken (\s -> (ITinline_prag (SourceText s) (Inline (SourceText s)) ConLike))), - ("notinline conlike", - strtoken (\s -> (ITinline_prag (SourceText s) (NoInline (SourceText s)) ConLike))), - ("specialize inline", - strtoken (\s -> (ITspec_inline_prag (SourceText s) True))), - ("specialize notinline", - strtoken (\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 - cmp later earlier - = srcSpanStartLine later - srcSpanEndLine earlier == 1 - - go decl _ [] = ([],decl) - go decl r (c@(L l _):cs) = if cmp r (anchor l) - then go (c:decl) (anchor l) cs - else (reverse (c:cs), decl) - 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) - = case mheader_comments of - Strict.Nothing -> (reverse newAnns, []) - _ -> 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 = lex_char_tok -alex_action_117 = 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,3176 +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.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 _ ki@(L loc _)) = addFatalError $ mkPlainErrorMsgEnvelope (locA loc) $ - (PsErrUnexpectedTypeAppInDecl ki pp_what (unLoc tc)) - check (HsValArg ty) = chkParens [] [] emptyComments 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 -> LHsType GhcPs - -> P (LHsTyVarBndr () GhcPs) - chkParens ops cps cs (L l (HsParTy an ty)) - = let - (o,c) = mkParensEpAnn (realSrcSpan $ locA l) - in - chkParens (o:ops) (c:cps) (cs Semi.<> epAnnComments an) ty - chkParens ops cps cs ty = chk ops cps cs ty - - -- Check that the name space is correct! - chk :: [AddEpAnn] -> [AddEpAnn] -> EpAnnComments -> LHsType GhcPs -> P (LHsTyVarBndr () GhcPs) - chk ops cps cs (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) an) - (KindedTyVar (addAnns (annk Semi.<> ann) an cs) () (L lv tv) k)) - chk ops cps cs (L l (HsTyVar ann _ (L ltv tv))) - | isRdrTyVar tv - = let - an = (reverse ops) ++ cps - in - return (L (widenLocatedAn l an) - (UserTyVar (addAnns ann an cs) () (L ltv tv))) - chk _ _ _ t@(L loc _) - = addFatalError $ mkPlainErrorMsgEnvelope (locA loc) $ - (PsErrUnexpectedTypeInDecl t pp_what (unLoc tc) tparms equals_or_where) - - -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 l ty ki) acc ops cps fix = goL ty (HsTypeArg l 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 "_"))) - -type instance Anno (GRHS GhcPs (LocatedA (PatBuilder GhcPs))) = SrcAnn NoEpAnns -type instance Anno [LocatedA (Match GhcPs (LocatedA (PatBuilder GhcPs)))] = SrcSpanAnnL -type instance Anno (Match GhcPs (LocatedA (PatBuilder GhcPs))) = SrcSpanAnnA -type instance Anno (StmtLR GhcPs GhcPs (LocatedA (PatBuilder GhcPs))) = SrcSpanAnnA - -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 -> SrcSpan -> 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 l_at ki = return (mkHsAppKindTy l_at t 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 l_at ki = - addFatalError $ mkPlainErrorMsgEnvelope l_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] - 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 = Left fs' } - True -> do - let qualifiedFields = - [ L l lbl | L _ (HsFieldBind _ (L l lbl) _ _) <- fs' - , isQual . rdrNameAmbiguousFieldOcc $ lbl - ] - case qualifiedFields of - qf:_ -> addFatalError $ mkPlainErrorMsgEnvelope (getLocA qf) $ - PsErrOverloadedRecordUpdateNoQualifiedFields - _ -> return RecordUpd -- This is a RecordDotSyntax update. - { rupd_ext = anns - , rupd_expr = exp - , rupd_flds = Right (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 -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 - mk (Just (Header (SourceText h) (mkFastString h))) - <$> 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 :: [AddEpAnn] -> LocatedA ImpExpQcSpec -> ImpExpSubSpec -> P (IE GhcPs) -mkModuleImpExp anns (L l specname) subs = do - cs <- getCommentsFor (locA l) -- AZ: IEVar can discard comments - let ann = EpAnn (spanAsAnchor $ locA l) anns cs - case subs of - ImpExpAbs - | isVarNameSpace (rdrNameSpace name) - -> return $ IEVar noExtField (L l (ieNameFromSpec specname)) - | otherwise -> IEThingAbs ann . L l <$> nameT - ImpExpAll -> IEThingAll ann . L l <$> nameT - ImpExpList xs -> - (\newName -> IEThingWith 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 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 "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,14 +54,20 @@ -- | 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))) = 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 + instance Outputable (PatBuilder GhcPs) where ppr (PatBuilderPat p) = ppr p ppr (PatBuilderPar _ (L _ p) _) = parens (ppr p) @@ -104,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 @@ -29,6 +30,7 @@ , platformInIntRange , platformInWordRange , platformCConvNeedsExtension + , platformHasRTSLinker , PlatformMisc(..) , SseVersion (..) , BmiVersion (..) @@ -73,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 @@ -179,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 = @@ -191,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 @@ -272,7 +244,22 @@ | OSDarwin <- platformOS platform -> True _ -> False +-- | Does this platform have an RTS linker? +platformHasRTSLinker :: Platform -> Bool +-- Note that we've inlined this logic in hadrian's +-- Settings.Builders.RunTest.inTreeCompilerArgs. +-- If you change this, be sure to change it too +platformHasRTSLinker p = case archOS_arch (platformArchOS p) of + ArchPPC -> False -- powerpc + ArchPPC_64 ELF_V1 -> False -- powerpc64 + ArchPPC_64 ELF_V2 -> False -- powerpc64le + ArchS390X -> False + ArchLoongArch64 -> False + ArchJavaScript -> False + _ -> True + + -------------------------------------------------- -- Instruction sets -------------------------------------------------- @@ -282,6 +269,7 @@ = SSE1 | SSE2 | SSE3 + | SSSE3 | SSE4 | SSE42 deriving (Eq, Ord) @@ -302,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/Wasm32.hs b/GHC/Platform/Wasm32.hs --- a/GHC/Platform/Wasm32.hs +++ b/GHC/Platform/Wasm32.hs @@ -4,7 +4,6 @@ import GHC.Prelude --- TODO -#define MACHREGS_NO_REGS 1 --- #define MACHREGS_wasm32 1 +#define MACHREGS_NO_REGS 0 +#define MACHREGS_wasm32 1 #include "CodeGen.Platform.h" 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 @@ -55,6 +55,7 @@ , module GHC.Types.Unique.Supply , module GHC.Data.FastString , module GHC.Tc.Errors.Hole.FitTypes -- for hole-fit plugins + , module GHC.Tc.Errors.Hole.Plugin -- for hole-fit plugins , module GHC.Unit.Module.ModGuts , module GHC.Unit.Module.ModSummary , module GHC.Unit.Module.ModIface @@ -148,13 +149,14 @@ import GHC.Types.Name.Cache ( NameCache ) import GHC.Tc.Errors.Hole.FitTypes +import GHC.Tc.Errors.Hole.Plugin -- For parse result plugins import GHC.Parser.Errors.Types ( PsWarning, PsError ) 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 -} @@ -200,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 @@ -2,6 +2,9 @@ {-# OPTIONS_HADDOCK not-home #-} {-# OPTIONS_GHC -O2 #-} -- See Note [-O2 Prelude] +-- See Note [Proxies for head and tail] +{-# OPTIONS_GHC -Wno-unrecognised-warning-flags -Wno-x-partial #-} + -- | Custom minimal GHC "Prelude" -- -- This module serves as a replacement for the "Prelude" module @@ -10,15 +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 + ( module X + , Applicative (..) + , module Bits + , bit + , shiftL, shiftR + , setBit, clearBit + , head, tail, unzip + + , strictGenericLength ) where @@ -50,29 +58,26 @@ extensions. -} -import Prelude as X hiding ((<>), Applicative(..)) +import qualified Prelude +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? @@ -102,3 +107,50 @@ shiftL = Bits.unsafeShiftL 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" #-}, +but the GHC codebase uses them fairly extensively and insists on building warning-free. +Thus, instead of adding {-# OPTIONS_GHC -Wno-x-partial #-} to every module which +employs them, we define warning-less proxies and export them from GHC.Prelude. +-} + +-- See Note [Proxies for head and tail] +head :: HasCallStack => [a] -> a +head = Prelude.head +{-# INLINE head #-} + +-- See Note [Proxies for head and tail] +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,10 +20,16 @@ rnLocalBindsAndThen, rnLocalValBindsLHS, rnLocalValBindsRHS, -- Other bindings - rnMethodBinds, renameSigs, + rnMethodBinds, renameSigs, bindRuleBndrs, rnMatchGroup, rnGRHSs, rnGRHS, rnSrcFixityDecl, - makeMiniFixityEnv, MiniFixityEnv, - HsSigCtxt(..) + makeMiniFixityEnv, MiniFixityEnv, emptyMiniFixityEnv, + HsSigCtxt(..), + + -- Utility for hs-boot files + rejectBootDecls, + + -- Utility for COMPLETE pragmas + localCompletePragmas ) where import GHC.Prelude @@ -41,39 +44,43 @@ import GHC.Rename.Names import GHC.Rename.Env import GHC.Rename.Fixity -import GHC.Rename.Utils ( mapFvRn - , checkDupRdrNames, checkDupRdrNamesN - , warnUnusedLocalBinds - , warnForallIdentifier - , checkUnusedRecordWildcard - , checkDupAndShadowedNames, bindLocalNamesFV - , addNoNestedForallsContextsErr, checkInferredVars ) -import GHC.Driver.Session -import GHC.Unit.Module +import GHC.Rename.Utils +import GHC.Driver.DynFlags + +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(..)) import Control.Monad -import Data.Foldable ( toList ) -import Data.List ( partition, sortBy ) +import Data.List ( partition ) import Data.List.NonEmpty ( NonEmpty(..) ) {- @@ -200,10 +207,20 @@ = do { topBinds <- rnTopBindsLHS fix_env binds ; case topBinds of ValBinds x mbinds sigs -> - do { mapM_ bindInHsBootFileErr mbinds - ; pure (ValBinds x emptyBag sigs) } + do { rejectBootDecls HsBoot BootBindsPs mbinds + ; pure (ValBinds x [] sigs) } _ -> pprPanic "rnTopBindsLHSBoot" (ppr topBinds) } +rejectBootDecls :: HsBootOrSig + -> (NonEmpty (LocatedA decl) -> BadBootDecls) + -> [LocatedA decl] + -> TcM () +rejectBootDecls _ _ [] = return () +rejectBootDecls hsc_src what (decl@(L loc _) : decls) + = addErrAt (locA loc) + $ TcRnIllegalHsBootOrSigDecl hsc_src + (what $ decl :| decls) + rnTopBindsBoot :: NameSet -> HsValBindsLR GhcRn GhcPs -> RnM (HsValBinds GhcRn, DefUses) -- A hs-boot file has no bindings. @@ -299,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 @@ -317,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 $ @@ -335,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) @@ -384,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)) @@ -430,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 @@ -446,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 @@ -508,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' @@ -529,7 +553,7 @@ = do { (bind', name, fvs) <- rnPatSynBind sig_fn bind ; return (PatSynBind x bind', name, fvs) } -rnBind _ b = pprPanic "rnBind" (ppr b) +rnBind _ (VarBind { var_ext = x }) = dataConCantHappen x -- See Note [Pattern bindings that bind no variables] isOkNoBindPattern :: LPat GhcRn -> Bool @@ -558,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 @@ -568,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 @@ -601,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. -} {- ********************************************************************* @@ -610,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 @@ -621,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) @@ -671,36 +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 (dupFixityDecl loc' name) + 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 -dupFixityDecl :: SrcSpan -> RdrName -> TcRnMessage -dupFixityDecl loc rdr_name - = mkTcRnUnknownMessage $ mkPlainError noHints $ - vcat [text "Multiple fixity declarations for" <+> quotes (ppr rdr_name), - text "also at " <+> ppr loc] + 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 @@ -716,7 +759,7 @@ , psb_dir = dir }) -- invariant: no free vars here when it's a FunBind = do { pattern_synonym_ok <- xoptM LangExt.PatternSynonyms - ; unless pattern_synonym_ok (addErr patternSynonymErr) + ; unless pattern_synonym_ok (addErr TcRnIllegalPatternSynonymDecl) ; let scoped_tvs = sig_fn name ; ((pat', details'), fvs1) <- bindSigTyVarsFV scoped_tvs $ @@ -725,10 +768,10 @@ -- so that the binding locations are reported -- from the left-hand side case details of - PrefixCon _ vars -> - do { checkDupRdrNamesN 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] @@ -739,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 @@ -757,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) } @@ -774,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] @@ -785,11 +828,6 @@ -- See Note [Renaming pattern synonym variables] lookupPatSynBndr = wrapLocMA lookupLocalOccRn - patternSynonymErr :: TcRnMessage - patternSynonymErr - = mkTcRnUnknownMessage $ mkPlainError noHints $ - hang (text "Illegal pattern synonym declaration") - 2 (text "Use -XPatternSynonyms to enable this extension") {- Note [Renaming pattern synonym variables] @@ -889,7 +927,7 @@ -- * the default method bindings in a class decl -- * the method bindings in an instance decl rnMethodBinds is_cls_decl cls ktv_names binds sigs - = do { checkDupRdrNamesN (collectMethodBinders binds) + = do { checkDupRdrNames (collectMethodBinders binds) -- Check that the same method is not given twice in the -- same instance decl instance C T where -- f x = ... @@ -901,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 @@ -910,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] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -972,26 +1017,19 @@ -> 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 rnMethodBindLHS is_cls_decl _ (L loc bind) rest - = do { addErrAt (locA loc) $ mkTcRnUnknownMessage $ mkPlainError noHints $ - vcat [ what <+> text "not allowed in" <+> decl_sort - , nest 2 (ppr bind) ] + = do { addErrAt (locA loc) $ TcRnIllegalClassBinding decl_sort bind ; return rest } where - decl_sort | is_cls_decl = text "class declaration:" - | otherwise = 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) + decl_sort | is_cls_decl = ClassDeclSort + | otherwise = InstanceDeclSort {- ************************************************************************ @@ -1027,48 +1065,36 @@ ; 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) } renameSig ctxt sig@(ClassOpSig _ is_deflt vs ty) = do { defaultSigs_on <- xoptM LangExt.DefaultSignatures ; when (is_deflt && not defaultSigs_on) $ - addErr (defaultSigErr sig) - ; mapM_ warnForallIdentifier vs - ; new_v <- mapM (lookupSigOccRnN ctxt sig) vs + addErr (TcRnUnexpectedDefaultSig sig) + ; 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 inf_msg ty + = do { checkInferredVars doc ty ; (new_ty, fvs) <- rnHsSigType doc TypeLevel 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). - ; addNoNestedForallsContextsErr doc (text "SPECIALISE instance type") + ; addNoNestedForallsContextsErr doc NFC_Specialize (getLHsInstDeclHead new_ty) ; return (SpecInstSig (noAnn, src) new_ty,fvs) } where doc = SpecInstSigCtx - inf_msg = Just (text "Inferred type variables are not allowed") -- {-# SPECIALISE #-} pragmas can refer to imported Ids -- so, in the top-level case (when mb_names is Nothing) @@ -1076,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) @@ -1096,40 +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 orphanError + 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 - orphanError :: TcRnMessage - orphanError = mkTcRnUnknownMessage $ mkPlainError noHints $ - 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." + 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] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1152,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 @@ -1175,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 @@ -1196,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)] @@ -1233,9 +1275,69 @@ checkDupMinimalSigs :: [LSig GhcPs] -> RnM () checkDupMinimalSigs sigs = case filter isMinimalLSig sigs of - minSigs@(_:_:_) -> dupMinimalSigErr minSigs + 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 + {- ************************************************************************ * * @@ -1245,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) ) @@ -1277,67 +1379,68 @@ -- \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 (emptyCaseErr 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 ) } -emptyCaseErr :: HsMatchContext GhcRn -> TcRnMessage -emptyCaseErr ctxt = mkTcRnUnknownMessage $ mkPlainError noHints $ message ctxt - where - pp_ctxt :: HsMatchContext GhcRn -> SDoc - pp_ctxt c = case c 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 c - message :: HsMatchContext GhcRn -> SDoc - message (LamCaseAlt LamCases) = lcases_msg <+> text "expression" - message (ArrowMatchCtxt (ArrowLamCaseAlt LamCases)) = - lcases_msg <+> text "command" - message ctxt = - hang (text "Empty list of alternatives in" <+> pp_ctxt ctxt) - 2 (text "Use EmptyCase to allow this") - - lcases_msg = - text "Empty list of alternatives is not allowed in \\cases" - {- ************************************************************************ * * @@ -1347,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) @@ -1357,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) @@ -1373,9 +1476,7 @@ rnBody rhs ; unless (pattern_guards_allowed || is_standard_guard guards') $ - let diag = mkTcRnUnknownMessage $ - mkPlainDiagnostic WarningWithoutFlag noHints (nonStdGuardErr guards') - in addDiagnostic diag + addDiagnostic (nonStdGuardErr guards') ; return (GRHS noAnn guards' rhs', fvs) } where @@ -1405,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" {- ************************************************************************ @@ -1427,44 +1530,18 @@ -} dupSigDeclErr :: NonEmpty (LocatedN RdrName, Sig GhcPs) -> RnM () -dupSigDeclErr pairs@((L loc name, sig) :| _) - = addErrAt (locA loc) $ mkTcRnUnknownMessage $ mkPlainError noHints $ - vcat [ text "Duplicate" <+> what_it_is - <> text "s for" <+> quotes (ppr name) - , text "at" <+> vcat (map ppr $ sortBy SrcLoc.leftmost_smallest - $ map (getLocA . fst) - $ toList pairs) - ] - where - what_it_is = hsSigDoc sig +dupSigDeclErr pairs@((L loc _, _) :| _) + = addErrAt (locA loc) $ TcRnDuplicateSigDecl pairs misplacedSigErr :: LSig GhcRn -> RnM () misplacedSigErr (L loc sig) - = addErrAt (locA loc) $ mkTcRnUnknownMessage $ mkPlainError noHints $ - sep [text "Misplaced" <+> hsSigDoc sig <> colon, ppr sig] - -defaultSigErr :: Sig GhcPs -> TcRnMessage -defaultSigErr sig = mkTcRnUnknownMessage $ mkPlainError noHints $ - vcat [ hang (text "Unexpected default signature:") - 2 (ppr sig) - , text "Use DefaultSignatures to enable default signatures" ] - -bindInHsBootFileErr :: LHsBindLR GhcRn GhcPs -> RnM () -bindInHsBootFileErr (L loc _) - = addErrAt (locA loc) $ mkTcRnUnknownMessage $ mkPlainError noHints $ - vcat [ text "Bindings in hs-boot files are not allowed" ] + = addErrAt (locA loc) $ TcRnMisplacedSigDecl sig nonStdGuardErr :: (Outputable body, Anno (Stmt GhcRn body) ~ SrcSpanAnnA) - => [LStmtLR GhcRn GhcRn body] -> SDoc -nonStdGuardErr guards - = hang (text "accepting non-standard pattern guards (use PatternGuards to suppress this message)") - 4 (interpp'SP guards) + => [LStmtLR GhcRn GhcRn body] -> TcRnMessage +nonStdGuardErr guards = TcRnNonStdGuards (NonStandardGuards guards) -dupMinimalSigErr :: [LSig GhcPs] -> RnM () -dupMinimalSigErr sigs@(L loc _ : _) - = addErrAt (locA loc) $ mkTcRnUnknownMessage $ mkPlainError noHints $ - vcat [ text "Multiple minimal complete definitions" - , text "at" <+> vcat (map ppr $ sortBy SrcLoc.leftmost_smallest $ map getLocA sigs) - , text "Combine alternative minimal complete definitions with `|'" ] -dupMinimalSigErr [] = panic "dupMinimalSigErr" +dupMinimalSigErr :: LSig GhcPs -> LSig GhcPs -> [LSig GhcPs] -> RnM () +dupMinimalSigErr sig1 sig2 otherSigs + = addErrAt (getLocA sig1) $ TcRnDuplicateMinimalSig sig1 sig2 otherSigs diff --git a/GHC/Rename/Doc.hs b/GHC/Rename/Doc.hs --- a/GHC/Rename/Doc.hs +++ b/GHC/Rename/Doc.hs @@ -8,8 +8,6 @@ import GHC.Types.Name import GHC.Types.SrcLoc import GHC.Tc.Utils.Monad (getGblEnv) -import GHC.Types.Avail -import GHC.Rename.Env rnLHsDoc :: LHsDoc GhcPs -> RnM (LHsDoc GhcRn) rnLHsDoc = traverse rnHsDoc @@ -37,10 +35,10 @@ pure (WithHsDocIdentifiers s (rnHsDocIdentifiers gre ids)) rnHsDocIdentifiers :: GlobalRdrEnv - -> [Located RdrName] - -> [Located Name] -rnHsDocIdentifiers gre ns = concat - [ map (L l . greNamePrintableName . gre_name) (lookupGRE_RdrName c gre) + -> [Located RdrName] + -> [Located Name] +rnHsDocIdentifiers gre_env ns = + [ L l $ greName gre | L l rdr_name <- ns - , c <- dataTcOccs rdr_name + , gre <- lookupGRE gre_env (LookupRdrName rdr_name AllRelevantGREs) ] diff --git a/GHC/Rename/Env.hs b/GHC/Rename/Env.hs --- a/GHC/Rename/Env.hs +++ b/GHC/Rename/Env.hs @@ -1,2095 +1,2493 @@ - -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE TypeApplications #-} - -{- -(c) The GRASP/AQUA Project, Glasgow University, 1992-2006 - -GHC.Rename.Env contains functions which convert RdrNames into Names. - --} - -module GHC.Rename.Env ( - newTopSrcBinder, - - lookupLocatedTopBndrRn, lookupLocatedTopBndrRnN, lookupTopBndrRn, - lookupLocatedTopConstructorRn, lookupLocatedTopConstructorRnN, - - lookupLocatedOccRn, lookupLocatedOccRnConstr, lookupLocatedOccRnRecField, - lookupLocatedOccRnNone, - lookupOccRn, lookupOccRn_maybe, - lookupLocalOccRn_maybe, lookupInfoOccRn, - lookupLocalOccThLvl_maybe, lookupLocalOccRn, - lookupTypeOccRn, - lookupGlobalOccRn, lookupGlobalOccRn_maybe, - - AmbiguousResult(..), - lookupExprOccRn, - lookupRecFieldOcc, - lookupRecFieldOcc_update, - - ChildLookupResult(..), - lookupSubBndrOcc_helper, - combineChildLookupResult, -- Called by lookupChildrenExport - - HsSigCtxt(..), lookupLocalTcNames, lookupSigOccRn, lookupSigOccRnN, - lookupSigCtxtOccRn, lookupSigCtxtOccRnN, - - lookupInstDeclBndr, lookupFamInstName, - lookupConstructorFields, - - lookupGreAvailRn, - - -- Rebindable Syntax - lookupSyntax, lookupSyntaxExpr, lookupSyntaxNames, - lookupSyntaxName, - lookupIfThenElse, - - -- QualifiedDo - lookupQualifiedDoExpr, lookupQualifiedDo, - lookupQualifiedDoName, lookupNameWithQualifier, - - -- Constructing usage information - addUsedGRE, addUsedGREs, addUsedDataCons, - - - - dataTcOccs, --TODO: Move this somewhere, into utils? - - ) where - -import GHC.Prelude - -import GHC.Iface.Load ( loadInterfaceForName, loadSrcInterface_maybe ) -import GHC.Iface.Env -import GHC.Hs -import GHC.Types.Name.Reader -import GHC.Tc.Errors.Types -import GHC.Tc.Utils.Env -import GHC.Tc.Utils.Monad -import GHC.Parser.PostProcess ( setRdrNameSpace ) -import GHC.Builtin.Types -import GHC.Types.Name -import GHC.Types.Name.Set -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 -import GHC.Builtin.Names( rOOT_MAIN ) -import GHC.Types.Basic ( TopLevelFlag(..), TupleSort(..) ) -import GHC.Types.SrcLoc as SrcLoc -import GHC.Utils.Outputable as Outputable -import GHC.Types.Unique.Set ( uniqSetAny ) -import GHC.Utils.Misc -import GHC.Utils.Panic -import GHC.Data.Maybe -import GHC.Driver.Session -import GHC.Data.FastString -import Control.Monad -import GHC.Data.List.SetOps ( minusList ) -import qualified GHC.LanguageExtensions as LangExt -import GHC.Rename.Unbound -import GHC.Rename.Utils -import qualified Data.Semigroup as Semi -import Data.Either ( partitionEithers ) -import Data.List ( find ) -import qualified Data.List.NonEmpty as NE -import Control.Arrow ( first ) -import GHC.Types.FieldLabel -import GHC.Data.Bag -import GHC.Types.PkgQual -import Language.Haskell.Syntax.Basic (FieldLabelString(..)) - -{- -********************************************************* -* * - Source-code binders -* * -********************************************************* - -Note [Signature lazy interface loading] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -GHC's lazy interface loading can be a bit confusing, so this Note is an -empirical description of what happens in one interesting case. When -compiling a signature module against an its implementation, we do NOT -load interface files associated with its names until after the type -checking phase. For example: - - module ASig where - data T - f :: T -> T - -Suppose we compile this with -sig-of "A is ASig": - - module B where - data T = T - f T = T - - module A(module B) where - import B - -During type checking, we'll load A.hi because we need to know what the -RdrEnv for the module is, but we DO NOT load the interface for B.hi! -It's wholly unnecessary: our local definition 'data T' in ASig is all -the information we need to finish type checking. This is contrast to -type checking of ordinary Haskell files, in which we would not have the -local definition "data T" and would need to consult B.hi immediately. -(Also, this situation never occurs for hs-boot files, since you're not -allowed to reexport from another module.) - -After type checking, we then check that the types we provided are -consistent with the backing implementation (in checkHiBootOrHsigIface). -At this point, B.hi is loaded, because we need something to compare -against. - -I discovered this behavior when trying to figure out why type class -instances for Data.Map weren't in the EPS when I was type checking a -test very much like ASig (sigof02dm): the associated interface hadn't -been loaded yet! (The larger issue is a moot point, since an instance -declared in a signature can never be a duplicate.) - -This behavior might change in the future. Consider this -alternate module B: - - module B where - {-# DEPRECATED T, f "Don't use" #-} - data T = T - f T = T - -One might conceivably want to report deprecation warnings when compiling -ASig with -sig-of B, in which case we need to look at B.hi to find the -deprecation warnings during renaming. At the moment, you don't get any -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] --} - -newTopSrcBinder :: LocatedN RdrName -> RnM Name -newTopSrcBinder (L loc rdr_name) - | Just name <- isExact_maybe rdr_name - = -- This is here to catch - -- (a) Exact-name binders created by Template Haskell - -- (b) The PrelBase defn of (say) [] and similar, for which - -- the parser reads the special syntax and returns an Exact RdrName - -- We are at a binding site for the name, so check first that it - -- the current module is the correct one; otherwise GHC can get - -- very confused indeed. This test rejects code like - -- data T = (,) Int Int - -- unless we are in GHC.Tup - if isExternalName name then - do { this_mod <- getModule - ; unless (this_mod == nameModule name) - (addErrAt (locA loc) (badOrigBinding rdr_name)) - ; return name } - else -- See Note [Binders in Template Haskell] in "GHC.ThToHs" - do { this_mod <- getModule - ; externaliseName this_mod name } - - | Just (rdr_mod, rdr_occ) <- isOrig_maybe rdr_name - = do { this_mod <- getModule - ; unless (rdr_mod == this_mod || rdr_mod == rOOT_MAIN) - (addErrAt (locA loc) (badOrigBinding rdr_name)) - -- When reading External Core we get Orig names as binders, - -- but they should agree with the module gotten from the monad - -- - -- We can get built-in syntax showing up here too, sadly. If you type - -- data T = (,,,) - -- the constructor is parsed as a type, and then GHC.Parser.PostProcess.tyConToDataCon - -- uses setRdrNameSpace to make it into a data constructors. At that point - -- the nice Exact name for the TyCon gets swizzled to an Orig name. - -- Hence the badOrigBinding error message. - -- - - -- MP 2022: I suspect this code path is never called for `rOOT_MAIN` anymore - -- because External Core has been removed but we instead have some similar logic for - -- serialising whole programs into interface files in GHC.IfaceToCore.mk_top_id. - - -- Except for the ":Main.main = ..." definition inserted into - -- the Main module; ugh! - - -- Because of this latter case, we call newGlobalBinder with a module from - -- the RdrName, not from the environment. In principle, it'd be fine to - -- have an arbitrary mixture of external core definitions in a single module, - -- (apart from module-initialisation issues, perhaps). - ; newGlobalBinder rdr_mod rdr_occ (locA loc) } - - | otherwise - = do { when (isQual rdr_name) - (addErrAt (locA loc) (badQualBndrErr rdr_name)) - -- 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 - -- 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 - ; return (mkInternalName uniq (rdrNameOcc rdr_name) (locA loc)) } - else - do { this_mod <- getModule - ; traceRn "newTopSrcBinder" (ppr this_mod $$ ppr rdr_name $$ ppr (locA loc)) - ; newGlobalBinder this_mod (rdrNameOcc rdr_name) (locA loc) } - } - -{- -********************************************************* -* * - Source code occurrences -* * -********************************************************* - -Looking up a name in the GHC.Rename.Env. - -Note [Type and class operator definitions] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We want to reject all of these unless we have -XTypeOperators (#3265) - data a :*: b = ... - class a :*: b where ... - data (:*:) a b = .... - class (:*:) a b where ... -The latter two mean that we are not just looking for a -*syntactically-infix* declaration, but one that uses an operator -OccName. We use OccName.isSymOcc to detect that case, which isn't -terribly efficient, but there seems to be no better way. --} - --- Can be made to not be exposed --- Only used unwrapped in rnAnnProvenance -lookupTopBndrRn :: WhatLooking -> RdrName -> RnM Name --- Look up a top-level source-code binder. We may be looking up an unqualified 'f', --- and there may be several imported 'f's too, which must not confuse us. --- For example, this is OK: --- import Foo( f ) --- infix 9 f -- The 'f' here does not need to be qualified --- f x = x -- Nor here, of course --- So we have to filter out the non-local ones. --- --- 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 id $ - do { -- Check for operators in type or class declarations - -- See Note [Type and class operator definitions] - let occ = rdrNameOcc rdr_name - ; when (isTcOcc occ && isSymOcc occ) - (do { op_ok <- xoptM LangExt.TypeOperators - ; unless op_ok (addErr (TcRnIllegalTypeOperatorDecl rdr_name)) }) - - ; env <- getGlobalRdrEnv - ; case filter isLocalGRE (lookupGRE_RdrName rdr_name env) of - [gre] -> return (greMangledName 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) - --- | Lookup an @Exact@ @RdrName@. See Note [Looking up Exact RdrNames]. --- This never adds an error, but it may return one, see --- Note [Errors in lookup functions] -lookupExactOcc_either :: Name -> RnM (Either NotInScopeError Name) -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 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 - ; checkTupSize tupArity - ; return (Right name) } - - | isExternalName name - = return (Right name) - - | otherwise - = do { env <- getGlobalRdrEnv - ; let -- See Note [Splicing Exact names] - main_occ = nameOccName name - demoted_occs = case demoteOccName main_occ of - Just occ -> [occ] - Nothing -> [] - gres = [ gre | occ <- main_occ : demoted_occs - , gre <- lookupGlobalRdrEnv env occ - , greMangledName gre == name ] - ; case gres of - [gre] -> return (Right (greMangledName gre)) - - [] -> -- See Note [Splicing Exact names] - do { lcl_env <- getLocalRdrEnv - ; if name `inLocalRdrEnvScope` lcl_env - then return (Right name) - else - do { th_topnames_var <- fmap tcg_th_topnames getGblEnv - ; th_topnames <- readTcRef th_topnames_var - ; if name `elemNameSet` th_topnames - then return (Right name) - else return (Left (NoExactName name)) - } - } - - gres -> return (Left (SameName gres)) -- Ugh! See Note [Template Haskell ambiguity] - } - ------------------------------------------------ -lookupInstDeclBndr :: Name -> SDoc -> 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 = ... --- ^^^^ called on this --- Regardless of how many unqualified fmaps are in scope, we want --- the one that comes from the Functor class. --- --- Furthermore, note that we take no account of whether the --- name is only in scope qualified. I.e. even if method op is --- in scope as M.op, we still allow plain 'op' on the LHS of --- an instance decl --- --- The "what" parameter says "method" or "associated type", --- depending on what we are looking up -lookupInstDeclBndr cls what rdr - = do { when (isQual rdr) - (addErr (badQualBndrErr rdr)) - -- In an instance decl you aren't allowed - -- to use a qualified name for the method - -- (Although it'd make perfect sense.) - ; mb_name <- lookupSubBndrOcc - False -- False => we don't give deprecated - -- warnings when a deprecated class - -- method is defined. We only warn - -- when it's used - cls doc rdr - ; case mb_name of - Left err -> do { addErr (mkTcRnNotInScope rdr err) - ; return (mkUnboundNameRdr rdr) } - Right nm -> return nm } - where - doc = what <+> text "of class" <+> quotes (ppr cls) - ------------------------------------------------ -lookupFamInstName :: Maybe Name -> LocatedN RdrName - -> RnM (LocatedN Name) --- 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 -lookupFamInstName Nothing tc_rdr -- Family instance; tc_rdr is an *occurrence* - = lookupLocatedOccRnConstr tc_rdr - ------------------------------------------------ -lookupConstructorFields :: Name -> RnM [FieldLabel] --- Look up the fields of a given constructor --- * For constructors from this module, use the record field env, --- which is itself gathered from the (as yet un-typechecked) --- data type decls --- --- * For constructors from imported modules, use the *type* environment --- since imported modules are already compiled, the info is conveniently --- right there - -lookupConstructorFields con_name - = do { this_mod <- getModule - ; if nameIsLocalOrFrom this_mod con_name then - do { field_env <- getRecFieldEnv - ; traceTc "lookupCF" (ppr con_name $$ ppr (lookupNameEnv field_env con_name) $$ ppr field_env) - ; return (lookupNameEnv field_env con_name `orElse` []) } - else - do { con <- tcLookupConLike con_name - ; traceTc "lookupCF 2" (ppr con) - ; return (conLikeFieldLabels con) } } - - --- In CPS style as `RnM r` is monadic --- Reports an error if the name is an Exact or Orig and it can't find the name --- Otherwise if it is not an Exact or Orig, returns k -lookupExactOrOrig :: RdrName -> (Name -> r) -> RnM r -> RnM r -lookupExactOrOrig rdr_name res k - = do { men <- lookupExactOrOrig_base rdr_name - ; case men of - FoundExactOrOrig n -> return (res n) - ExactOrOrigError e -> - do { addErr (mkTcRnNotInScope rdr_name e) - ; return (res (mkUnboundNameRdr rdr_name)) } - NotExactOrOrig -> k } - --- Variant of 'lookupExactOrOrig' that does not report an error --- See Note [Errors in lookup functions] --- Calls k if the name is neither an Exact nor Orig -lookupExactOrOrig_maybe :: RdrName -> (Maybe Name -> r) -> RnM r -> RnM r -lookupExactOrOrig_maybe rdr_name res k - = do { men <- lookupExactOrOrig_base rdr_name - ; case men of - FoundExactOrOrig n -> return (res (Just n)) - ExactOrOrigError _ -> return (res Nothing) - NotExactOrOrig -> k } - -data ExactOrOrigResult = FoundExactOrOrig Name -- ^ Found an Exact Or Orig Name - | ExactOrOrigError NotInScopeError -- ^ The RdrName was an Exact - -- or Orig, but there was an - -- error looking up the Name - | NotExactOrOrig -- ^ The RdrName is neither an Exact nor - -- Orig - --- Does the actual looking up an Exact or Orig name, see 'ExactOrOrigResult' -lookupExactOrOrig_base :: RdrName -> RnM ExactOrOrigResult -lookupExactOrOrig_base rdr_name - | Just n <- isExact_maybe rdr_name -- This happens in derived code - = cvtEither <$> lookupExactOcc_either n - | Just (rdr_mod, rdr_occ) <- isOrig_maybe rdr_name - = FoundExactOrOrig <$> lookupOrig rdr_mod rdr_occ - | otherwise = return NotExactOrOrig - where - cvtEither (Left e) = ExactOrOrigError e - cvtEither (Right n) = FoundExactOrOrig n - - -{- Note [Errors in lookup functions] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Many of these lookup functions will attach an error if it can't find the Name it -is trying to lookup. However there are also _maybe and _either variants for many -of these functions. - -These variants should *not* attach any errors, as there are -places where we want to attempt looking up a name, but it's not the end of the -world if we don't find it. - -For example, see lookupThName_maybe: It calls lookupOccRn_maybe multiple -times for varying names in different namespaces. lookupOccRn_maybe should -therefore never attach an error, instead just return a Nothing. - -For these _maybe/_either variant functions then, avoid calling further lookup -functions that can attach errors and instead call their _maybe/_either -counterparts. --} - ------------------------------------------------ --- | Look up an occurrence of a field in record construction or pattern --- matching (but not update). When the -XDisambiguateRecordFields --- flag is on, take account of the data constructor name to --- disambiguate which field to use. --- --- See Note [DisambiguateRecordFields] and Note [NoFieldSelectors]. -lookupRecFieldOcc :: Maybe 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 - , isUnboundName con -- Avoid error cascade - = return (mkUnboundNameRdr rdr_name) - | Just con <- mb_con - = lookupExactOrOrig rdr_name id $ -- See Note [Record field names and Template Haskell] - do { flds <- lookupConstructorFields con - ; env <- getGlobalRdrEnv - ; let lbl = FieldLabelString $ occNameFS (rdrNameOcc rdr_name) - mb_field = do fl <- find ((== lbl) . flLabel) flds - -- We have the label, now check it is in scope. If - -- there is a qualifier, use pickGREs to check that - -- the qualifier is correct, and return the filtered - -- GRE so we get import usage right (see #17853). - gre <- lookupGRE_FieldLabel env fl - if isQual rdr_name - then do gre' <- listToMaybe (pickGREs rdr_name [gre]) - return (fl, gre') - else return (fl, gre) - ; case mb_field of - Just (fl, gre) -> do { addUsedGRE True gre - ; return (flSelector fl) } - Nothing -> do { addErr (badFieldConErr con lbl) - ; return (mkUnboundNameRdr rdr_name) } } - - | otherwise -- Can't use the data constructor to disambiguate - = lookupGlobalOccRn' WantBoth rdr_name - -- This use of Global is right as we are looking up a selector, - -- which can only be defined at the top level. - --- | Look up an occurrence of a field in a record update, returning the selector --- name. --- --- Unlike construction and pattern matching with @-XDisambiguateRecordFields@ --- (see 'lookupRecFieldOcc'), there is no data constructor to help disambiguate, --- so this may be ambiguous if the field is in scope multiple times. However we --- ignore non-fields in scope with the same name if @-XDisambiguateRecordFields@ --- is on (see Note [DisambiguateRecordFields for updates]). --- --- Here a field is in scope even if @NoFieldSelectors@ was enabled at its --- definition site (see Note [NoFieldSelectors]). -lookupRecFieldOcc_update - :: DuplicateRecordFields - -> RdrName - -> RnM AmbiguousResult -lookupRecFieldOcc_update dup_fields_ok rdr_name = do - disambig_ok <- xoptM LangExt.DisambiguateRecordFields - let want | disambig_ok = WantField - | otherwise = WantBoth - mr <- lookupGlobalOccRn_overloaded dup_fields_ok want rdr_name - case mr of - Just r -> return r - Nothing -- Try again if we previously looked only for fields, see - -- Note [DisambiguateRecordFields for updates] - | disambig_ok -> do mr' <- lookupGlobalOccRn_overloaded dup_fields_ok WantBoth rdr_name - case mr' of - Just r -> return r - Nothing -> unbound - | otherwise -> unbound - where - unbound = UnambiguousGre . NormalGreName - <$> unboundName (LF WL_RecField WL_Global) rdr_name - - -{- Note [DisambiguateRecordFields] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When we are looking up record fields in record construction or pattern -matching, we can take advantage of the data constructor name to -resolve fields that would otherwise be ambiguous (provided the --XDisambiguateRecordFields flag is on). - -For example, consider: - - data S = MkS { x :: Int } - data T = MkT { x :: Int } - - e = MkS { x = 3 } - -When we are renaming the occurrence of `x` in `e`, instead of looking -`x` up directly (and finding both fields), lookupRecFieldOcc will -search the fields of `MkS` to find the only possible `x` the user can -mean. - -Of course, we still have to check the field is in scope, using -lookupGRE_FieldLabel. The handling of qualified imports is slightly -subtle: the occurrence may be unqualified even if the field is -imported only qualified (but if the occurrence is qualified, the -qualifier must be correct). For example: - - module A where - data S = MkS { x :: Int } - data T = MkT { x :: Int } - - module B where - import qualified A (S(..)) - import A (T(MkT)) - - e1 = MkT { x = 3 } -- x not in scope, so fail - e2 = A.MkS { B.x = 3 } -- module qualifier is wrong, so fail - e3 = A.MkS { x = 3 } -- x in scope (lack of module qualifier permitted) - -In case `e1`, lookupGRE_FieldLabel will return Nothing. In case `e2`, -lookupGRE_FieldLabel will return the GRE for `A.x`, but then the guard -will fail because the field RdrName `B.x` is qualified and pickGREs -rejects the GRE. In case `e3`, lookupGRE_FieldLabel will return the -GRE for `A.x` and the guard will succeed because the field RdrName `x` -is unqualified. - - -Note [DisambiguateRecordFields for updates] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When we are looking up record fields in record update, we can take advantage of -the fact that we know we are looking for a field, even though we do not know the -data constructor name (as in Note [DisambiguateRecordFields]), provided the --XDisambiguateRecordFields flag is on. - -For example, consider: - - module N where - f = () - - {-# LANGUAGE DisambiguateRecordFields #-} - module M where - import N (f) - data T = MkT { f :: Int } - t = MkT { f = 1 } -- unambiguous because MkT determines which field we mean - u = t { f = 2 } -- unambiguous because we ignore the non-field 'f' - -This works by lookupRecFieldOcc_update using 'WantField :: FieldsOrSelectors' -when looking up the field name, so that 'filterFieldGREs' will later ignore any -non-fields in scope. Of course, if a record update has two fields in scope with -the same name, it is still ambiguous. - -If we do not find anything when looking only for fields, we try again allowing -fields or non-fields. This leads to a better error message if the user -mistakenly tries to use a non-field name in a record update: - - f = () - e x = x { f = () } - -Unlike with constructors or pattern-matching, we do not allow the module -qualifier to be omitted, because we do not have a data constructor from which to -determine it. - -Note [Record field names and Template Haskell] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider (#12130): - - module Foo where - import M - b = $(funny) - - module M(funny) where - data T = MkT { x :: Int } - funny :: Q Exp - funny = [| MkT { x = 3 } |] - -When we splice, `MkT` is not lexically in scope, so -lookupGRE_FieldLabel will fail. But there is no need for -disambiguation anyway, because `x` is an original name, and -lookupGlobalOccRn will find it. --} - - --- | Used in export lists to lookup the children. -lookupSubBndrOcc_helper :: Bool -> Bool -> Name -> RdrName - -> RnM ChildLookupResult -lookupSubBndrOcc_helper must_have_parent warn_if_deprec parent rdr_name - | isUnboundName parent - -- Avoid an error cascade - = return (FoundChild NoParent (NormalGreName (mkUnboundNameRdr rdr_name))) - - | otherwise = do - gre_env <- getGlobalRdrEnv - - let original_gres = lookupGlobalRdrEnv gre_env (rdrNameOcc rdr_name) - -- Disambiguate the lookup based on the parent information. - -- 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 "lookupExportChild original_gres:" (ppr original_gres) - traceRn "lookupExportChild picked_gres:" (ppr (picked_gres original_gres) $$ ppr must_have_parent) - case picked_gres original_gres of - NoOccurrence -> - noMatchingParentErr original_gres - UniqueOccurrence g -> - if must_have_parent then noMatchingParentErr original_gres - else checkFld g - DisambiguatedOccurrence g -> - checkFld g - AmbiguousOccurrence gres -> - mkNameClashErr gres - where - -- Convert into FieldLabel if necessary - checkFld :: GlobalRdrElt -> RnM ChildLookupResult - checkFld g@GRE{gre_name,gre_par} = do - addUsedGRE warn_if_deprec g - return $ FoundChild gre_par gre_name - - -- Called when we find no matching GREs after disambiguation but - -- there are three situations where this happens. - -- 1. There were none to begin with. - -- 2. None of the matching ones were the parent but - -- a. They were from an overloaded record field so we can report - -- a better error - -- b. The original lookup was actually ambiguous. - -- For example, the case where overloading is off and two - -- record fields are in scope from different record - -- constructors, neither of which is the parent. - noMatchingParentErr :: [GlobalRdrElt] -> RnM ChildLookupResult - noMatchingParentErr original_gres = do - traceRn "npe" (ppr original_gres) - dup_fields_ok <- xoptM LangExt.DuplicateRecordFields - case original_gres of - [] -> return NameNotFound - [g] -> return $ IncorrectParent parent - (gre_name g) - [p | Just p <- [getParent g]] - gss@(g:gss'@(_:_)) -> - if all isRecFldGRE gss && dup_fields_ok - then return $ - IncorrectParent parent - (gre_name g) - [p | x <- gss, Just p <- [getParent x]] - else mkNameClashErr $ g NE.:| gss' - - mkNameClashErr :: NE.NonEmpty GlobalRdrElt -> RnM ChildLookupResult - mkNameClashErr gres = do - addNameClashErrRn rdr_name gres - return (FoundChild (gre_par (NE.head gres)) (gre_name (NE.head gres))) - - getParent :: GlobalRdrElt -> Maybe Name - getParent (GRE { gre_par = p } ) = - case p of - ParentIs cur_parent -> Just cur_parent - NoParent -> Nothing - - picked_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 - picked_gres gres - | isUnqual rdr_name - = mconcat (map right_parent gres) - | otherwise - = mconcat (map right_parent (pickGREs rdr_name gres)) - - right_parent :: GlobalRdrElt -> DisambigInfo - right_parent p - = case getParent p of - Just cur_parent - | parent == cur_parent -> DisambiguatedOccurrence p - | otherwise -> NoOccurrence - Nothing -> UniqueOccurrence p - - --- This domain specific datatype is used to record why we decided it was --- possible that a GRE could be exported with a parent. -data DisambigInfo - = NoOccurrence - -- The GRE could never be exported. It has the wrong parent. - | UniqueOccurrence GlobalRdrElt - -- The GRE has no parent. It could be a pattern synonym. - | DisambiguatedOccurrence GlobalRdrElt - -- The parent of the GRE is the correct parent - | AmbiguousOccurrence (NE.NonEmpty GlobalRdrElt) - -- For example, two normal identifiers with the same name are in - -- scope. They will both be resolved to "UniqueOccurrence" and the - -- monoid will combine them to this failing case. - -instance Outputable DisambigInfo where - ppr NoOccurrence = text "NoOccurrence" - ppr (UniqueOccurrence gre) = text "UniqueOccurrence:" <+> ppr gre - ppr (DisambiguatedOccurrence gre) = text "DiambiguatedOccurrence:" <+> ppr gre - ppr (AmbiguousOccurrence gres) = text "Ambiguous:" <+> ppr gres - -instance Semi.Semigroup DisambigInfo where - -- This is the key line: We prefer disambiguated occurrences to other - -- names. - _ <> DisambiguatedOccurrence g' = DisambiguatedOccurrence g' - DisambiguatedOccurrence g' <> _ = DisambiguatedOccurrence g' - - NoOccurrence <> m = m - m <> NoOccurrence = m - UniqueOccurrence g <> UniqueOccurrence g' - = AmbiguousOccurrence $ g NE.:| [g'] - UniqueOccurrence g <> AmbiguousOccurrence gs - = AmbiguousOccurrence (g `NE.cons` gs) - AmbiguousOccurrence gs <> UniqueOccurrence g' - = AmbiguousOccurrence (g' `NE.cons` gs) - AmbiguousOccurrence gs <> AmbiguousOccurrence gs' - = AmbiguousOccurrence (gs Semi.<> gs') - -instance Monoid DisambigInfo where - mempty = NoOccurrence - mappend = (Semi.<>) - --- Lookup SubBndrOcc can never be ambiguous --- --- Records the result of looking up a child. -data ChildLookupResult - = NameNotFound -- We couldn't find a suitable name - | IncorrectParent Name -- Parent - GreName -- Child we were looking for - [Name] -- List of possible parents - | FoundChild Parent GreName -- We resolved to a child - --- | Specialised version of msum for RnM ChildLookupResult -combineChildLookupResult :: [RnM ChildLookupResult] -> RnM ChildLookupResult -combineChildLookupResult [] = return NameNotFound -combineChildLookupResult (x:xs) = do - res <- x - case res of - NameNotFound -> combineChildLookupResult xs - _ -> return res - -instance Outputable ChildLookupResult where - ppr NameNotFound = text "NameNotFound" - ppr (FoundChild p n) = text "Found:" <+> ppr p <+> ppr n - ppr (IncorrectParent p n ns) = text "IncorrectParent" - <+> hsep [ppr p, ppr n, ppr ns] - -lookupSubBndrOcc :: Bool - -> Name -- Parent - -> SDoc - -> RdrName - -> RnM (Either NotInScopeError Name) --- Find all the things the rdr-name maps to --- and pick the one with the right parent name -lookupSubBndrOcc warn_if_deprec the_parent doc rdr_name = do - res <- - lookupExactOrOrig rdr_name (FoundChild NoParent . NormalGreName) $ - -- This happens for built-in classes, see mod052 for example - lookupSubBndrOcc_helper True warn_if_deprec the_parent rdr_name - case res of - NameNotFound -> return (Left (UnknownSubordinate doc)) - FoundChild _p child -> return (Right (greNameMangledName child)) - IncorrectParent {} - -- See [Mismatched class methods and associated type families] - -- in TcInstDecls. - -> return $ Left (UnknownSubordinate doc) - -{- -Note [Family instance binders] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - data family F a - data instance F T = X1 | X2 - -The 'data instance' decl has an *occurrence* of F (and T), and *binds* -X1 and X2. (This is unlike a normal data type declaration which would -bind F too.) So we want an AvailTC F [X1,X2]. - -Now consider a similar pair: - class C a where - data G a - instance C S where - data G S = Y1 | Y2 - -The 'data G S' *binds* Y1 and Y2, and has an *occurrence* of G. - -But there is a small complication: in an instance decl, we don't use -qualified names on the LHS; instead we use the class to disambiguate. -Thus: - module M where - import Blib( G ) - class C a where - data G a - instance C S where - data G S = Y1 | Y2 -Even though there are two G's in scope (M.G and Blib.G), the occurrence -of 'G' in the 'instance C S' decl is unambiguous, because C has only -one associated type called G. This is exactly what happens for methods, -and it is only consistent to do the same thing for types. That's the -role of the function lookupTcdName; the (Maybe Name) give the class of -the enclosing instance decl, if any. - -Note [Looking up Exact RdrNames] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Exact RdrNames are generated by: - -* Template Haskell (See Note [Binders in Template Haskell] in GHC.ThToHs) -* Derived instances (See Note [Auxiliary binders] in GHC.Tc.Deriv.Generate) - -For data types and classes have Exact system Names in the binding -positions for constructors, TyCons etc. For example - [d| data T = MkT Int |] -when we splice in and convert to HsSyn RdrName, we'll get - data (Exact (system Name "T")) = (Exact (system Name "MkT")) ... -These System names are generated by GHC.ThToHs.thRdrName - -But, constructors and the like need External Names, not System Names! -So we do the following - - * In GHC.Rename.Env.newTopSrcBinder we spot Exact RdrNames that wrap a - non-External Name, and make an External name for it. This is - the name that goes in the GlobalRdrEnv - - * When looking up an occurrence of an Exact name, done in - GHC.Rename.Env.lookupExactOcc, we find the Name with the right unique in the - GlobalRdrEnv, and use the one from the envt -- it will be an - External Name in the case of the data type/constructor above. - - * Exact names are also use for purely local binders generated - by TH, such as \x_33. x_33 - Both binder and occurrence are Exact RdrNames. The occurrence - gets looked up in the LocalRdrEnv by GHC.Rename.Env.lookupOccRn, and - misses, because lookupLocalRdrEnv always returns Nothing for - an Exact Name. Now we fall through to lookupExactOcc, which - will find the Name is not in the GlobalRdrEnv, so we just use - the Exact supplied Name. - -Note [Splicing Exact names] -~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider the splice $(do { x <- newName "x"; return (VarE x) }) -This will generate a (HsExpr RdrName) term that mentions the -Exact RdrName "x_56" (or whatever), but does not bind it. So -when looking such Exact names we want to check that it's in scope, -otherwise the type checker will get confused. To do this we need to -keep track of all the Names in scope, and the LocalRdrEnv does just that; -we consult it with RdrName.inLocalRdrEnvScope. - -There is another wrinkle. With TH and -XDataKinds, consider - $( [d| data Nat = Zero - data T = MkT (Proxy 'Zero) |] ) -After splicing, but before renaming we get this: - data Nat_77{tc} = Zero_78{d} - data T_79{tc} = MkT_80{d} (Proxy 'Zero_78{tc}) |] ) -The occurrence of 'Zero in the data type for T has the right unique, -but it has a TcClsName name-space in its OccName. (This is set by -the ctxt_ns argument of Convert.thRdrName.) When we check that is -in scope in the GlobalRdrEnv, we need to look up the DataName namespace -too. (An alternative would be to make the GlobalRdrEnv also have -a Name -> GRE mapping.) - -Note [Template Haskell ambiguity] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The GlobalRdrEnv invariant says that if - occ -> [gre1, ..., gren] -then the gres have distinct Names (INVARIANT 1 of GlobalRdrEnv). -This is guaranteed by extendGlobalRdrEnvRn (the dups check in add_gre). - -So how can we get multiple gres in lookupExactOcc_maybe? Because in -TH we might use the same TH NameU in two different name spaces. -eg (#7241): - $(newName "Foo" >>= \o -> return [DataD [] o [] [RecC o []] [''Show]]) -Here we generate a type constructor and data constructor with the same -unique, but different name spaces. - -It'd be nicer to rule this out in extendGlobalRdrEnvRn, but that would -mean looking up the OccName in every name-space, just in case, and that -seems a bit brutal. So it's just done here on lookup. But we might -need to revisit that choice. - -Note [Usage for sub-bndrs] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -If you have this - import qualified M( C( f ) ) - instance M.C T where - f x = x -then is the qualified import M.f used? Obviously yes. -But the RdrName used in the instance decl is unqualified. In effect, -we fill in the qualification by looking for f's whose class is M.C -But when adding to the UsedRdrNames we must make that qualification -explicit (saying "used M.f"), otherwise we get "Redundant import of M.f". - -So we make up a suitable (fake) RdrName. But be careful - import qualified M - import M( C(f) ) - instance C T where - f x = x -Here we want to record a use of 'f', not of 'M.f', otherwise -we'll miss the fact that the qualified import is redundant. - --------------------------------------------------- --- Occurrences --------------------------------------------------- --} - - -lookupLocatedOccRn :: GenLocated (SrcSpanAnn' ann) RdrName - -> TcRn (GenLocated (SrcSpanAnn' ann) Name) -lookupLocatedOccRn = wrapLocMA lookupOccRn - -lookupLocatedOccRnConstr :: GenLocated (SrcSpanAnn' ann) RdrName - -> TcRn (GenLocated (SrcSpanAnn' ann) Name) -lookupLocatedOccRnConstr = wrapLocMA lookupOccRnConstr - -lookupLocatedOccRnRecField :: GenLocated (SrcSpanAnn' ann) RdrName - -> TcRn (GenLocated (SrcSpanAnn' ann) Name) -lookupLocatedOccRnRecField = wrapLocMA lookupOccRnRecField - -lookupLocatedOccRnNone :: GenLocated (SrcSpanAnn' ann) RdrName - -> TcRn (GenLocated (SrcSpanAnn' ann) Name) -lookupLocatedOccRnNone = wrapLocMA lookupOccRnNone - -lookupLocalOccRn_maybe :: RdrName -> RnM (Maybe Name) --- Just look in the local environment -lookupLocalOccRn_maybe rdr_name - = do { local_env <- getLocalRdrEnv - ; return (lookupLocalRdrEnv local_env rdr_name) } - -lookupLocalOccThLvl_maybe :: Name -> RnM (Maybe (TopLevelFlag, ThLevel)) --- Just look in the local environment -lookupLocalOccThLvl_maybe name - = do { lcl_env <- getLclEnv - ; return (lookupNameEnv (tcl_th_bndrs lcl_env) name) } - --- lookupOccRn' looks up an occurrence of a RdrName, and uses its argument to --- determine what kind of suggestions should be displayed if it is not in scope -lookupOccRn' :: WhatLooking -> RdrName -> RnM Name -lookupOccRn' which_suggest rdr_name - = do { mb_name <- lookupOccRn_maybe rdr_name - ; case mb_name of - Just name -> return name - Nothing -> reportUnboundName' which_suggest rdr_name } - --- lookupOccRn looks up an occurrence of a RdrName and displays suggestions if --- it is not in scope -lookupOccRn :: RdrName -> RnM Name -lookupOccRn = lookupOccRn' WL_Anything - --- lookupOccRnConstr looks up an occurrence of a RdrName and displays --- constructors and pattern synonyms as suggestions if it is not in scope -lookupOccRnConstr :: RdrName -> RnM Name -lookupOccRnConstr = lookupOccRn' WL_Constructor - --- lookupOccRnRecField looks up an occurrence of a RdrName and displays --- record fields as suggestions if it is not in scope -lookupOccRnRecField :: RdrName -> RnM Name -lookupOccRnRecField = lookupOccRn' WL_RecField - --- lookupOccRnRecField looks up an occurrence of a RdrName and displays --- no suggestions if it is not in scope -lookupOccRnNone :: RdrName -> RnM Name -lookupOccRnNone = lookupOccRn' WL_None - --- Only used in one place, to rename pattern synonym binders. --- See Note [Renaming pattern synonym variables] in GHC.Rename.Bind -lookupLocalOccRn :: RdrName -> RnM Name -lookupLocalOccRn rdr_name - = do { mb_name <- lookupLocalOccRn_maybe rdr_name - ; case mb_name of - Just name -> return name - Nothing -> unboundName (LF WL_Anything 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 (rdrNameOcc rdr_name) -- See Note [Promoted variables in types] - = badVarInType rdr_name - | otherwise - = do { mb_name <- lookupOccRn_maybe rdr_name - ; case mb_name of - Just name -> return name - Nothing -> - if occName rdr_name == occName eqTyCon_RDR -- See Note [eqTyCon (~) compatibility fallback] - then eqTyConName <$ addDiagnostic TcRnTypeEqualityOutOfScope - else lookup_demoted rdr_name } - -{- Note [eqTyCon (~) compatibility fallback] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Before GHC Proposal #371, the (~) type operator used in type equality -constraints (a~b) was considered built-in syntax. - -This had two implications: - -1. Users could use it without importing it from Data.Type.Equality or Prelude. -2. TypeOperators were not required to use it (it was guarded behind TypeFamilies/GADTs instead) - -To ease migration and minimize breakage, we continue to support those usages -but emit appropriate warnings. --} - -lookup_demoted :: RdrName -> RnM Name -lookup_demoted rdr_name - | Just demoted_rdr <- demoteRdrName rdr_name - -- Maybe it's the name of a *data* constructor - = do { data_kinds <- xoptM LangExt.DataKinds - ; star_is_type <- xoptM LangExt.StarIsType - ; let is_star_type = if star_is_type then StarIsType else StarIsNotType - star_is_type_hints = noStarIsTypeHints is_star_type rdr_name - ; if data_kinds - then do { mb_demoted_name <- lookupOccRn_maybe demoted_rdr - ; case mb_demoted_name of - Nothing -> unboundNameX looking_for rdr_name star_is_type_hints - Just demoted_name -> return demoted_name } - else do { -- We need to check if a data constructor of this name is - -- in scope to give good error messages. However, we do - -- not want to give an additional error if the data - -- constructor happens to be out of scope! See #13947. - mb_demoted_name <- discardErrs $ - lookupOccRn_maybe demoted_rdr - ; let suggestion | isJust mb_demoted_name - , let additional = text "to refer to the data constructor of that name?" - = [SuggestExtension $ SuggestSingleExtension additional LangExt.DataKinds] - | otherwise - = star_is_type_hints - ; unboundNameX looking_for rdr_name suggestion } } - - | otherwise - = reportUnboundName' (lf_which looking_for) rdr_name - - where - looking_for = LF WL_Constructor WL_Anywhere - --- If the given RdrName can be promoted to the type level and its promoted variant is in scope, --- lookup_promoted returns the corresponding type-level Name. --- Otherwise, the function returns Nothing. --- See Note [Promotion] below. -lookup_promoted :: RdrName -> RnM (Maybe Name) -lookup_promoted rdr_name - | Just promoted_rdr <- promoteRdrName rdr_name - = lookupOccRn_maybe promoted_rdr - | 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] -~~~~~~~~~~~~~~~ -When the user writes: - data Nat = Zero | Succ Nat - foo :: f Zero -> Int - -'Zero' in the type signature of 'foo' is parsed as: - HsTyVar ("Zero", TcClsName) - -When the renamer hits this occurrence of 'Zero' it's going to realise -that it's not in scope. But because it is renaming a type, it knows -that 'Zero' might be a promoted data constructor, so it will demote -its namespace to DataName and do a second lookup. - -The final result (after the renamer) will be: - HsTyVar ("Zero", DataName) - -Note [Promotion] -~~~~~~~~~~~~~~~ -When the user mentions a type constructor or a type variable in a -term-level context, then we report that a value identifier was expected -instead of a type-level one. That makes error messages more precise. -Previously, such errors contained only the info that a given value was out of scope (#18740). -We promote the namespace of RdrName and look up after that -(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’ - In the expression: id Int - In an equation for ‘x’: x = id Int - -when the user writes the following declaration - - x = id Int --} - -lookupOccRnX_maybe :: (RdrName -> RnM (Maybe r)) -> (Name -> r) -> RdrName - -> RnM (Maybe r) -lookupOccRnX_maybe globalLookup wrapper rdr_name - = runMaybeT . msum . map MaybeT $ - [ fmap wrapper <$> lookupLocalOccRn_maybe rdr_name - , globalLookup rdr_name ] - --- Used outside this module only by TH name reification (lookupName, lookupThName_maybe) -lookupOccRn_maybe :: RdrName -> RnM (Maybe Name) -lookupOccRn_maybe = lookupOccRnX_maybe lookupGlobalOccRn_maybe id - --- | Look up a 'RdrName' used as a variable in an expression. --- --- This may be a local variable, global variable, or one or more record selector --- functions. It will not return record fields created with the --- @NoFieldSelectors@ extension (see Note [NoFieldSelectors]). --- --- If the name is not in scope at the term level, but its promoted equivalent is --- in scope at the type level, the lookup will succeed (so that the type-checker --- can report a more informative error later). See Note [Promotion]. --- -lookupExprOccRn :: RdrName -> RnM (Maybe GreName) -lookupExprOccRn rdr_name - = do { mb_name <- lookupOccRnX_maybe global_lookup NormalGreName rdr_name - ; case mb_name of - Nothing -> fmap @Maybe NormalGreName <$> lookup_promoted rdr_name - -- See Note [Promotion]. - -- We try looking up the name as a - -- type constructor or type variable, if - -- we failed to look up the name at the term level. - p -> return p } - - where - global_lookup :: RdrName -> RnM (Maybe GreName) - global_lookup rdr_name = - do { mb_name <- lookupGlobalOccRn_overloaded NoDuplicateRecordFields WantNormal rdr_name - ; case mb_name of - Just (UnambiguousGre name) -> return (Just name) - Just _ -> panic "GHC.Rename.Env.global_lookup: The impossible happened!" - Nothing -> return Nothing - } - -lookupGlobalOccRn_maybe :: RdrName -> RnM (Maybe Name) --- Looks up a RdrName occurrence in the top-level --- environment, including using lookupQualifiedNameGHCi --- for the GHCi case, but first tries to find an Exact or Orig name. --- No filter function; does not report an error on failure --- See Note [Errors in lookup functions] --- Uses addUsedRdrName to record use and deprecations --- --- Used directly only by getLocalNonValBinders (new_assoc). -lookupGlobalOccRn_maybe rdr_name = - lookupExactOrOrig_maybe rdr_name id (lookupGlobalOccRn_base WantNormal 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' WantNormal - -lookupGlobalOccRn' :: FieldsOrSelectors -> RdrName -> RnM Name -lookupGlobalOccRn' fos rdr_name = - lookupExactOrOrig rdr_name id $ do - mn <- lookupGlobalOccRn_base fos rdr_name - case mn of - Just n -> return n - Nothing -> do { traceRn "lookupGlobalOccRn" (ppr rdr_name) - ; unboundName (LF which_suggest WL_Global) rdr_name } - where which_suggest = case fos of - WantNormal -> WL_Anything - WantBoth -> WL_RecField - WantField -> WL_RecField - --- Looks up a RdrName occurrence in the GlobalRdrEnv and with --- lookupQualifiedNameGHCi. Does not try to find an Exact or Orig name first. --- lookupQualifiedNameGHCi here is used when we're in GHCi and a name like --- 'Data.Map.elems' is typed, even if you didn't import Data.Map -lookupGlobalOccRn_base :: FieldsOrSelectors -> RdrName -> RnM (Maybe Name) -lookupGlobalOccRn_base fos rdr_name = - runMaybeT . msum . map MaybeT $ - [ fmap greMangledName <$> lookupGreRn_maybe fos rdr_name - , fmap greNameMangledName <$> lookupOneQualifiedNameGHCi fos rdr_name ] - -- This test is not expensive, - -- and only happens for failed lookups - -lookupInfoOccRn :: RdrName -> RnM [Name] --- lookupInfoOccRn is intended for use in GHCi's ":info" command --- It finds all the GREs that RdrName could mean, not complaining --- about ambiguity, but rather returning them all --- C.f. #9881 --- lookupInfoOccRn is also used in situations where we check for --- at least one definition of the RdrName, not complaining about --- multiple definitions. (See #17832) -lookupInfoOccRn rdr_name = - lookupExactOrOrig rdr_name (:[]) $ - do { rdr_env <- getGlobalRdrEnv - ; let ns = map greMangledName (lookupGRE_RdrName' rdr_name rdr_env) - ; qual_ns <- map greNameMangledName <$> lookupQualifiedNameGHCi WantBoth rdr_name - ; return (ns ++ (qual_ns `minusList` ns)) } - --- | Like 'lookupOccRn_maybe', but with a more informative result if --- the 'RdrName' happens to be a record selector: --- --- * Nothing -> name not in scope (no error reported) --- * Just (UnambiguousGre x) -> name uniquely refers to x, --- or there is a name clash (reported) --- * Just AmbiguousFields -> name refers to two or more record fields --- (no error reported) --- --- See Note [ Unbound vs Ambiguous Names ]. -lookupGlobalOccRn_overloaded :: DuplicateRecordFields -> FieldsOrSelectors -> RdrName - -> RnM (Maybe AmbiguousResult) -lookupGlobalOccRn_overloaded dup_fields_ok fos rdr_name = - lookupExactOrOrig_maybe rdr_name (fmap (UnambiguousGre . NormalGreName)) $ - do { res <- lookupGreRn_helper fos rdr_name - ; case res of - GreNotFound -> fmap UnambiguousGre <$> lookupOneQualifiedNameGHCi fos rdr_name - OneNameMatch gre -> return $ Just (UnambiguousGre (gre_name gre)) - MultipleNames gres - | all isRecFldGRE gres - , dup_fields_ok == DuplicateRecordFields -> return $ Just AmbiguousFields - | otherwise -> do - addNameClashErrRn rdr_name gres - return (Just (UnambiguousGre (gre_name (NE.head gres)))) } - - --- | Result of looking up an occurrence that might be an ambiguous field. -data AmbiguousResult - = UnambiguousGre GreName - -- ^ Occurrence picked out a single name, which may or may not belong to a - -- field (or might be unbound, if an error has been reported already, per - -- Note [ Unbound vs Ambiguous Names ]). - | AmbiguousFields - -- ^ Occurrence picked out two or more fields, and no non-fields. For now - -- this is allowed by DuplicateRecordFields in certain circumstances, as the - -- type-checker may be able to disambiguate later. - - -{- -Note [NoFieldSelectors] -~~~~~~~~~~~~~~~~~~~~~~~ -The NoFieldSelectors extension allows record fields to be defined without -bringing the corresponding selector functions into scope. However, such fields -may still be used in contexts such as record construction, pattern matching or -update. This requires us to distinguish contexts in which selectors are required -from those in which any field may be used. For example: - - {-# LANGUAGE NoFieldSelectors #-} - module M (T(foo), foo) where -- T(foo) refers to the field, - -- unadorned foo to the value binding - data T = MkT { foo :: Int } - foo = () - - bar = foo -- refers to the value binding, field ignored - - module N where - import M (T(..)) - baz = MkT { foo = 3 } -- refers to the field - oops = foo -- an error: the field is in scope but the value binding is not - -Each 'FieldLabel' indicates (in the 'flHasFieldSelector' field) whether the -FieldSelectors extension was enabled in the defining module. This allows them -to be filtered out by 'filterFieldGREs'. - -Even when NoFieldSelectors is in use, we still generate selector functions -internally. For example, the expression - getField @"foo" t -or (with dot-notation) - t.foo -extracts the `foo` field of t::T, and hence needs the selector function -(see Note [HasField instances] in GHC.Tc.Instance.Class). In order to avoid -name clashes with normal bindings reusing the names, selector names for such -fields are mangled just as for DuplicateRecordFields (see Note [FieldLabel] in -GHC.Types.FieldLabel). - - -In many of the name lookup functions in this module we pass a FieldsOrSelectors -value, indicating what we are looking for: - - * WantNormal: fields are in scope only if they have an accompanying selector - function, e.g. we are looking up a variable in an expression - (lookupExprOccRn). - - * WantBoth: any name or field will do, regardless of whether the selector - function is available, e.g. record updates (lookupRecFieldOcc_update) with - NoDisambiguateRecordFields. - - * WantField: any field will do, regardless of whether the selector function is - available, but ignoring any non-field names, e.g. record updates - (lookupRecFieldOcc_update) with DisambiguateRecordFields. - ------------------------------------------------------------------------------------ - Context FieldsOrSelectors ------------------------------------------------------------------------------------ - Record construction/pattern match WantBoth if NoDisambiguateRecordFields - e.g. MkT { foo = 3 } (DisambiguateRecordFields is separate) - - Record update WantBoth if NoDisambiguateRecordFields - e.g. e { foo = 3 } WantField if DisambiguateRecordFields - - :info in GHCi WantBoth - - Variable occurrence in expression WantNormal - Type variable, data constructor - Pretty much everything else ------------------------------------------------------------------------------------ --} - --- | When looking up GREs, we may or may not want to include fields that were --- defined in modules with @NoFieldSelectors@ enabled. See Note --- [NoFieldSelectors]. -data FieldsOrSelectors - = WantNormal -- ^ Include normal names, and fields with selectors, but - -- ignore fields without selectors. - | WantBoth -- ^ Include normal names and all fields (regardless of whether - -- they have selectors). - | WantField -- ^ Include only fields, with or without selectors, ignoring - -- any non-fields in scope. - deriving Eq - -filterFieldGREs :: FieldsOrSelectors -> [GlobalRdrElt] -> [GlobalRdrElt] -filterFieldGREs fos = filter (allowGreName fos . gre_name) - -allowGreName :: FieldsOrSelectors -> GreName -> Bool -allowGreName WantBoth _ = True -allowGreName WantNormal (FieldGreName fl) = flHasFieldSelector fl == FieldSelectors -allowGreName WantNormal (NormalGreName _) = True -allowGreName WantField (FieldGreName _) = True -allowGreName WantField (NormalGreName _) = False - - --------------------------------------------------- --- Lookup in the Global RdrEnv of the module --------------------------------------------------- - -data GreLookupResult = GreNotFound - | OneNameMatch GlobalRdrElt - | MultipleNames (NE.NonEmpty GlobalRdrElt) - -lookupGreRn_maybe :: FieldsOrSelectors -> RdrName -> RnM (Maybe GlobalRdrElt) --- Look up the RdrName in the GlobalRdrEnv --- Exactly one binding: records it as "used", return (Just gre) --- No bindings: return Nothing --- Many bindings: report "ambiguous", return an arbitrary (Just gre) --- Uses addUsedRdrName to record use and deprecations -lookupGreRn_maybe fos rdr_name - = do - res <- lookupGreRn_helper fos rdr_name - case res of - OneNameMatch gre -> return $ Just gre - MultipleNames gres -> do - traceRn "lookupGreRn_maybe:NameClash" (ppr gres) - addNameClashErrRn rdr_name gres - return $ Just (NE.head gres) - GreNotFound -> return Nothing - -{- - -Note [ Unbound vs Ambiguous Names ] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -lookupGreRn_maybe deals with failures in two different ways. If a name -is unbound then we return a `Nothing` but if the name is ambiguous -then we raise an error and return a dummy name. - -The reason for this is that when we call `lookupGreRn_maybe` we are -speculatively looking for whatever we are looking up. If we don't find it, -then we might have been looking for the wrong thing and can keep trying. -On the other hand, if we find a clash then there is no way to recover as -we found the thing we were looking for but can no longer resolve which -the correct one is. - -One example of this is in `lookupTypeOccRn` which first looks in the type -constructor namespace before looking in the data constructor namespace to -deal with `DataKinds`. - -There is however, as always, one exception to this scheme. If we find -an ambiguous occurrence of a record selector and DuplicateRecordFields -is enabled then we defer the selection until the typechecker. - --} - - - - --- Internal Function -lookupGreRn_helper :: FieldsOrSelectors -> RdrName -> RnM GreLookupResult -lookupGreRn_helper fos rdr_name - = do { env <- getGlobalRdrEnv - ; case filterFieldGREs fos (lookupGRE_RdrName' rdr_name env) of - [] -> return GreNotFound - [gre] -> do { addUsedGRE True gre - ; return (OneNameMatch gre) } - -- Don't record usage for ambiguous names - -- until we know which is meant - (gre:gres) -> return (MultipleNames (gre NE.:| gres)) } - -lookupGreAvailRn :: RdrName -> RnM (Name, AvailInfo) --- 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 - = do - mb_gre <- lookupGreRn_helper WantNormal rdr_name - case mb_gre of - GreNotFound -> - do - traceRn "lookupGreAvailRn" (ppr rdr_name) - name <- unboundName (LF WL_Anything WL_Global) rdr_name - return (name, avail name) - MultipleNames gres -> - do - addNameClashErrRn rdr_name gres - let unbound_name = mkUnboundNameRdr rdr_name - return (unbound_name, avail unbound_name) - -- Returning an unbound name here prevents an error - -- cascade - OneNameMatch gre -> - return (greMangledName gre, availFromGRE gre) - - -{- -********************************************************* -* * - Deprecations -* * -********************************************************* - -Note [Handling of deprecations] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -* We report deprecations at each *occurrence* of the deprecated thing - (see #5867) - -* 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. - -* 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' --} - -addUsedDataCons :: GlobalRdrEnv -> TyCon -> RnM () --- Remember use of in-scope data constructors (#7969) -addUsedDataCons rdr_env tycon - = addUsedGREs [ gre - | dc <- tyConDataCons tycon - , Just gre <- [lookupGRE_Name rdr_env (dataConName dc)] ] - -addUsedGRE :: Bool -> GlobalRdrElt -> RnM () --- Called for both local and imported things --- Add usage *and* warn if deprecated -addUsedGRE warn_if_deprec gre - = do { when warn_if_deprec (warnIfDeprecated gre) - ; unless (isLocalGRE gre) $ - do { env <- getGblEnv - ; traceRn "addUsedGRE" (ppr gre) - ; updMutVar (tcg_used_gres env) (gre :) } } - -addUsedGREs :: [GlobalRdrElt] -> RnM () --- Record uses of any *imported* GREs --- Used for recording used sub-bndrs --- NB: no call to warnIfDeprecated; see Note [Handling of deprecations] -addUsedGREs gres - | null imp_gres = return () - | otherwise = do { env <- getGblEnv - ; traceRn "addUsedGREs" (ppr imp_gres) - ; updMutVar (tcg_used_gres env) (imp_gres ++) } - where - imp_gres = filterOut isLocalGRE gres - -warnIfDeprecated :: GlobalRdrElt -> RnM () -warnIfDeprecated gre@(GRE { gre_imp = iss }) - | Just imp_spec <- headMaybe iss - = do { dflags <- getDynFlags - ; this_mod <- getModule - ; when (wopt Opt_WarnWarningsDeprecations dflags && - not (nameIsLocalOrFrom this_mod name)) $ - -- See Note [Handling of deprecations] - do { iface <- loadInterfaceForName doc name - ; case lookupImpDeprec 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 = definedMod - } - Nothing -> return () } } - | otherwise - = return () - where - occ = greOccName gre - name = greMangledName gre - definedMod = moduleName $ assertPpr (isExternalName name) (ppr name) (nameModule name) - doc = text "The name" <+> quotes (ppr occ) <+> text "is mentioned explicitly" - -lookupImpDeprec :: ModIface -> GlobalRdrElt -> Maybe (WarningTxt GhcRn) -lookupImpDeprec iface gre - = mi_warn_fn (mi_final_exts iface) (greOccName gre) `mplus` -- Bleat if the thing, - case gre_par gre of -- or its parent, is warn'd - ParentIs p -> mi_warn_fn (mi_final_exts iface) (nameOccName p) - NoParent -> Nothing - -{- -Note [Used names with interface not loaded] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -It's (just) possible to find a used -Name whose interface hasn't been loaded: - -a) It might be a WiredInName; in that case we may not load - its interface (although we could). - -b) It might be GHC.Real.fromRational, or GHC.Num.fromInteger - These are seen as "used" by the renamer (if -XRebindableSyntax) - is on), but the typechecker may discard their uses - if in fact the in-scope fromRational is GHC.Read.fromRational, - (see tcPat.tcOverloadedLit), and the typechecker sees that the type - is fixed, say, to GHC.Base.Float (see Inst.lookupSimpleInst). - In that obscure case it won't force the interface in. - -In both cases we simply don't permit deprecations; -this is, after all, wired-in stuff. - - -********************************************************* -* * - GHCi support -* * -********************************************************* - -A qualified name on the command line can refer to any module at -all: we try to load the interface if we don't already have it, just -as if there was an "import qualified M" declaration for every -module. - -For example, writing `Data.List.sort` will load the interface file for -`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" -which is what loadSrcInterface does. - -It is enabled by default and disabled by the flag -`-fno-implicit-import-qualified`. - -Note [Safe Haskell and GHCi] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We DON'T do this Safe Haskell as we need to check imports. We can -and should instead check the qualified import but at the moment -this requires some refactoring so leave as a TODO - -Note [DuplicateRecordFields and -fimplicit-import-qualified] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When DuplicateRecordFields is used, a single module can export the same OccName -multiple times, for example: - - module M where - data S = MkS { foo :: Int } - data T = MkT { foo :: Int } - -Now if we refer to M.foo via -fimplicit-import-qualified, we need to report an -ambiguity error. - --} - - --- | Like 'lookupQualifiedNameGHCi' but returning at most one name, reporting an --- ambiguity error if there are more than one. -lookupOneQualifiedNameGHCi :: FieldsOrSelectors -> RdrName -> RnM (Maybe GreName) -lookupOneQualifiedNameGHCi fos rdr_name = do - gnames <- lookupQualifiedNameGHCi fos rdr_name - case gnames of - [] -> return Nothing - [gname] -> return (Just gname) - (gname:gnames') -> do addNameClashErrRn rdr_name (toGRE gname NE.:| map toGRE gnames') - return (Just (NormalGreName (mkUnboundNameRdr rdr_name))) - where - -- Fake a GRE so we can report a sensible name clash error if - -- -fimplicit-import-qualified is used with a module that exports the same - -- field name multiple times (see - -- Note [DuplicateRecordFields and -fimplicit-import-qualified]). - toGRE gname = GRE { gre_name = gname, gre_par = NoParent, gre_lcl = False, gre_imp = unitBag is } - is = ImpSpec { is_decl = ImpDeclSpec { is_mod = mod, is_as = mod, is_qual = True, is_dloc = noSrcSpan } - , is_item = ImpAll } - -- If -fimplicit-import-qualified succeeded, the name must be qualified. - (mod, _) = fromMaybe (pprPanic "lookupOneQualifiedNameGHCi" (ppr rdr_name)) (isQual_maybe rdr_name) - - --- | Look up *all* the names to which the 'RdrName' may refer in GHCi (using --- @-fimplicit-import-qualified@). This will normally be zero or one, but may --- be more in the presence of @DuplicateRecordFields@. -lookupQualifiedNameGHCi :: FieldsOrSelectors -> RdrName -> RnM [GreName] -lookupQualifiedNameGHCi fos rdr_name - = -- We want to behave as we would for a source file import here, - -- and respect hiddenness of modules/packages, hence loadSrcInterface. - do { dflags <- getDynFlags - ; is_ghci <- getIsGHCi - ; go_for_it dflags is_ghci } - - where - go_for_it dflags is_ghci - | Just (mod,occ) <- isQual_maybe rdr_name - , is_ghci - , gopt Opt_ImplicitImportQualified dflags -- Enables this GHCi behaviour - , not (safeDirectImpsReq dflags) -- See Note [Safe Haskell and GHCi] - = do { res <- loadSrcInterface_maybe doc mod NotBoot NoPkgQual - ; case res of - Succeeded iface - -> return [ gname - | avail <- mi_exports iface - , gname <- availGreNames avail - , occName gname == occ - -- Include a field if it has a selector or we are looking for all fields; - -- see Note [NoFieldSelectors]. - , allowGreName fos gname - ] - - _ -> -- Either we couldn't load the interface, or - -- we could but we didn't find the name in it - do { traceRn "lookupQualifiedNameGHCi" (ppr rdr_name) - ; return [] } } - - | otherwise - = do { traceRn "lookupQualifiedNameGHCi: off" (ppr rdr_name) - ; return [] } - - doc = text "Need to find" <+> ppr rdr_name - -{- -Note [Looking up signature names] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -lookupSigOccRn is used for type signatures and pragmas -Is this valid? - module A - import M( f ) - f :: Int -> Int - f x = x -It's clear that the 'f' in the signature must refer to A.f -The Haskell98 report does not stipulate this, but it will! -So we must treat the 'f' in the signature in the same way -as the binding occurrence of 'f', using lookupBndrRn - -However, consider this case: - import M( f ) - f :: Int -> Int - g x = x -We don't want to say 'f' is out of scope; instead, we want to -return the imported 'f', so that later on the renamer will -correctly report "misplaced type sig". - -Note [Signatures for top level things] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -data HsSigCtxt = ... | TopSigCtxt NameSet | .... - -* The NameSet says what is bound in this group of bindings. - We can't use isLocalGRE from the GlobalRdrEnv, because of this: - f x = x - $( ...some TH splice... ) - f :: Int -> Int - When we encounter the signature for 'f', the binding for 'f' - will be in the GlobalRdrEnv, and will be a LocalDef. Yet the - signature is mis-placed - -* For type signatures the NameSet should be the names bound by the - value bindings; for fixity declarations, the NameSet should also - include class sigs and record selectors - - infix 3 `f` -- Yes, ok - f :: C a => a -> a -- No, not ok - class C a where - f :: a -> a --} - -data HsSigCtxt - = TopSigCtxt NameSet -- At top level, binding these names - -- 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 - | 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 - -instance Outputable HsSigCtxt where - ppr (TopSigCtxt ns) = text "TopSigCtxt" <+> ppr ns - ppr (LocalBindCtxt ns) = text "LocalBindCtxt" <+> ppr ns - ppr (ClsDeclCtxt n) = text "ClsDeclCtxt" <+> ppr n - ppr (InstDeclCtxt ns) = text "InstDeclCtxt" <+> ppr ns - ppr (HsBootCtxt ns) = text "HsBootCtxt" <+> ppr ns - ppr (RoleAnnotCtxt ns) = text "RoleAnnotCtxt" <+> ppr ns - -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 = lookupSigCtxtOccRnN ctxt (hsSigDoc sig) - - --- | Lookup a name in relation to the names in a 'HsSigCtxt' -lookupSigCtxtOccRnN :: HsSigCtxt - -> SDoc -- ^ description of thing we're looking up, - -- like "type family" - -> LocatedN RdrName -> RnM (LocatedN Name) -lookupSigCtxtOccRnN ctxt what - = wrapLocMA $ \ rdr_name -> - do { mb_name <- lookupBindGroupOcc ctxt what rdr_name - ; case mb_name of - Left err -> do { addErr (mkTcRnNotInScope rdr_name err) - ; return (mkUnboundNameRdr rdr_name) } - Right name -> return name } - --- | Lookup a name in relation to the names in a 'HsSigCtxt' -lookupSigCtxtOccRn :: HsSigCtxt - -> SDoc -- ^ description of thing we're looking up, - -- like "type family" - -> LocatedA RdrName -> RnM (LocatedA Name) -lookupSigCtxtOccRn ctxt what - = wrapLocMA $ \ rdr_name -> - do { mb_name <- lookupBindGroupOcc ctxt what rdr_name - ; case mb_name of - Left err -> do { addErr (mkTcRnNotInScope rdr_name err) - ; return (mkUnboundNameRdr rdr_name) } - Right name -> return name } - -lookupBindGroupOcc :: HsSigCtxt - -> SDoc - -> RdrName -> RnM (Either NotInScopeError Name) --- Looks up the RdrName, expecting it to resolve to one of the --- bound names passed in. If not, return an appropriate error message --- --- See Note [Looking up signature names] -lookupBindGroupOcc ctxt what rdr_name - | Just n <- isExact_maybe rdr_name - = lookupExactOcc_either n -- allow for the possibility of missing Exacts; - -- see Note [dataTcOccs and Exact Names] - -- Maybe we should check the side conditions - -- but it's a pain, and Exact things only show - -- up when you know what you are doing - - | Just (rdr_mod, rdr_occ) <- isOrig_maybe rdr_name - = do { n' <- lookupOrig rdr_mod rdr_occ - ; return (Right n') } - - | otherwise - = case ctxt of - HsBootCtxt ns -> lookup_top (`elemNameSet` ns) - TopSigCtxt ns -> lookup_top (`elemNameSet` ns) - RoleAnnotCtxt ns -> lookup_top (`elemNameSet` ns) - LocalBindCtxt ns -> lookup_group ns - ClsDeclCtxt cls -> lookup_cls_op cls - InstDeclCtxt ns -> if uniqSetAny isUnboundName ns -- #16610 - then return (Right $ mkUnboundNameRdr rdr_name) - else lookup_top (`elemNameSet` ns) - where - lookup_cls_op cls - = lookupSubBndrOcc True cls doc rdr_name - where - doc = text "method of class" <+> quotes (ppr cls) - - lookup_top keep_me - = do { env <- getGlobalRdrEnv - ; dflags <- getDynFlags - ; let all_gres = lookupGlobalRdrEnv env (rdrNameOcc rdr_name) - names_in_scope = -- If rdr_name lacks a binding, only - -- recommend alternatives from related - -- namespaces. See #17593. - filter (\n -> nameSpacesRelated dflags WL_Anything - (rdrNameSpace rdr_name) - (nameNameSpace n)) - $ map greMangledName - $ filter isLocalGRE - $ globalRdrEnvElts env - candidates_msg = candidates names_in_scope - ; case filter (keep_me . greMangledName) all_gres of - [] | null all_gres -> bale_out_with candidates_msg - | otherwise -> bale_out_with local_msg - (gre:_) -> return (Right (greMangledName gre)) } - - lookup_group bound_names -- Look in the local envt (not top level) - = do { mname <- lookupLocalOccRn_maybe rdr_name - ; env <- getLocalRdrEnv - ; let candidates_msg = candidates $ localRdrEnvElts env - ; case mname of - Just n - | n `elemNameSet` bound_names -> return (Right n) - | otherwise -> bale_out_with local_msg - Nothing -> bale_out_with candidates_msg } - - bale_out_with hints = return (Left $ MissingBinding what hints) - - local_msg = [SuggestMoveToDeclarationSite what rdr_name] - - -- Identify all similar names and produce a message listing them - candidates :: [Name] -> [GhcHint] - candidates names_in_scope - | (nm : nms) <- map SimilarName similar_names - = [SuggestSimilarNames rdr_name (nm NE.:| nms)] - | otherwise - = [] - where - similar_names - = fuzzyLookup (unpackFS $ occNameFS $ rdrNameOcc rdr_name) - $ map (\x -> ((unpackFS $ occNameFS $ nameOccName x), x)) - names_in_scope - - ---------------- -lookupLocalTcNames :: HsSigCtxt -> SDoc -> 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_name - = do { mb_gres <- mapM lookup (dataTcOccs rdr_name) - ; let (errs, names) = partitionEithers mb_gres - ; when (null names) $ - addErr (head errs) -- Bleat about one only - ; return names } - where - lookup rdr = do { this_mod <- getModule - ; nameEither <- lookupBindGroupOcc ctxt what rdr - ; return (guard_builtin_syntax this_mod rdr nameEither) } - - -- Guard against the built-in syntax (ex: `infixl 6 :`), see #15233 - guard_builtin_syntax this_mod rdr (Right name) - | Just _ <- isBuiltInOcc_maybe (occName rdr) - , this_mod /= nameModule name - = Left $ TcRnIllegalBuiltinSyntax what rdr - | otherwise - = Right (rdr, name) - guard_builtin_syntax _ _ (Left err) - = Left $ mkTcRnNotInScope rdr_name err - -dataTcOccs :: RdrName -> [RdrName] --- Return both the given name and the same name promoted to the TcClsName --- namespace. This is useful when we aren't sure which we are looking at. --- See also Note [dataTcOccs and Exact Names] -dataTcOccs rdr_name - | isDataOcc occ || isVarOcc occ - = [rdr_name, rdr_name_tc] - | otherwise - = [rdr_name] - where - occ = rdrNameOcc rdr_name - rdr_name_tc = setRdrNameSpace rdr_name tcName - -{- -Note [dataTcOccs and Exact Names] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Exact RdrNames can occur in code generated by Template Haskell, and generally -those references are, well, exact. However, the TH `Name` type isn't expressive -enough to always track the correct namespace information, so we sometimes get -the right Unique but wrong namespace. Thus, we still have to do the double-lookup -for Exact RdrNames. - -There is also an awkward situation for built-in syntax. Example in GHCi - :info [] -This parses as the Exact RdrName for nilDataCon, but we also want -the list type constructor. - -Note that setRdrNameSpace on an Exact name requires the Name to be External, -which it always is for built in syntax. --} - - - -{- -************************************************************************ -* * - Rebindable names - Dealing with rebindable syntax is driven by the - Opt_RebindableSyntax dynamic flag. - - In "deriving" code we don't want to use rebindable syntax - so we switch off the flag locally - -* * -************************************************************************ - -Haskell 98 says that when you say "3" you get the "fromInteger" from the -Standard Prelude, regardless of what is in scope. However, to experiment -with having a language that is less coupled to the standard prelude, we're -trying a non-standard extension that instead gives you whatever "Prelude.fromInteger" -happens to be in scope. Then you can - import Prelude () - import MyPrelude as Prelude -to get the desired effect. - -At the moment this just happens for - * fromInteger, fromRational on literals (in expressions and patterns) - * negate (in expressions) - * minus (arising from n+k patterns) - * "do" notation - -We store the relevant Name in the HsSyn tree, in - * HsIntegral/HsFractional/HsIsString - * NegApp - * NPlusKPat - * HsDo -respectively. Initially, we just store the "standard" name (GHC.Builtin.Names.fromIntegralName, -fromRationalName etc), but the renamer changes this to the appropriate user -name if Opt_NoImplicitPrelude is on. That is what lookupSyntax does. - -We treat the original (standard) names as free-vars too, because the type checker -checks the type of the user thing against the type of the standard thing. --} - -lookupIfThenElse :: RnM (Maybe Name) --- Looks up "ifThenElse" if rebindable syntax is on -lookupIfThenElse - = do { rebindable_on <- xoptM LangExt.RebindableSyntax - ; if not rebindable_on - then return Nothing - else do { ite <- lookupOccRnNone (mkVarUnqual (fsLit "ifThenElse")) - ; return (Just ite) } } - -lookupSyntaxName :: Name -- ^ The standard name - -> RnM (Name, FreeVars) -- ^ Possibly a non-standard name --- Lookup a Name that may be subject to Rebindable Syntax (RS). --- --- - When RS is off, just return the supplied (standard) Name --- --- - When RS is on, look up the OccName of the supplied Name; return --- what we find, or the supplied Name if there is nothing in scope -lookupSyntaxName std_name - = do { rebind <- xoptM LangExt.RebindableSyntax - ; if not rebind - then return (std_name, emptyFVs) - else do { nm <- lookupOccRnNone (mkRdrUnqual (nameOccName std_name)) - ; return (nm, unitFV nm) } } - -lookupSyntaxExpr :: Name -- ^ The standard name - -> RnM (HsExpr GhcRn, FreeVars) -- ^ Possibly a non-standard name -lookupSyntaxExpr std_name - = do { (name, fvs) <- lookupSyntaxName std_name - ; return (nl_HsVar 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) } - -lookupSyntaxNames :: [Name] -- Standard names - -> RnM ([HsExpr GhcRn], FreeVars) -- See comments with HsExpr.ReboundNames - -- this works with CmdTop, which wants HsExprs, not SyntaxExprs -lookupSyntaxNames std_names - = do { rebindable_on <- xoptM LangExt.RebindableSyntax - ; if not rebindable_on then - return (map (HsVar noExtField . noLocA) std_names, emptyFVs) - else - do { usr_names <- - mapM (lookupOccRnNone . mkRdrUnqual . nameOccName) std_names - ; return (map (HsVar noExtField . noLocA) usr_names, mkFVs usr_names) } } - - -{- -Note [QualifiedDo] -~~~~~~~~~~~~~~~~~~ -QualifiedDo is implemented using the same placeholders for operation names in -the AST that were devised for RebindableSyntax. Whenever the renamer checks -which names to use for do syntax, it first checks if the do block is qualified -(e.g. M.do { stmts }), in which case it searches for qualified names. If the -qualified names are not in scope, an error is produced. If the do block is not -qualified, the renamer does the usual search of the names which considers -whether RebindableSyntax is enabled or not. Dealing with QualifiedDo is driven -by the Opt_QualifiedDo dynamic flag. --} - --- 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 ctxt std_name - = first mkSyntaxExpr <$> lookupQualifiedDoExpr ctxt std_name - -lookupNameWithQualifier :: Name -> ModuleName -> RnM (Name, FreeVars) -lookupNameWithQualifier std_name modName - = do { qname <- lookupOccRnNone (mkRdrQual modName (nameOccName std_name)) - ; return (qname, unitFV qname) } - --- See Note [QualifiedDo]. -lookupQualifiedDoName - :: HsStmtContext p - -> Name - -> RnM (Name, FreeVars) -lookupQualifiedDoName ctxt std_name - = case qualifiedDoModuleName_maybe ctxt of - Nothing -> lookupSyntaxName std_name - Just modName -> lookupNameWithQualifier std_name modName - - --- Error messages - -badOrigBinding :: RdrName -> TcRnMessage -badOrigBinding name - | Just _ <- isBuiltInOcc_maybe occ = TcRnIllegalBindingOfBuiltIn occ - | otherwise = TcRnNameByTemplateHaskellQuote name - where - occ = rdrNameOcc $ filterCTuple name +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TupleSections #-} + +{- +(c) The GRASP/AQUA Project, Glasgow University, 1992-2006 + +GHC.Rename.Env contains functions which convert RdrNames into Names. + +-} + +module GHC.Rename.Env ( + newTopSrcBinder, + + lookupLocatedTopBndrRnN, lookupTopBndrRn, + + lookupLocatedOccRn, lookupLocatedOccRnConstr, lookupLocatedOccRnRecField, + lookupLocatedOccRnNone, + lookupOccRn, lookupOccRn_maybe, lookupSameOccRn_maybe, + lookupLocalOccRn_maybe, lookupInfoOccRn, + lookupLocalOccThLvl_maybe, lookupLocalOccRn, + lookupTypeOccRn, + lookupGlobalOccRn_maybe, + + lookupExprOccRn, + lookupRecFieldOcc, + lookupRecUpdFields, + getFieldUpdLbl, + getUpdFieldLbls, + + ChildLookupResult(..), + lookupSubBndrOcc_helper, + + HsSigCtxt(..), lookupLocalTcNames, lookupSigOccRn, + lookupSigCtxtOccRn, + + lookupInstDeclBndr, lookupFamInstName, + lookupConstructorInfo, lookupConstructorFields, + lookupGREInfo, + + irrefutableConLikeRn, irrefutableConLikeTc, + + lookupGreAvailRn, + + -- Rebindable Syntax + lookupSyntax, lookupSyntaxExpr, lookupSyntaxNames, + lookupSyntaxName, + lookupIfThenElse, + + -- QualifiedDo + lookupQualifiedDo, lookupQualifiedDoName, lookupNameWithQualifier, + + -- Constructing usage information + DeprecationWarnings(..), + addUsedGRE, addUsedGREs, addUsedDataCons, + + dataTcOccs, --TODO: Move this somewhere, into utils? + + ) where + +import GHC.Prelude + +import Language.Haskell.Syntax.Basic (FieldLabelString(..)) + +import GHC.Iface.Load +import GHC.Iface.Env +import GHC.Hs +import GHC.Types.Name.Reader +import GHC.Tc.Errors.Types +import GHC.Tc.Errors.Ppr (pprScopeError) +import GHC.Tc.Utils.Env +import GHC.Tc.Types.LclEnv +import GHC.Tc.Utils.Monad +import GHC.Parser.PostProcess ( setRdrNameSpace ) +import GHC.Builtin.Types +import GHC.Types.Name +import GHC.Types.Name.Set +import GHC.Types.Name.Env +import GHC.Types.Avail +import GHC.Types.Hint +import GHC.Unit.Module +import GHC.Unit.Module.ModIface +import GHC.Core.ConLike +import GHC.Core.DataCon +import GHC.Core.TyCon +import GHC.Builtin.Names( rOOT_MAIN ) +import GHC.Types.Basic ( TopLevelFlag(..), TupleSort(..), tupleSortBoxity ) +import GHC.Types.TyThing ( tyThingGREInfo ) +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.Data.Maybe +import GHC.Driver.Env +import GHC.Driver.Session +import GHC.Data.FastString +import GHC.Data.List.SetOps ( minusList ) +import qualified GHC.LanguageExtensions as LangExt +import GHC.Rename.Unbound +import GHC.Rename.Utils +import GHC.Data.Bag +import GHC.Types.CompleteMatch +import GHC.Types.PkgQual +import GHC.Types.GREInfo + +import Control.Arrow ( first ) +import Control.Monad +import Data.Either ( partitionEithers ) +import Data.Function ( on ) +import Data.List ( find, partition, sortBy ) +import qualified Data.List.NonEmpty as NE +import qualified Data.Semigroup as Semi +import System.IO.Unsafe ( unsafePerformIO ) + +{- +********************************************************* +* * + Source-code binders +* * +********************************************************* + +Note [Signature lazy interface loading] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +GHC's lazy interface loading can be a bit confusing, so this Note is an +empirical description of what happens in one interesting case. When +compiling a signature module against an its implementation, we do NOT +load interface files associated with its names until after the type +checking phase. For example: + + module ASig where + data T + f :: T -> T + +Suppose we compile this with -sig-of "A is ASig": + + module B where + data T = T + f T = T + + module A(module B) where + import B + +During type checking, we'll load A.hi because we need to know what the +RdrEnv for the module is, but we DO NOT load the interface for B.hi! +It's wholly unnecessary: our local definition 'data T' in ASig is all +the information we need to finish type checking. This is contrast to +type checking of ordinary Haskell files, in which we would not have the +local definition "data T" and would need to consult B.hi immediately. +(Also, this situation never occurs for hs-boot files, since you're not +allowed to reexport from another module.) + +After type checking, we then check that the types we provided are +consistent with the backing implementation (in checkHiBootOrHsigIface). +At this point, B.hi is loaded, because we need something to compare +against. + +I discovered this behavior when trying to figure out why type class +instances for Data.Map weren't in the EPS when I was type checking a +test very much like ASig (sigof02dm): the associated interface hadn't +been loaded yet! (The larger issue is a moot point, since an instance +declared in a signature can never be a duplicate.) + +This behavior might change in the future. Consider this +alternate module B: + + module B where + {-# DEPRECATED T, f "Don't use" #-} + data T = T + f T = T + +One might conceivably want to report deprecation warnings when compiling +ASig with -sig-of B, in which case we need to look at B.hi to find the +deprecation warnings during renaming. At the moment, you don't get any +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] in GHC.Rename.Utils +-} + +newTopSrcBinder :: LocatedN RdrName -> RnM Name +newTopSrcBinder (L loc rdr_name) + | Just name <- isExact_maybe rdr_name + = -- This is here to catch + -- (a) Exact-name binders created by Template Haskell + -- (b) The PrelBase defn of (say) [] and similar, for which + -- the parser reads the special syntax and returns an Exact RdrName + -- We are at a binding site for the name, so check first that it + -- the current module is the correct one; otherwise GHC can get + -- very confused indeed. This test rejects code like + -- data T = (,) Int Int + -- unless we are in GHC.Tup + if isExternalName name then + do { this_mod <- getModule + ; unless (this_mod == nameModule name) + (addErrAt (locA loc) (TcRnBindingOfExistingName rdr_name)) + ; return name } + else -- See Note [Binders in Template Haskell] in "GHC.ThToHs" + do { this_mod <- getModule + ; externaliseName this_mod name } + + | Just (rdr_mod, rdr_occ) <- isOrig_maybe rdr_name + = do { this_mod <- getModule + ; unless (rdr_mod == this_mod || rdr_mod == rOOT_MAIN) + (addErrAt (locA loc) (TcRnBindingOfExistingName rdr_name)) + -- When reading External Core we get Orig names as binders, + -- but they should agree with the module gotten from the monad + -- + -- We can get built-in syntax showing up here too, sadly. If you type + -- data T = (,,,) + -- the constructor is parsed as a type, and then GHC.Parser.PostProcess.tyConToDataCon + -- uses setRdrNameSpace to make it into a data constructors. At that point + -- the nice Exact name for the TyCon gets swizzled to an Orig name. + -- Hence the TcRnBindingOfExistingName error message. + -- + + -- MP 2022: I suspect this code path is never called for `rOOT_MAIN` anymore + -- because External Core has been removed but we instead have some similar logic for + -- serialising whole programs into interface files in GHC.IfaceToCore.mk_top_id. + + -- Except for the ":Main.main = ..." definition inserted into + -- the Main module; ugh! + + -- Because of this latter case, we call newGlobalBinder with a module from + -- the RdrName, not from the environment. In principle, it'd be fine to + -- have an arbitrary mixture of external core definitions in a single module, + -- (apart from module-initialisation issues, perhaps). + ; newGlobalBinder rdr_mod rdr_occ (locA loc) } + + | otherwise + = do { when (isQual rdr_name) + (addErrAt (locA loc) (badQualBndrErr rdr_name)) + -- 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 + + ; 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 + ; return (mkInternalName uniq (rdrNameOcc rdr_name) (locA loc)) } + else + do { this_mod <- getModule + ; traceRn "newTopSrcBinder" (ppr this_mod $$ ppr rdr_name $$ ppr (locA loc)) + ; newGlobalBinder this_mod (rdrNameOcc rdr_name) (locA loc) } + } + +{- +********************************************************* +* * + Source code occurrences +* * +********************************************************* + +Looking up a name in the GHC.Rename.Env. + +Note [Type and class operator definitions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We want to reject all of these unless we have -XTypeOperators (#3265) + data a :*: b = ... + class a :*: b where ... + data (:*:) a b = .... + class (:*:) a b where ... +The latter two mean that we are not just looking for a +*syntactically-infix* declaration, but one that uses an operator +OccName. We use OccName.isSymOcc to detect that case, which isn't +terribly efficient, but there seems to be no better way. +-} + +-- Can be made to not be exposed +-- Only used unwrapped in rnAnnProvenance +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: +-- import Foo( f ) +-- infix 9 f -- The 'f' here does not need to be qualified +-- f x = x -- Nor here, of course +-- So we have to filter out the non-local ones. +-- +-- 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 (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 + ; when (isTcOcc occ && isSymOcc occ) + (do { op_ok <- xoptM LangExt.TypeOperators + ; unless op_ok (addErr (TcRnIllegalTypeOperatorDecl rdr_name)) }) + ; env <- getGlobalRdrEnv + ; 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 + } + +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 +-- Note [Errors in lookup functions] +lookupExactOcc_either :: Name -> RnM (Either NotInScopeError GlobalRdrElt) +lookupExactOcc_either name + | Just thing <- wiredInNameTyThing_maybe name + , 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 = mkInfo tupleSort + ; checkTupSize tupArity + ; return $ Right $ mkExactGRE name info } + + | isExternalName name + = do { info <- lookupExternalExactName name + ; return $ Right $ mkExactGRE name info } + + | otherwise + = lookupLocalExactGRE name + +lookupExternalExactName :: Name -> RnM GREInfo +lookupExternalExactName name + = do { thing <- + case wiredInNameTyThing_maybe name of + Just thing -> return thing + _ -> tcLookupGlobal name + ; return $ tyThingGREInfo thing } + +lookupLocalExactGRE :: Name -> RnM (Either NotInScopeError GlobalRdrElt) +lookupLocalExactGRE name + = do { env <- getGlobalRdrEnv + ; let lk = LookupExactName { lookupExactName = name + , lookInAllNameSpaces = True } + -- We want to check for clashes where the same Unique + -- occurs in two different NameSpaces, as per + -- Note [Template Haskell ambiguity]. So we + -- check ALL namespaces, not just the NameSpace of the Name. + -- See test cases T9066, T11809. + ; case lookupGRE env lk of + [gre] -> return (Right gre) + + [] -> -- See Note [Splicing Exact names] + do { lcl_env <- getLocalRdrEnv + ; let gre = mkLocalVanillaGRE NoParent name -- LocalRdrEnv only contains Vanilla things + ; if name `inLocalRdrEnvScope` lcl_env + then return (Right gre) + else + do { th_topnames_var <- fmap tcg_th_topnames getGblEnv + ; th_topnames <- readTcRef th_topnames_var + ; if name `elemNameSet` th_topnames + then return (Right gre) + else return (Left (NoExactName name)) + } + } + + gres -> return (Left (SameName gres)) } + -- Ugh! See Note [Template Haskell ambiguity] } + +----------------------------------------------- +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 = ... +-- ^^^^ called on this +-- Regardless of how many unqualified fmaps are in scope, we want +-- the one that comes from the Functor class. +-- +-- Furthermore, note that we take no account of whether the +-- name is only in scope qualified. I.e. even if method op is +-- in scope as M.op, we still allow plain 'op' on the LHS of +-- an instance decl +-- +-- The "what" parameter says "method" or "associated type", +-- depending on what we are looking up +lookupInstDeclBndr cls what_subordinate rdr + = do { when (isQual rdr) + (addErr (badQualBndrErr rdr)) + -- In an instance decl you aren't allowed + -- to use a qualified name for the method + -- (Although it'd make perfect sense.) + ; mb_name <- lookupSubBndrOcc + NoDeprecationWarnings + -- we don't give deprecated + -- warnings when a deprecated class + -- method is defined. We only warn + -- when it's used + (ParentGRE cls (IAmTyCon ClassFlavour)) what_subordinate rdr + ; case mb_name of + Left err -> do { addErr $ TcRnNotInScope err rdr + ; return (mkUnboundNameRdr rdr) } + Right nm -> return nm } + +----------------------------------------------- +lookupFamInstName :: Maybe Name -> LocatedN RdrName + -> RnM (LocatedN Name) +-- 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 AssociatedTypeOfClass) tc_rdr +lookupFamInstName Nothing tc_rdr -- Family instance; tc_rdr is an *occurrence* + = lookupLocatedOccRn WL_TyCon tc_rdr + +----------------------------------------------- +lookupConstructorFields :: HasDebugCallStack => WithUserRdr Name -> RnM [FieldLabel] +lookupConstructorFields = fmap conInfoFields . lookupConstructorInfo + +-- | Look up the arity and record fields of a constructor. +lookupConstructorInfo :: HasDebugCallStack => WithUserRdr Name -> RnM ConInfo +lookupConstructorInfo qcon@(WithUserRdr _ con_name) + = do { info <- lookupGREInfo_GRE con_name + ; case info of + IAmConLike con_info -> return con_info + UnboundGRE -> return $ ConInfo (ConIsData []) ConHasPositionalArgs + IAmTyCon {} -> failIllegalTyCon WL_ConLike qcon + _ -> pprPanic "lookupConstructorInfo: not a ConLike" $ + vcat [ text "name:" <+> ppr con_name ] + } + +-- In CPS style as `RnM r` is monadic +-- Reports an error if the name is an Exact or Orig and it can't find the name +-- Otherwise if it is not an Exact or Orig, returns k +lookupExactOrOrig :: RdrName -> (GlobalRdrElt -> r) -> RnM r -> RnM r +lookupExactOrOrig rdr_name res k + = do { men <- lookupExactOrOrig_base rdr_name + ; case men of + FoundExactOrOrig gre -> return $ res gre + NotExactOrOrig -> k + ExactOrOrigError e -> + do { addErr $ TcRnNotInScope e rdr_name + ; return $ res (mkUnboundGRERdr rdr_name) } } + +-- Variant of 'lookupExactOrOrig' that does not report an error +-- See Note [Errors in lookup functions] +-- Calls k if the name is neither an Exact nor Orig +lookupExactOrOrig_maybe :: RdrName -> (Maybe GlobalRdrElt -> r) -> RnM r -> RnM r +lookupExactOrOrig_maybe rdr_name res k + = do { men <- lookupExactOrOrig_base rdr_name + ; case men of + FoundExactOrOrig gre -> return (res (Just gre)) + ExactOrOrigError _ -> return (res Nothing) + NotExactOrOrig -> k } + +data ExactOrOrigResult + = FoundExactOrOrig GlobalRdrElt + -- ^ Found an Exact Or Orig Name + | ExactOrOrigError NotInScopeError + -- ^ The RdrName was an Exact + -- or Orig, but there was an + -- error looking up the Name + | NotExactOrOrig + -- ^ The RdrName is neither an Exact nor Orig + +-- Does the actual looking up an Exact or Orig name, see 'ExactOrOrigResult' +lookupExactOrOrig_base :: RdrName -> RnM ExactOrOrigResult +lookupExactOrOrig_base rdr_name + | Just n <- isExact_maybe rdr_name -- This happens in derived code + = cvtEither <$> lookupExactOcc_either n + | Just (rdr_mod, rdr_occ) <- isOrig_maybe rdr_name + = do { nm <- lookupOrig rdr_mod rdr_occ + + ; this_mod <- getModule + ; mb_gre <- + if nameIsLocalOrFrom this_mod nm + then lookupLocalExactGRE nm + else do { info <- lookupExternalExactName nm + ; return $ Right $ mkExactGRE nm info } + ; return $ case mb_gre of + Left err -> ExactOrOrigError err + Right gre -> FoundExactOrOrig gre } + | otherwise = return NotExactOrOrig + where + cvtEither (Left e) = ExactOrOrigError e + cvtEither (Right gre) = FoundExactOrOrig gre + +{- Note [Errors in lookup functions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Many of these lookup functions will attach an error if it can't find the Name it +is trying to lookup. However there are also _maybe and _either variants for many +of these functions. + +These variants should *not* attach any errors, as there are +places where we want to attempt looking up a name, but it's not the end of the +world if we don't find it. + +For example, see lookupThName_maybe: It calls lookupOccRn_maybe multiple +times for varying names in different namespaces. lookupOccRn_maybe should +therefore never attach an error, instead just return a Nothing. + +For these _maybe/_either variant functions then, avoid calling further lookup +functions that can attach errors and instead call their _maybe/_either +counterparts. +-} + +----------------------------------------------- +-- | Look up an occurrence of a field in record construction or pattern +-- matching (but not update). +-- +-- 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 (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 (WithUserRdr _ con) <- mb_con + , isUnboundName con -- Avoid error cascade + = return $ mk_unbound_rec_fld 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 qcon + ; env <- getGlobalRdrEnv + ; let mb_gre = do fl <- find ((== lbl) . flLabel) flds + -- We have the label, now check it is in scope. If + -- there is a qualifier, use pickGREs to check that + -- the qualifier is correct, and return the filtered + -- GRE so we get import usage right (see #17853). + gre <- lookupGRE_FieldLabel env fl + if isQual rdr_name + then listToMaybe $ pickGREs rdr_name [gre] + else return gre + ; traceRn "lookupRecFieldOcc" $ + vcat [ text "mb_con:" <+> ppr mb_con + , text "rdr_name:" <+> ppr rdr_name + , text "flds:" <+> ppr flds + , text "mb_gre:" <+> ppr mb_gre ] + ; mapM_ (addUsedGRE AllDeprecationWarnings) mb_gre + ; return $ flSelector . fieldGRELabel <$> mb_gre } + ; case mb_nm of + { Nothing -> do { addErr (badFieldConErr con lbl) + ; return $ mk_unbound_rec_fld con } + ; Just nm -> return nm } } + + | otherwise -- Can't use the data constructor to disambiguate + = 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. + mk_unbound_rec_fld con = mkUnboundName $ + mkRecFieldOccFS (getOccFS con) (occNameFS occ) + occ = rdrNameOcc rdr_name + + ensure_recfld :: GlobalRdrElt -> Maybe Name + ensure_recfld gre = do { guard (isRecFldGRE gre) + ; return $ greName gre } + +{- Note [DisambiguateRecordFields] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When we are looking up record fields in record construction or pattern +matching, we can take advantage of the data constructor name to +resolve fields that would otherwise be ambiguous (provided the +-XDisambiguateRecordFields flag is on). + +For example, consider: + + data S = MkS { x :: Int } + data T = MkT { x :: Int } + + e = MkS { x = 3 } + +When we are renaming the occurrence of `x` in `e`, instead of looking +`x` up directly (and finding both fields), lookupRecFieldOcc will +search the fields of `MkS` to find the only possible `x` the user can +mean. + +Of course, we still have to check the field is in scope, using +lookupGRE_FieldLabel. The handling of qualified imports is slightly +subtle: the occurrence may be unqualified even if the field is +imported only qualified (but if the occurrence is qualified, the +qualifier must be correct). For example: + + module A where + data S = MkS { x :: Int } + data T = MkT { x :: Int } + + module B where + import qualified A (S(..)) + import A (T(MkT)) + + e1 = MkT { x = 3 } -- x not in scope, so fail + e2 = A.MkS { B.x = 3 } -- module qualifier is wrong, so fail + e3 = A.MkS { x = 3 } -- x in scope (lack of module qualifier permitted) + +In case `e1`, lookupGRE_FieldLabel will return Nothing. In case `e2`, +lookupGRE_FieldLabel will return the GRE for `A.x`, but then the guard +will fail because the field RdrName `B.x` is qualified and pickGREs +rejects the GRE. In case `e3`, lookupGRE_FieldLabel will return the +GRE for `A.x` and the guard will succeed because the field RdrName `x` +is unqualified. + + +Note [DisambiguateRecordFields for updates] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When we are looking up record fields in record update, we can take advantage of +the fact that we know we are looking for a field, even though we do not know the +data constructor name (as in Note [DisambiguateRecordFields]), provided the +-XDisambiguateRecordFields flag is on. + +For example, consider: + + module N where + f = () + + {-# LANGUAGE DisambiguateRecordFields #-} + module M where + import N (f) + data T = MkT { f :: Int } + t = MkT { f = 1 } -- unambiguous because MkT determines which field we mean + u = t { f = 2 } -- unambiguous because we ignore the non-field 'f' + +We filter out non-fields in lookupFieldGREs by using isRecFldGRE, which allows +us to accept the above program. +Of course, if a record update has two fields in scope with the same name, +it is still ambiguous. + +We also look up the non-fields with the same textual name + + 1. to throw an error if the user hasn't enabled DisambiguateRecordFields, + 2. in order to improve the error message when a user mistakenly tries to use + a non-field in a record update: + + f = () + e x = x { f = () } + +Unlike with constructors or pattern-matching, we do not allow the module +qualifier to be omitted from the field names, because we do not have a +data constructor to use to determine the appropriate qualifier. + +This is all done in the function lookupFieldGREs, which is called by +GHC.Rename.Pat.rnHsRecUpdFields, which deals with record updates. + +Note [Record field names and Template Haskell] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider (#12130): + + module Foo where + import M + b = $(funny) + + module M(funny) where + data T = MkT { x :: Int } + funny :: Q Exp + funny = [| MkT { x = 3 } |] + +When we splice, `MkT` is not lexically in scope, so +lookupGRE_FieldLabel will fail. But there is no need for +disambiguation anyway, because `x` is an original name, and +lookupGlobalOccRn will find it. +-} + +-- | Used in export lists to lookup the children. +lookupSubBndrOcc_helper :: Bool + -> DeprecationWarnings + -> ParentGRE -- ^ parent + -> RdrName -- ^ thing we are looking up + -> RnM ChildLookupResult +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 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 (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 + NoOccurrence -> + noMatchingParentErr original_gres + UniqueOccurrence g -> + if must_have_parent + then noMatchingParentErr original_gres + else checkFld g + DisambiguatedOccurrence g -> + checkFld g + AmbiguousOccurrence gres -> + mkNameClashErr gres + where + checkFld :: GlobalRdrElt -> RnM ChildLookupResult + checkFld g = do + addUsedGRE warn_if_deprec g + return $ FoundChild g + + -- Called when we find no matching GREs after disambiguation but + -- there are three situations where this happens. + -- 1. There were none to begin with. + -- 2. None of the matching ones were the parent but + -- a. They were from an overloaded record field so we can report + -- a better error + -- b. The original lookup was actually ambiguous. + -- For example, the case where overloading is off and two + -- record fields are in scope from different record + -- constructors, neither of which is the parent. + noMatchingParentErr :: [GlobalRdrElt] -> RnM ChildLookupResult + noMatchingParentErr original_gres = do + traceRn "npe" (ppr original_gres) + dup_fields_ok <- xoptM LangExt.DuplicateRecordFields + case original_gres of + [] -> return NameNotFound + [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_gre g + [p | x <- gss, ParentIs p <- [greParent x]] + else mkNameClashErr $ g NE.:| gss' + + mkNameClashErr :: NE.NonEmpty GlobalRdrElt -> RnM ChildLookupResult + mkNameClashErr gres = do + addNameClashErrRn rdr_name gres + return (FoundChild (NE.head gres)) + + pick_gres :: [GlobalRdrElt] -> DisambigInfo + 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 + | parentGRE_name parent_gre == cur_parent -> DisambiguatedOccurrence gre + | otherwise -> NoOccurrence + NoParent -> UniqueOccurrence gre + +-- | This domain specific datatype is used to record why we decided it was +-- possible that a GRE could be exported with a parent. +data DisambigInfo + = NoOccurrence + -- ^ The GRE could not be found, or it has the wrong parent. + | UniqueOccurrence GlobalRdrElt + -- ^ The GRE has no parent. It could be a pattern synonym. + | DisambiguatedOccurrence GlobalRdrElt + -- ^ The parent of the GRE is the correct parent. + | AmbiguousOccurrence (NE.NonEmpty GlobalRdrElt) + -- ^ The GRE is ambiguous. + -- + -- For example, two normal identifiers with the same name are in + -- scope. They will both be resolved to "UniqueOccurrence" and the + -- monoid will combine them to this failing case. + +instance Outputable DisambigInfo where + ppr NoOccurrence = text "NoOccurrence" + ppr (UniqueOccurrence gre) = text "UniqueOccurrence:" <+> ppr gre + ppr (DisambiguatedOccurrence gre) = text "DiambiguatedOccurrence:" <+> ppr gre + ppr (AmbiguousOccurrence gres) = text "Ambiguous:" <+> ppr gres + +instance Semi.Semigroup DisambigInfo where + -- These are the key lines: we prefer disambiguated occurrences to other + -- names. + _ <> DisambiguatedOccurrence g' = DisambiguatedOccurrence g' + DisambiguatedOccurrence g' <> _ = DisambiguatedOccurrence g' + + NoOccurrence <> m = m + m <> NoOccurrence = m + UniqueOccurrence g <> UniqueOccurrence g' + = AmbiguousOccurrence $ g NE.:| [g'] + UniqueOccurrence g <> AmbiguousOccurrence gs + = AmbiguousOccurrence (g `NE.cons` gs) + AmbiguousOccurrence gs <> UniqueOccurrence g' + = AmbiguousOccurrence (g' `NE.cons` gs) + AmbiguousOccurrence gs <> AmbiguousOccurrence gs' + = AmbiguousOccurrence (gs Semi.<> gs') + +instance Monoid DisambigInfo where + mempty = NoOccurrence + mappend = (Semi.<>) + +-- Lookup SubBndrOcc can never be ambiguous +-- +-- Records the result of looking up a child. +data ChildLookupResult + -- | We couldn't find a suitable name + = NameNotFound + -- | The child has an incorrect parent + | 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 parent g ns) + = text "IncorrectParent" + <+> hsep [ppr (parentGRE_name parent), ppr $ greName g, ppr ns] + +lookupSubBndrOcc :: DeprecationWarnings + -> 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 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 + ; return $ case child of + FoundChild g -> Right (greName g) + NameNotFound -> Left unknown_sub + IncorrectParent {} -> Left unknown_sub } + -- See [Mismatched class methods and associated type families] + -- in TcInstDecls. + where + unknown_sub = UnknownSubordinate (parentGRE_name the_parent) what_subordinate + +{- Note [Family instance binders] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + data family F a + data instance F T = X1 | X2 + +The 'data instance' decl has an *occurrence* of F (and T), and *binds* +X1 and X2. (This is unlike a normal data type declaration which would +bind F too.) So we want an AvailTC F [X1,X2]. + +Now consider a similar pair: + class C a where + data G a + instance C S where + data G S = Y1 | Y2 + +The 'data G S' *binds* Y1 and Y2, and has an *occurrence* of G. + +But there is a small complication: in an instance decl, we don't use +qualified names on the LHS; instead we use the class to disambiguate. +Thus: + module M where + import Blib( G ) + class C a where + data G a + instance C S where + data G S = Y1 | Y2 +Even though there are two G's in scope (M.G and Blib.G), the occurrence +of 'G' in the 'instance C S' decl is unambiguous, because C has only +one associated type called G. This is exactly what happens for methods, +and it is only consistent to do the same thing for types. That's the +role of the function lookupTcdName; the (Maybe Name) give the class of +the enclosing instance decl, if any. + +Note [Looking up Exact RdrNames] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Exact RdrNames are generated by: + +* Template Haskell (See Note [Binders in Template Haskell] in GHC.ThToHs) +* Derived instances (See Note [Auxiliary binders] in GHC.Tc.Deriv.Generate) + +For data types and classes have Exact system Names in the binding +positions for constructors, TyCons etc. For example + [d| data T = MkT Int |] +when we splice in and convert to HsSyn RdrName, we'll get + data (Exact (system Name "T")) = (Exact (system Name "MkT")) ... +These System names are generated by GHC.ThToHs.thRdrName + +But, constructors and the like need External Names, not System Names! +So we do the following + + * In GHC.Rename.Env.newTopSrcBinder we spot Exact RdrNames that wrap a + non-External Name, and make an External name for it. This is + the name that goes in the GlobalRdrEnv + + * When looking up an occurrence of an Exact name, done in + GHC.Rename.Env.lookupExactOcc, we find the Name with the right unique in the + GlobalRdrEnv, and use the one from the envt -- it will be an + External Name in the case of the data type/constructor above. + + * Exact names are also use for purely local binders generated + by TH, such as \x_33. x_33 + Both binder and occurrence are Exact RdrNames. The occurrence + gets looked up in the LocalRdrEnv by GHC.Rename.Env.lookupOccRn, and + misses, because lookupLocalRdrEnv always returns Nothing for + an Exact Name. Now we fall through to lookupExactOcc, which + will find the Name is not in the GlobalRdrEnv, so we just use + the Exact supplied Name. + +Note [Splicing Exact names] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider the splice $(do { x <- newName "x"; return (VarE x) }) +This will generate a (HsExpr RdrName) term that mentions the +Exact RdrName "x_56" (or whatever), but does not bind it. So +when looking such Exact names we want to check that it's in scope, +otherwise the type checker will get confused. To do this we need to +keep track of all the Names in scope, and the LocalRdrEnv does just that; +we consult it with RdrName.inLocalRdrEnvScope. + +There is another wrinkle. With TH and -XDataKinds, consider + $( [d| data Nat = Zero + data T = MkT (Proxy 'Zero) |] ) +After splicing, but before renaming we get this: + data Nat_77{tc} = Zero_78{d} + data T_79{tc} = MkT_80{d} (Proxy 'Zero_78{tc}) |] ) +The occurrence of 'Zero in the data type for T has the right unique, +but it has a TcClsName name-space in its OccName. (This is set by +the ctxt_ns argument of Convert.thRdrName.) When we check that is +in scope in the GlobalRdrEnv, we need to look up the DataName namespace +too. (An alternative would be to make the GlobalRdrEnv also have +a Name -> GRE mapping.) + +Note [Template Haskell ambiguity] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The GlobalRdrEnv invariant says that if + occ -> [gre1, ..., gren] +then the gres have distinct Names (INVARIANT 1 of GlobalRdrEnv). +This is guaranteed by extendGlobalRdrEnvRn (the dups check in add_gre). + +So how can we get multiple gres in lookupExactOcc_maybe? Because in +TH we might use the same TH NameU in two different name spaces. +eg (#7241): + $(newName "Foo" >>= \o -> return [DataD [] o [] [RecC o []] [''Show]]) +Here we generate a type constructor and data constructor with the same +unique, but different name spaces. + +It'd be nicer to rule this out in extendGlobalRdrEnvRn, but that would +mean looking up the OccName in every name-space, just in case, and that +seems a bit brutal. So it's just done here on lookup. But we might +need to revisit that choice. + +Note [Usage for sub-bndrs] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +If you have this + import qualified M( C( f ) ) + instance M.C T where + f x = x +then is the qualified import M.f used? Obviously yes. +But the RdrName used in the instance decl is unqualified. In effect, +we fill in the qualification by looking for f's whose class is M.C +But when adding to the UsedRdrNames we must make that qualification +explicit (saying "used M.f"), otherwise we get "Redundant import of M.f". + +So we make up a suitable (fake) RdrName. But be careful + import qualified M + import M( C(f) ) + instance C T where + f x = x +Here we want to record a use of 'f', not of 'M.f', otherwise +we'll miss the fact that the qualified import is redundant. + +-------------------------------------------------- +-- Occurrences +-------------------------------------------------- +-} + +lookupLocatedOccRn :: WhatLooking + -> GenLocated (EpAnn ann) RdrName + -> TcRn (GenLocated (EpAnn ann) Name) +lookupLocatedOccRn what = wrapLocMA (lookupOccRn what) + +lookupLocatedOccRnConstr :: GenLocated (EpAnn ann) RdrName + -> TcRn (GenLocated (EpAnn ann) Name) +lookupLocatedOccRnConstr = wrapLocMA lookupOccRnConstr + +lookupLocatedOccRnRecField :: GenLocated (EpAnn ann) RdrName + -> TcRn (GenLocated (EpAnn ann) Name) +lookupLocatedOccRnRecField = wrapLocMA lookupOccRnRecField + +lookupLocatedOccRnNone :: GenLocated (EpAnn ann) RdrName + -> TcRn (GenLocated (EpAnn ann) Name) +lookupLocatedOccRnNone = wrapLocMA lookupOccRnNone + +lookupLocalOccRn_maybe :: RdrName -> RnM (Maybe Name) +-- Just look in the local environment +lookupLocalOccRn_maybe rdr_name + = do { local_env <- getLocalRdrEnv + ; return (lookupLocalRdrEnv local_env rdr_name) } + +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 +-- determine what kind of suggestions should be displayed if it is not in scope +lookupOccRn :: WhatLooking -> RdrName -> RnM Name +lookupOccRn which_suggest rdr_name + = do { mb_gre <- lookupOccRn_maybe rdr_name + ; case mb_gre of + Just gre -> return $ greName gre + Nothing -> reportUnboundName which_suggest rdr_name } + +-- | 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 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 looks up an occurrence of a RdrName and displays +-- no suggestions if it is not in scope +lookupOccRnNone :: RdrName -> RnM Name +lookupOccRnNone = lookupOccRn WL_None + +-- Only used in one place, to rename pattern synonym binders. +-- See Note [Renaming pattern synonym variables] in GHC.Rename.Bind +lookupLocalOccRn :: RdrName -> RnM Name +lookupLocalOccRn rdr_name + = do { mb_name <- lookupLocalOccRn_maybe rdr_name + ; case mb_name of + Just name -> return 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 + = do { mb_gre <- lookupOccRn_maybe rdr_name + ; case mb_gre of + Just gre -> return $ greName gre + Nothing -> + if occName rdr_name == occName eqTyCon_RDR -- See Note [eqTyCon (~) compatibility fallback] + then eqTyConName <$ addDiagnostic TcRnTypeEqualityOutOfScope + else lookup_demoted rdr_name } + +{- Note [eqTyCon (~) compatibility fallback] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Before GHC Proposal #371, the (~) type operator used in type equality +constraints (a~b) was considered built-in syntax. + +This had two implications: + +1. Users could use it without importing it from Data.Type.Equality or Prelude. +2. TypeOperators were not required to use it (it was guarded behind TypeFamilies/GADTs instead) + +To ease migration and minimize breakage, we continue to support those usages +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 <- demoteRdrNameTcCls rdr_name + -- Maybe it's the name of a *data* constructor + = do { data_kinds <- xoptM LangExt.DataKinds + ; star_is_type <- xoptM LangExt.StarIsType + ; let is_star_type = if star_is_type then StarIsType else StarIsNotType + star_is_type_hints = noStarIsTypeHints is_star_type rdr_name + ; if data_kinds + then do { mb_demoted_gre <- lookupOccRn_maybe demoted_rdr + ; case mb_demoted_gre of + Nothing -> unboundNameX looking_for rdr_name star_is_type_hints + Just demoted_gre -> return $ greName demoted_gre} + else do { -- We need to check if a data constructor of this name is + -- in scope to give good error messages. However, we do + -- not want to give an additional error if the data + -- constructor happens to be out of scope! See #13947. + mb_demoted_name <- discardErrs $ + lookupOccRn_maybe demoted_rdr + ; let suggestion | isJust mb_demoted_name + , let additional = text "to refer to the data constructor of that name?" + = [SuggestExtension $ SuggestSingleExtension additional LangExt.DataKinds] + | otherwise + = star_is_type_hints + ; unboundNameX looking_for rdr_name suggestion } } + + | 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 + = unboundName looking_for rdr_name + + where + 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 +-- ^^^^^^^^^^^ +report_qualified_term_in_types :: RdrName -> RdrName -> RnM Name +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 [] + Nothing -> unboundTermNameInTypes looking_for rdr_name demoted_rdr_name } + where + looking_for = LF WL_Constructor WL_Global + +-- If the given RdrName can be promoted to the type level and its promoted variant is in scope, +-- lookup_promoted returns the corresponding type-level Name. +-- Otherwise, the function returns Nothing. +-- See Note [Promotion] below. +lookup_promoted :: RdrName -> RnM (Maybe GlobalRdrElt) +lookup_promoted rdr_name + | Just promoted_rdr <- promoteRdrName rdr_name + = lookupOccRn_maybe promoted_rdr + | otherwise + = return Nothing + +{- Note [Demotion] +~~~~~~~~~~~~~~~~~~ +When the user writes: + data Nat = Zero | Succ Nat + foo :: f Zero -> Int + +'Zero' in the type signature of 'foo' is parsed as: + HsTyVar ("Zero", TcClsName) + +When the renamer hits this occurrence of 'Zero' it's going to realise +that it's not in scope. But because it is renaming a type, it knows +that 'Zero' might be a promoted data constructor, so it will demote +its namespace to DataName and do a second lookup. + +The final result (after the renamer) will be: + HsTyVar ("Zero", DataName) + +Another case of demotion happens when the user tries to +use a qualified term at the type level: + + f :: Prelude.id -> Int + +This signature passes the parser to be caught by the renamer. +It allows the compiler to create more informative error messages. + +'Prelude.id' in the type signature is parsed as + HsTyVar ("id", TvName) + +To separate the case of a typo from the case of an +intentional attempt to use an imported term's name the compiler demotes +the namespace to VarName (using 'demoteTvNameSpace') and does a lookup. + +The same type of demotion happens when the compiler needs to check +if a name of a type variable has already been used for a term that is in scope. +We need to do it to check if a user should change the name +to make his code compatible with the RequiredTypeArguments extension. + +Note [Promotion] +~~~~~~~~~~~~~~~ +When the user mentions a type constructor or a type variable in a +term-level context, then we report that a value identifier was expected +instead of a type-level one. That makes error messages more precise. +Previously, such errors contained only the info that a given value was out of scope (#18740). +We promote the namespace of RdrName and look up after that +(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' + In the expression: id Int + In an equation for ‘x': x = id Int + +when the user writes the following declaration + + x = id Int +-} + +lookupOccRnX_maybe :: (RdrName -> RnM (Maybe r)) -> (GlobalRdrElt -> RnM r) -> RdrName + -> RnM (Maybe r) +lookupOccRnX_maybe globalLookup wrapper rdr_name + = runMaybeT . msum . map MaybeT $ + [ do { res <- lookupLocalOccRn_maybe rdr_name + ; case res of + { Nothing -> return Nothing + ; Just nm -> + -- Elements in the LocalRdrEnv are always Vanilla GREs + do { let gre = mkLocalVanillaGRE NoParent nm + ; Just <$> wrapper gre } } } + , globalLookup rdr_name ] + +lookupOccRn_maybe :: RdrName -> RnM (Maybe GlobalRdrElt) +lookupOccRn_maybe = + lookupOccRnX_maybe + (lookupGlobalOccRn_maybe $ RelevantGREsFOS WantNormal) + return + +-- Used outside this module only by TH name reification (lookupName, lookupThName_maybe) +lookupSameOccRn_maybe :: RdrName -> RnM (Maybe Name) +lookupSameOccRn_maybe = + lookupOccRnX_maybe + (get_name <$> lookupGlobalOccRn_maybe SameNameSpace) + (return . greName) + where + get_name :: RnM (Maybe GlobalRdrElt) -> RnM (Maybe Name) + get_name = fmap (fmap greName) + +-- | Look up a 'RdrName' used as a variable in an expression. +-- +-- This may be a local variable, global variable, or one or more record selector +-- functions. It will not return record fields created with the +-- @NoFieldSelectors@ extension (see Note [NoFieldSelectors]). +-- +-- If the name is not in scope at the term level, but its promoted equivalent is +-- in scope at the type level, the lookup will succeed (so that the type-checker +-- can report a more informative error later). See Note [Promotion]. +-- +lookupExprOccRn :: RdrName -> RnM (Maybe GlobalRdrElt) +lookupExprOccRn rdr_name + = do { mb_name <- lookupOccRnX_maybe + lookupGlobalOccRn_overloaded + return + rdr_name + ; case mb_name of + Nothing -> lookup_promoted rdr_name + -- See Note [Promotion]. + -- We try looking up the name as a + -- type constructor or type variable, if + -- we failed to look up the name at the term level. + p -> return p } + +lookupGlobalOccRn_maybe :: WhichGREs GREInfo -> RdrName -> RnM (Maybe GlobalRdrElt) +-- Looks up a RdrName occurrence in the top-level +-- environment, including using lookupQualifiedNameGHCi +-- for the GHCi case, but first tries to find an Exact or Orig name. +-- No filter function; does not report an error on failure +-- See Note [Errors in lookup functions] +-- Uses addUsedRdrName to record use and deprecations +-- +-- Used directly only by getLocalNonValBinders (new_assoc). +lookupGlobalOccRn_maybe which_gres rdr_name = + lookupExactOrOrig_maybe rdr_name id $ + lookupGlobalOccRn_base which_gres rdr_name + +-- 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 +-- 'Data.Map.elems' is typed, even if you didn't import Data.Map +lookupGlobalOccRn_base :: WhichGREs GREInfo -> RdrName -> RnM (Maybe GlobalRdrElt) +lookupGlobalOccRn_base which_gres rdr_name = + runMaybeT . msum . map MaybeT $ + [ lookupGreRn_maybe which_gres rdr_name + , lookupOneQualifiedNameGHCi fos rdr_name ] + -- This test is not expensive, + -- and only happens for failed lookups + where + fos = case which_gres of + RelevantGREs { includeFieldSelectors = sel } -> sel + _ -> if isFieldOcc (rdrNameOcc rdr_name) + then WantField + else WantNormal + +-- | Lookup a 'Name' in the 'GlobalRdrEnv', falling back to looking up +-- in the type environment it if fails. +lookupGREInfo_GRE :: HasDebugCallStack => Name -> RnM GREInfo +lookupGREInfo_GRE name + = do { rdr_env <- getGlobalRdrEnv + ; case lookupGRE_Name rdr_env name of + Just ( GRE { gre_info = info } ) + -> return info + _ -> do { hsc_env <- getTopEnv + ; return $ lookupGREInfo hsc_env name } } + -- Just looking in the GlobalRdrEnv is insufficient, as we also + -- need to handle qualified imports in GHCi; see e.g. T9815ghci. + +lookupInfoOccRn :: RdrName -> RnM [Name] +-- ^ lookupInfoOccRn is intended for use in GHCi's ":info" command +-- It finds all the GREs that RdrName could mean, not complaining +-- about ambiguity, but rather returning them all (c.f. #9881). +-- +-- lookupInfoOccRn is also used in situations where we check for +-- at least one definition of the RdrName, not complaining about +-- multiple definitions (see #17832). +lookupInfoOccRn rdr_name = + lookupExactOrOrig rdr_name (\ gre -> [greName gre]) $ + do { rdr_env <- getGlobalRdrEnv + ; let nms = map greName $ lookupGRE rdr_env (LookupRdrName rdr_name (RelevantGREsFOS WantBoth)) + ; qual_nms <- map greName <$> lookupQualifiedNameGHCi WantBoth rdr_name + ; return $ nms ++ (qual_nms `minusList` nms) } + +-- | Look up all record field names, available in the 'GlobalRdrEnv', +-- that a given 'RdrName' might refer to. +-- (Also includes implicit qualified imports in GHCi). +-- +-- Throws an error if no fields are found. +-- +-- See Note [DisambiguateRecordFields for updates]. +lookupFieldGREs :: GlobalRdrEnv -> LocatedN RdrName -> RnM (NE.NonEmpty FieldGlobalRdrElt) +lookupFieldGREs env (L loc rdr) + = setSrcSpanA loc + $ do { res <- lookupExactOrOrig rdr (\ gre -> maybeToList $ fieldGRE_maybe gre) $ + 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 + ; let (ghci_fld_gres, ghci_var_gres) = + partition isRecFldGRE $ + ghci_gres + + ; let fld_gres = ghci_fld_gres ++ env_fld_gres + var_gres = ghci_var_gres ++ env_var_gres + + -- Add an error for ambiguity when -XDisambiguateRecordFields is off. + -- + -- See Note [DisambiguateRecordFields for updates]. + ; disamb_ok <- xoptM LangExt.DisambiguateRecordFields + ; if | not disamb_ok + , gre1 : gre2 : others <- fld_gres ++ var_gres + -> addErrTc $ TcRnAmbiguousFieldInUpdate (gre1, gre2, others) + | otherwise + -> return () + ; return fld_gres } + + -- Add an error if lookup failed. + ; case res of + { 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. +-- +-- Don't allow any ambiguity: emit a name-clash error if there are multiple +-- matching GREs. +lookupGlobalOccRn_overloaded :: RdrName -> RnM (Maybe GlobalRdrElt) +lookupGlobalOccRn_overloaded rdr_name = + lookupExactOrOrig_maybe rdr_name id $ + do { res <- lookupGreRn_helper (RelevantGREsFOS WantNormal) rdr_name AllDeprecationWarnings + ; case res of + GreNotFound -> lookupOneQualifiedNameGHCi WantNormal rdr_name + OneNameMatch gre -> return $ Just gre + MultipleNames gres@(gre NE.:| _) -> do + addNameClashErrRn rdr_name gres + return (Just gre) } + +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. +-- +-- Example: +-- +-- data D = MkD { fld1 :: Int, fld2 :: Bool } +-- data E = MkE1 { fld1 :: Int, fld2 :: Bool, fld3 :: Char } +-- | MkE2 { fld1 :: Int, fld2 :: Bool } +-- data F = MkF1 { fld1 :: Int } | MkF2 { fld2 :: Bool } +-- +-- f r = r { fld1 = a, fld2 = b } +-- +-- This function will return: +-- +-- [ [ D.fld1, D.fld2 ] -- could be a record update at type D +-- , [ E.fld1, E.fld2 ] -- could be a record update at type E +-- ] -- cannot be a record update at type F: no constructor has both +-- -- of the fields fld1 and fld2 +-- +-- If there are no valid parents for the record update, +-- throws a 'TcRnBadRecordUpdate' error. +lookupRecUpdFields :: NE.NonEmpty (LHsRecUpdField GhcPs GhcPs) + -> RnM (NE.NonEmpty (HsRecUpdParent GhcRn)) +lookupRecUpdFields flds +-- See Note [Disambiguating record updates] in GHC.Rename.Pat. + = 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 + -- (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 + + ; traceRn "lookupRecUpdFields" $ + vcat [ text "flds:" <+> ppr (fmap getFieldUpdLbl flds) + , text "possible_GREs:" <+> + ppr (map (fmap greName . rnRecUpdLabels) possible_GREs) ] + + ; case possible_GREs of + + -- (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) + + -- (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 + fld1_cons = unionManyUniqSets + $ NE.toList + $ NE.map (recFieldCons . fieldGREInfo) fld1_gres + -- The field labels of the constructors which have the first field. + fld1_cons_fields :: UniqFM ConLikeName [FieldLabel] + fld1_cons_fields + = fmap (lkp_con_fields hsc_env gre_env) + $ getUniqSet fld1_cons + failWithTc $ badFieldsUpd (NE.toList flds) fld1_cons_fields } } + + where + intersect_by_cons :: NE.NonEmpty FieldGlobalRdrElt + -> [NE.NonEmpty FieldGlobalRdrElt] + -> [HsRecUpdParent GhcRn] + intersect_by_cons this [] = + map + (\ fld -> RnRecUpdParent (fld NE.:| []) (recFieldCons (fieldGREInfo fld))) + (NE.toList this) + intersect_by_cons this (new : rest) = + [ RnRecUpdParent (this_fld NE.<| next_flds) both_cons + | this_fld <- NE.toList this + , let this_cons = recFieldCons $ fieldGREInfo this_fld + , RnRecUpdParent next_flds next_cons <- intersect_by_cons new rest + , let both_cons = next_cons `intersectUniqSets` this_cons + , not $ isEmptyUniqSet both_cons + ] + + -- 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 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. + ] + +{-********************************************************************** +* * + Record field errors +* * +**********************************************************************-} + +getUpdFieldLbls :: forall p q. IsPass p + => [LHsRecUpdField (GhcPass p) q] -> [RdrName] +getUpdFieldLbls + = map $ fieldOccRdrName + . unXRec @(GhcPass p) + . hfbLHS + . unXRec @(GhcPass p) + +-- | Create an error message when there is no single 'ConLike' which +-- has all of the required fields for a record update. +-- +-- This boils down the problem to a smaller set of fields, to avoid +-- the error message containing a lot of uninformative field names that +-- aren't really relevant to the problem. +-- +-- NB: this error message should only be triggered when all the field names +-- 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] + -- ^ Field names that don't belong to a single datacon + -> UniqFM ConLikeName [FieldLabel] + -- ^ The list of field labels for each constructor. + -- (These are the constructors in which the first field occurs.) + -> TcRnMessage +badFieldsUpd rbinds fld1_cons_fields + = TcRnBadRecordUpdate + (getUpdFieldLbls rbinds) + (NoConstructorHasAllFields conflictingFields) + -- See Note [Finding the conflicting fields] + where + -- A (preferably small) set of fields such that no constructor contains + -- all of them. See Note [Finding the conflicting fields] + conflictingFields = case nonMembers of + -- nonMember belongs to a different type. + (nonMember, _) : _ -> [aMember, nonMember] + [] -> let + -- All of rbinds belong to one type. In this case, repeatedly add + -- a field to the set until no constructor contains the set. + + -- Each field, together with a list indicating which constructors + -- have all the fields so far. + growingSets :: [(FieldLabelString, [Bool])] + growingSets = scanl1 combine membership + combine (_, setMem) (field, fldMem) + = (field, zipWith (&&) setMem fldMem) + in + -- Fields that don't change the membership status of the set + -- are redundant and can be dropped. + map (fst . NE.head) $ NE.groupBy ((==) `on` snd) growingSets + + aMember = assert (not (null members) ) fst (head members) + (members, nonMembers) = partition (or . snd) membership + + -- For each field, which constructors contain the field? + membership :: [(FieldLabelString, [Bool])] + membership + = sortMembership $ + map + ( (\fld -> (fld, map (fld `elementOfUniqSet`) fieldLabelSets)) + . FieldLabelString . occNameFS . rdrNameOcc . unLoc . getFieldUpdLbl ) + rbinds + + fieldLabelSets :: [UniqSet FieldLabelString] + fieldLabelSets = map (mkUniqSet . map flLabel) $ nonDetEltsUFM fld1_cons_fields + + -- Sort in order of increasing number of True, so that a smaller + -- conflicting set can be found. + sortMembership = + map snd . + sortBy (compare `on` fst) . + map (\ item@(_, membershipRow) -> (countTrue membershipRow, item)) + + countTrue = count id + +{- +Note [Finding the conflicting fields] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we have + data A = A {a0, a1 :: Int} + | B {b0, b1 :: Int} +and we see a record update + x { a0 = 3, a1 = 2, b0 = 4, b1 = 5 } +Then we'd like to find the smallest subset of fields that no +constructor has all of. Here, say, {a0,b0}, or {a0,b1}, etc. +We don't really want to report that no constructor has all of +{a0,a1,b0,b1}, because when there are hundreds of fields it's +hard to see what was really wrong. + +We may need more than two fields, though; eg + data T = A { x,y :: Int, v::Int } + | B { y,z :: Int, v::Int } + | C { z,x :: Int, v::Int } +with update + r { x=e1, y=e2, z=e3 }, we + +Finding the smallest subset is hard, so the code here makes +a decent stab, no more. See #7989. +-} + +-------------------------------------------------- +-- Lookup in the Global RdrEnv of the module +-------------------------------------------------- + +data GreLookupResult = GreNotFound + | OneNameMatch GlobalRdrElt + | MultipleNames (NE.NonEmpty GlobalRdrElt) + +lookupGreRn_maybe :: WhichGREs GREInfo -> RdrName -> RnM (Maybe GlobalRdrElt) +-- Look up the RdrName in the GlobalRdrEnv +-- Exactly one binding: records it as "used", return (Just gre) +-- No bindings: return Nothing +-- Many bindings: report "ambiguous", return an arbitrary (Just gre) +-- Uses addUsedRdrName to record use and deprecations +lookupGreRn_maybe which_gres rdr_name + = do + res <- lookupGreRn_helper which_gres rdr_name AllDeprecationWarnings + case res of + OneNameMatch gre -> return $ Just gre + MultipleNames gres -> do + traceRn "lookupGreRn_maybe:NameClash" (ppr gres) + addNameClashErrRn rdr_name gres + return $ Just (NE.head gres) + GreNotFound -> return Nothing + +{- + +Note [ Unbound vs Ambiguous Names ] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +lookupGreRn_maybe deals with failures in two different ways. If a name +is unbound then we return a `Nothing` but if the name is ambiguous +then we raise an error and return a dummy name. + +The reason for this is that when we call `lookupGreRn_maybe` we are +speculatively looking for whatever we are looking up. If we don't find it, +then we might have been looking for the wrong thing and can keep trying. +On the other hand, if we find a clash then there is no way to recover as +we found the thing we were looking for but can no longer resolve which +the correct one is. + +One example of this is in `lookupTypeOccRn` which first looks in the type +constructor namespace before looking in the data constructor namespace to +deal with `DataKinds`. + +There is however, as always, one exception to this scheme. If we find +an ambiguous occurrence of a record selector and DuplicateRecordFields +is enabled then we defer the selection until the typechecker. + +-} + + +-- Internal Function +lookupGreRn_helper :: WhichGREs GREInfo -> RdrName -> DeprecationWarnings -> RnM GreLookupResult +lookupGreRn_helper which_gres rdr_name warn_if_deprec + = do { env <- getGlobalRdrEnv + ; case lookupGRE env (LookupRdrName rdr_name which_gres) of + [] -> return GreNotFound + [gre] -> do { addUsedGRE warn_if_deprec gre + ; return (OneNameMatch gre) } + -- Don't record usage for ambiguous names + -- until we know which is meant + (gre:others) -> return (MultipleNames (gre NE.:| others)) } + +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 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 what_looking WL_Global) rdr_name + return Nothing + MultipleNames gres -> + do + addNameClashErrRn rdr_name gres + return Nothing + -- Prevent error cascade + OneNameMatch gre -> + return $ Just gre + +{- +********************************************************* +* * + Deprecations +* * +********************************************************* + +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. +-} + +addUsedDataCons :: GlobalRdrEnv -> TyCon -> RnM () +-- Remember use of in-scope data constructors (#7969) +addUsedDataCons rdr_env tycon + = addUsedGREs NoDeprecationWarnings + [ gre + | dc <- tyConDataCons tycon + , Just gre <- [lookupGRE_Name rdr_env (dataConName dc)] ] + +addUsedGRE :: DeprecationWarnings -> GlobalRdrElt -> RnM () +-- Called for both local and imported things +-- Add usage *and* warn if deprecated +addUsedGRE 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) + ; traceRn "addUsedGRE" (ppr $ greName gre) + ; updTcRef (tcg_used_gres env) (gre :) } } + +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] in GHC.Rename.Utils +addUsedGREs warn_if_deprec gres + = do { warnIfDeprecated warn_if_deprec gres + ; unless (null imp_gres) $ + do { env <- getGblEnv + -- Do not report the GREInfo (#23424) + ; traceRn "addUsedGREs" (ppr $ map greName imp_gres) + ; updTcRef (tcg_used_gres env) (imp_gres ++) } } + where + imp_gres = filter isImportedGRE gres + -- See Note [Using isImportedGRE in addUsedGRE] + +{- +Note [Used names with interface not loaded] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +It's (just) possible to find a used +Name whose interface hasn't been loaded: + +a) It might be a WiredInName; in that case we may not load + its interface (although we could). + +b) It might be GHC.Real.fromRational, or GHC.Num.fromInteger + These are seen as "used" by the renamer (if -XRebindableSyntax) + is on), but the typechecker may discard their uses + if in fact the in-scope fromRational is GHC.Read.fromRational, + (see tcPat.tcOverloadedLit), and the typechecker sees that the type + is fixed, say, to GHC.Base.Float (see Inst.lookupSimpleInst). + In that obscure case it won't force the interface in. + +In both cases we simply don't permit deprecations; +this is, after all, wired-in stuff. + + +********************************************************* +* * + GHCi support +* * +********************************************************* + +A qualified name on the command line can refer to any module at +all: we try to load the interface if we don't already have it, just +as if there was an "import qualified M" declaration for every +module. + +For example, writing `Data.List.sort` will load the interface file for +`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" +which is what loadSrcInterface does. + +It is enabled by default and disabled by the flag +`-fno-implicit-import-qualified`. + +Note [Safe Haskell and GHCi] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We DON'T do this Safe Haskell as we need to check imports. We can +and should instead check the qualified import but at the moment +this requires some refactoring so leave as a TODO + +Note [DuplicateRecordFields and -fimplicit-import-qualified] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When DuplicateRecordFields is used, a single module can export the same OccName +multiple times, for example: + + module M where + data S = MkS { foo :: Int } + data T = MkT { foo :: Int } + +Now if we refer to M.foo via -fimplicit-import-qualified, we need to report an +ambiguity error. + +-} + +-- | Like 'lookupQualifiedNameGHCi' but returning at most one name, reporting an +-- ambiguity error if there are more than one. +lookupOneQualifiedNameGHCi :: FieldsOrSelectors -> RdrName -> RnM (Maybe GlobalRdrElt) +lookupOneQualifiedNameGHCi fos rdr_name = do + all_gres <- lookupQualifiedNameGHCi fos rdr_name + case all_gres of + [] -> return Nothing + [gre] -> return $ Just $ gre + (gre:gres) -> + do addNameClashErrRn rdr_name (gre NE.:| gres) + return (Just (mkUnboundGRE $ greOccName gre)) + -- (Use mkUnboundGRE to get the correct namespace) + +-- | Look up *all* the names to which the 'RdrName' may refer in GHCi (using +-- @-fimplicit-import-qualified@). This will normally be zero or one, but may +-- be more in the presence of @DuplicateRecordFields@. +lookupQualifiedNameGHCi :: HasDebugCallStack => FieldsOrSelectors -> RdrName -> RnM [GlobalRdrElt] +lookupQualifiedNameGHCi fos rdr_name + = -- We want to behave as we would for a source file import here, + -- and respect hiddenness of modules/packages, hence loadSrcInterface. + do { dflags <- getDynFlags + ; is_ghci <- getIsGHCi + ; go_for_it dflags is_ghci } + + where + go_for_it dflags is_ghci + | Just (mod_name,occ) <- isQual_maybe rdr_name + , let ns = occNameSpace occ + , is_ghci + , gopt Opt_ImplicitImportQualified dflags -- Enables this GHCi behaviour + , not (safeDirectImpsReq dflags) -- See Note [Safe Haskell and GHCi] + = do { res <- loadSrcInterface_maybe doc mod_name NotBoot NoPkgQual + ; case res of + Succeeded iface + -> do { hsc_env <- getTopEnv + ; let gres = + [ gre + | avail <- mi_exports iface + , gname <- availNames avail + , let lk_occ = occName gname + lk_ns = occNameSpace lk_occ + , occNameFS occ == occNameFS lk_occ + , ns == lk_ns || (ns == varName && isFieldNameSpace lk_ns) + , let mod = mi_module iface + gre = lookupGRE_PTE mod hsc_env gname + , allowGRE fos gre + -- Include a field if it has a selector or we are looking for all fields; + -- see Note [NoFieldSelectors]. + ] + ; return gres } + + _ -> -- Either we couldn't load the interface, or + -- we could but we didn't find the name in it + do { traceRn "lookupQualifiedNameGHCi" (ppr rdr_name) + ; return [] } } + + | otherwise + = do { traceRn "lookupQualifiedNameGHCi: off" (ppr rdr_name) + ; return [] } + + doc = text "Need to find" <+> ppr rdr_name + + -- Lookup a Name for an implicit qualified import in GHCi + -- in the given PackageTypeEnv. + lookupGRE_PTE :: Module -> HscEnv -> Name -> GlobalRdrElt + lookupGRE_PTE mod hsc_env nm = + -- Fake a GRE so we can report a sensible name clash error if + -- -fimplicit-import-qualified is used with a module that exports the same + -- field name multiple times (see + -- Note [DuplicateRecordFields and -fimplicit-import-qualified]). + GRE { gre_name = nm + , gre_par = NoParent + , gre_lcl = False + , gre_imp = unitBag is + , gre_info = info } + where + info = lookupGREInfo hsc_env nm + spec = ImpDeclSpec { is_mod = mod + , is_as = moduleName mod + , is_pkg_qual = NoPkgQual + , is_qual = True + , is_isboot = NotBoot + , is_dloc = noSrcSpan + , is_level = NormalLevel } + is = ImpSpec { is_decl = spec, is_item = ImpAll } + +-- | Look up the 'GREInfo' associated with the given 'Name' +-- by looking up in the type environment. +lookupGREInfo :: HasDebugCallStack => HscEnv -> Name -> GREInfo +lookupGREInfo hsc_env nm + | Just ty_thing <- wiredInNameTyThing_maybe nm + = tyThingGREInfo ty_thing + | otherwise + -- Create a thunk which, when forced, loads the interface + -- 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 -> + unsafePerformIO $ do + _ <- initIfaceLoad hsc_env $ + loadInterface (text "lookupGREInfo" <+> parens (ppr nm)) + mod ImportBySystem + mb_ty_thing <- lookupType hsc_env nm + case mb_ty_thing of + Nothing -> do + pprPanic "lookupGREInfo" $ + vcat [ text "lookup failed:" <+> ppr nm ] + Just ty_thing -> return $ tyThingGREInfo ty_thing + +{- +Note [Looking up signature names] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +lookupSigOccRn is used for type signatures and pragmas +Is this valid? + module A + import M( f ) + f :: Int -> Int + f x = x +It's clear that the 'f' in the signature must refer to A.f +The Haskell98 report does not stipulate this, but it will! +So we must treat the 'f' in the signature in the same way +as the binding occurrence of 'f', using lookupBndrRn + +However, consider this case: + import M( f ) + f :: Int -> Int + g x = x +We don't want to say 'f' is out of scope; instead, we want to +return the imported 'f', so that later on the renamer will +correctly report "misplaced type sig". + +Note [Signatures for top level things] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +data HsSigCtxt = ... | TopSigCtxt NameSet | .... + +* The NameSet says what is bound in this group of bindings. + We can't use isLocalGRE from the GlobalRdrEnv, because of this: + f x = x + $( ...some TH splice... ) + f :: Int -> Int + When we encounter the signature for 'f', the binding for 'f' + will be in the GlobalRdrEnv, and will be a LocalDef. Yet the + signature is mis-placed + +* For type signatures the NameSet should be the names bound by the + value bindings; for fixity declarations, the NameSet should also + include class sigs and record selectors + + infix 3 `f` -- Yes, ok + 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 + = TopSigCtxt NameSet -- At top level, binding these names + -- See Note [Signatures for top level things] + | LocalBindCtxt NameSet -- In a local binding, binding these names + | ClsDeclCtxt Name -- Class decl for this class + | 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 + +instance Outputable HsSigCtxt where + ppr (TopSigCtxt ns) = text "TopSigCtxt" <+> ppr ns + ppr (LocalBindCtxt ns) = text "LocalBindCtxt" <+> ppr ns + ppr (ClsDeclCtxt n) = text "ClsDeclCtxt" <+> ppr n + ppr (InstDeclCtxt ns) = text "InstDeclCtxt" <+> ppr ns + ppr (HsBootCtxt ns) = text "HsBootCtxt" <+> ppr ns + ppr (RoleAnnotCtxt ns) = text "RoleAnnotCtxt" <+> ppr ns + +lookupSigOccRn :: HsSigCtxt + -> Sig GhcPs + -> 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 + -> 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 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 $ TcRnNotInScope err rdr_name + ; return (mkUnboundNameRdr rdr_name) } + } + +lookupBindGroupOcc :: HsSigCtxt + -> 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 ns_spec + | Just n <- isExact_maybe rdr_name + = do { mb_gre <- lookupExactOcc_either n + ; return $ case mb_gre of + Left err -> NE.singleton $ Left err + Right gre -> finish (NoExactName $ greName gre) gre } + -- Maybe we should check the side conditions + -- but it's a pain, and Exact things only show + -- up when you know what you are doing + + | Just (rdr_mod, rdr_occ) <- isOrig_maybe rdr_name + = do { NE.singleton . Right <$> lookupOrig rdr_mod rdr_occ } + + | otherwise + = case ctxt of + 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 occ_env-> lookup_inst occ_env + where + elem_name_set_with_namespace ns n = check_namespace n && (n `elemNameSet` ns) + + check_namespace = coveredByNamespaceSpecifier ns_spec . nameNameSpace + + namespace = occNameSpace occ + occ = rdrNameOcc rdr_name + 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)) + | otherwise + = NE.singleton (Left err) + + succeed_with n = return $ NE.singleton $ Right n + + lookup_cls_op 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 + all_gres = lookupGRE env (LookupOccName occ relevant_gres) + names_in_scope = -- If rdr_name lacks a binding, only + -- recommend alternatives from relevant + -- namespaces. See #17593. + map greName + $ filter (ok_gre <&&> isLocalGRE) + $ globalRdrEnvElts env + candidates_msg = candidates names_in_scope + ; case filter (keep_me . greName) all_gres of + [] | null all_gres -> bale_out_with candidates_msg + | otherwise -> bale_out_with local_msg + (gre1:gres) -> return (fmap (Right . greName) (gre1 NE.:| gres)) } + + lookup_group bound_names -- Look in the local envt (not top level) + = do { mname <- lookupLocalOccRn_maybe rdr_name + ; env <- getLocalRdrEnv + ; let candidates_msg = candidates $ localRdrEnvElts env + ; case mname of + Just n + | n `elemNameSet` bound_names -> succeed_with n + | otherwise -> bale_out_with local_msg + Nothing -> bale_out_with candidates_msg } + + bale_out_with hints = return $ NE.singleton $ Left $ MissingBinding what hints + + local_msg = [SuggestMoveToDeclarationSite what rdr_name] + + -- Identify all similar names and produce a message listing them + candidates :: [Name] -> [GhcHint] + candidates names_in_scope + | (nm : nms) <- map SimilarName similar_names + = [SuggestSimilarNames rdr_name (nm NE.:| nms)] + | otherwise + = [] + where + similar_names + = fuzzyLookup (unpackFS $ occNameFS $ rdrNameOcc rdr_name) + $ map (\x -> ((unpackFS $ occNameFS $ nameOccName x), x)) + names_in_scope + + +--------------- +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 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 ns_spec + ; let (errs, names) = partitionEithers (NE.toList nms_eithers) + ; when (null names) $ + addErr (head errs) -- Bleat about one only + ; return names } + where + -- Guard against the built-in syntax (ex: `infixl 6 :`), see #15233 + guard_builtin_syntax this_mod rdr (Right name) + | isBuiltInOcc (occName rdr) + , this_mod /= nameModule name + = Left $ TcRnIllegalBuiltinSyntax what rdr + | otherwise + = Right (rdr, name) + guard_builtin_syntax _ _ (Left err) + = Left $ TcRnNotInScope err rdr + +dataTcOccs :: RdrName -> [RdrName] +-- Return both the given name and the same name promoted to the TcClsName +-- namespace. This is useful when we aren't sure which we are looking at. +-- See also Note [dataTcOccs and Exact Names] +dataTcOccs rdr_name + | isDataOcc occ || isVarOcc occ + = [rdr_name, rdr_name_tc] + | otherwise + = [rdr_name] + where + occ = rdrNameOcc rdr_name + rdr_name_tc = setRdrNameSpace rdr_name tcName + +{- Note [dataTcOccs and Exact Names] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Exact RdrNames can occur in code generated by Template Haskell, and generally +those references are, well, exact. However, the TH `Name` type isn't expressive +enough to always track the correct namespace information, so we sometimes get +the right Unique but wrong namespace. Thus, we still have to do the double-lookup +for Exact RdrNames. + +There is also an awkward situation for built-in syntax. Example in GHCi + :info [] +This parses as the Exact RdrName for nilDataCon, but we also want +the list type constructor. + +Note that setRdrNameSpace on an Exact name requires the Name to be External, +which it always is for built in syntax. +-} + +{- +************************************************************************ +* * + Rebindable names + Dealing with rebindable syntax is driven by the + Opt_RebindableSyntax dynamic flag. + + In "deriving" code we don't want to use rebindable syntax + so we switch off the flag locally + +* * +************************************************************************ + +Haskell 98 says that when you say "3" you get the "fromInteger" from the +Standard Prelude, regardless of what is in scope. However, to experiment +with having a language that is less coupled to the standard prelude, we're +trying a non-standard extension that instead gives you whatever "Prelude.fromInteger" +happens to be in scope. Then you can + import Prelude () + import MyPrelude as Prelude +to get the desired effect. + +At the moment this just happens for + * fromInteger, fromRational on literals (in expressions and patterns) + * negate (in expressions) + * minus (arising from n+k patterns) + * "do" notation + +We store the relevant Name in the HsSyn tree, in + * HsIntegral/HsFractional/HsIsString + * NegApp + * NPlusKPat + * HsDo +respectively. Initially, we just store the "standard" name (GHC.Builtin.Names.fromIntegralName, +fromRationalName etc), but the renamer changes this to the appropriate user +name if Opt_NoImplicitPrelude is on. That is what lookupSyntax does. + +We treat the original (standard) names as free-vars too, because the type checker +checks the type of the user thing against the type of the standard thing. +-} + +lookupIfThenElse :: RnM (Maybe Name) +-- Looks up "ifThenElse" if rebindable syntax is on +lookupIfThenElse + = do { rebindable_on <- xoptM LangExt.RebindableSyntax + ; if not rebindable_on + then return Nothing + else do { ite <- lookupOccRnNone (mkVarUnqual (fsLit "ifThenElse")) + ; return (Just ite) } } + +lookupSyntaxName :: Name -- ^ The standard name + -> RnM (Name, FreeVars) -- ^ Possibly a non-standard name +-- Lookup a Name that may be subject to Rebindable Syntax (RS). +-- +-- - When RS is off, just return the supplied (standard) Name +-- +-- - When RS is on, look up the OccName of the supplied Name; return +-- what we find, or the supplied Name if there is nothing in scope +lookupSyntaxName std_name + = do { rebind <- xoptM LangExt.RebindableSyntax + ; if not rebind + then return (std_name, emptyFVs) + else do { nm <- lookupOccRnNone (mkRdrUnqual (nameOccName std_name)) + ; return (nm, unitFV nm) } } + +lookupSyntaxExpr :: Name -- ^ The standard name + -> RnM (HsExpr GhcRn, FreeVars) -- ^ Possibly a non-standard name +lookupSyntaxExpr std_name + = do { (name, fvs) <- lookupSyntaxName std_name + ; return (genHsVar name, fvs) } + +lookupSyntax :: Name -- The standard name + -> RnM (SyntaxExpr GhcRn, FreeVars) -- Possibly a non-standard + -- name +lookupSyntax std_name + = do { (name, fvs) <- lookupSyntaxName std_name + ; return (mkRnSyntaxExpr name, fvs) } + +lookupSyntaxNames :: [Name] -- Standard names + -> RnM ([HsExpr GhcRn], FreeVars) -- See comments with HsExpr.ReboundNames + -- this works with CmdTop, which wants HsExprs, not SyntaxExprs +lookupSyntaxNames std_names + = do { rebindable_on <- xoptM LangExt.RebindableSyntax + ; if not rebindable_on then + return (map (mkHsVar . noLocA) std_names, emptyFVs) + else + do { usr_names <- + mapM (lookupOccRnNone . mkRdrUnqual . nameOccName) std_names + ; return (map (mkHsVar . noLocA) usr_names, mkFVs usr_names) } } + + +{- +Note [QualifiedDo] +~~~~~~~~~~~~~~~~~~ +QualifiedDo is implemented using the same placeholders for operation names in +the AST that were devised for RebindableSyntax. Whenever the renamer checks +which names to use for do syntax, it first checks if the do block is qualified +(e.g. M.do { stmts }), in which case it searches for qualified names. If the +qualified names are not in scope, an error is produced. If the do block is not +qualified, the renamer does the usual search of the names which considers +whether RebindableSyntax is enabled or not. Dealing with QualifiedDo is driven +by the Opt_QualifiedDo dynamic flag. +-} + +-- Lookup operations for a qualified do. If the context is not a qualified +-- do, then use lookupSyntaxExpr. See Note [QualifiedDo]. +lookupQualifiedDo :: HsStmtContext fn -> Name -> RnM (SyntaxExpr GhcRn, FreeVars) +lookupQualifiedDo ctxt std_name + = first mkRnSyntaxExpr <$> lookupQualifiedDoName ctxt std_name + +lookupNameWithQualifier :: Name -> ModuleName -> RnM (Name, FreeVars) +lookupNameWithQualifier std_name modName + = do { qname <- lookupOccRnNone (mkRdrQual modName (nameOccName std_name)) + ; return (qname, unitFV qname) } + +-- See Note [QualifiedDo]. +lookupQualifiedDoName :: HsStmtContext fn -> Name -> RnM (Name, FreeVars) +lookupQualifiedDoName ctxt std_name + = case qualifiedDoModuleName_maybe ctxt of + Nothing -> lookupSyntaxName std_name + Just modName -> lookupNameWithQualifier std_name modName + +-------------------------------------------------------------------------------- +-- Helper functions for 'isIrrefutableHsPat'. +-- +-- (Defined here to avoid import cycles.) + +-- | Check irrefutability of a 'ConLike' in a 'ConPat GhcRn' +-- (the 'Irref-ConLike' condition of Note [Irrefutability of ConPat]). +irrefutableConLikeRn :: HasDebugCallStack + => HscEnv + -> GlobalRdrEnv + -> CompleteMatches -- ^ in-scope COMPLETE pragmas + -> 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,34 @@ -} 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 ) +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.Session + +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 import GHC.Types.Fixity import GHC.Types.Id.Make @@ -63,41 +61,54 @@ import GHC.Types.Name.Reader import GHC.Types.Unique.Set import GHC.Types.SourceText +import GHC.Types.SrcLoc + import GHC.Utils.Misc -import GHC.Data.List.SetOps ( removeDups ) +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.Types.SrcLoc -import Control.Monad -import GHC.Builtin.Types ( nilDataConName ) + +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 Data.List (unzip4, minimumBy) -import Data.List.NonEmpty ( NonEmpty(..), nonEmpty ) -import Data.Maybe (isJust, isNothing) +import Control.Monad +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. @@ -106,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 @@ -132,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 @@ -146,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. @@ -174,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 @@ -207,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. -} {- @@ -236,81 +306,83 @@ 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_name <- lookupExprOccRn v + ; mb_gre <- lookupExprOccRn v + ; case mb_gre of { + Nothing -> rnUnboundVar l v ; + Just gre -> + do { let nm = greName gre + info = greInfo gre + ; if | IAmRecField fld_info <- info + -- Since GHC 9.4, such occurrences of record fields must be + -- unambiguous. For ambiguous occurrences, we arbitrarily pick one + -- matching GRE and add a name clash error + -- (see lookupGlobalOccRn_overloaded, called by lookupExprOccRn). + -> do { let sel_name = flSelector $ recFieldLabel fld_info + ; 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 + -- OverloadedLists works correctly + -- Note [Empty lists] in GHC.Hs.Expr + , xopt LangExt.OverloadedLists dflags + -> rnExpr (ExplicitList noAnn []) - ; case mb_name of { - Nothing -> rnUnboundVar v ; - Just (NormalGreName name) - | name == nilDataConName -- Treat [] as an ExplicitList, so that - -- OverloadedLists works correctly - -- Note [Empty lists] in GHC.Hs.Expr - , xopt LangExt.OverloadedLists dflags - -> rnExpr (ExplicitList noAnn []) + | otherwise + -> do { res_expr <- checkThLocalNameWithLift (L (l2l l) (WithUserRdr v nm)) + ; return (res_expr, unitFV nm) } + }}} - | otherwise - -> finishHsVar (L (na2la l) name) ; - Just (FieldGreName fl) - -> do { let sel_name = flSelector fl - ; this_mod <- getModule - ; when (nameIsLocalOrFrom this_mod sel_name) $ - checkThLocalName sel_name - ; return ( HsRecSel noExtField (FieldOcc sel_name (L l v) ), unitFV sel_name) - } - } - } 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) @@ -318,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 "type" $ hswc_body arg + ; 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 @@ -336,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 @@ -359,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')) @@ -367,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) } ------------------------------------------ @@ -385,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 } @@ -410,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 noExtField new_expr new_matches, e_fvs `plusFV` ms_fvs) } + ; 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) <- @@ -434,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 @@ -443,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') } } @@ -463,44 +531,58 @@ = 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) } -rnExpr (RecordUpd { rupd_expr = expr, rupd_flds = rbinds }) - = case rbinds of - Left flds -> -- 'OverloadedRecordUpdate' is not in effect. Regular record update. - do { ; (e, fv_e) <- rnLExpr expr - ; (rs, fv_rs) <- rnHsRecUpdFields flds - ; return ( RecordUpd noExtField e (Left rs), fv_e `plusFV` fv_rs ) - } - Right flds -> -- 'OverloadedRecordUpdate' is in effect. Record dot update desugaring. - do { ; unlessXOptM LangExt.RebindableSyntax $ - addErr TcRnNoRebindableSyntaxRecordDot - ; let punnedFields = [fld | (L _ fld) <- flds, hfbPun fld] - ; punsEnabled <-xoptM LangExt.NamedFieldPuns - ; unless (null punnedFields || punsEnabled) $ - addErr TcRnNoFieldPunsRecordDot - ; (getField, fv_getField) <- lookupSyntaxName getFieldName - ; (setField, fv_setField) <- lookupSyntaxName setFieldName - ; (e, fv_e) <- rnLExpr expr - ; (us, fv_us) <- rnHsUpdProjs flds - ; return ( mkExpandedExpr - (RecordUpd noExtField e (Right us)) - (mkRecordDotUpd getField setField e us) - , plusFVs [fv_getField, fv_setField, fv_e, fv_us] ) - } +rnExpr (RecordUpd { rupd_expr = L l expr, rupd_flds = rbinds }) + = setSrcSpanA l $ + case rbinds of + -- 'OverloadedRecordUpdate' is not in effect. Regular record update. + RegularRecUpdFields { recUpdFields = flds } -> + do { (e, fv_e) <- rnExpr expr + ; (parents, flds, fv_flds) <- rnHsRecUpdFields flds + ; let upd_flds = + RegularRecUpdFields + { xRecUpdFields = parents + , recUpdFields = flds } + ; return ( RecordUpd noExtField (L l e) upd_flds + , fv_e `plusFV` fv_flds ) } + + -- 'OverloadedRecordUpdate' is in effect. Record dot update desugaring. + OverloadedRecUpdFields { olRecUpdFields = flds } -> + do { unlessXOptM LangExt.RebindableSyntax $ + addErr TcRnNoRebindableSyntaxRecordDot + ; let punnedFields = [fld | (L _ fld) <- flds, hfbPun fld] + ; punsEnabled <- xoptM LangExt.NamedFieldPuns + ; unless (null punnedFields || punsEnabled) $ + addErr TcRnNoFieldPunsRecordDot + ; (getField, fv_getField) <- lookupSyntaxName getFieldName + ; (setField, fv_setField) <- lookupSyntaxName setFieldName + ; (e, fv_e) <- rnExpr expr + ; (us, fv_us) <- rnHsUpdProjs flds + ; let upd_flds = OverloadedRecUpdFields + { xOLRecUpdFields = noExtField + , olRecUpdFields = us } + ; return ( mkExpandedExpr + (RecordUpd noExtField (L l e) upd_flds) + (mkRecordDotUpd getField setField (L l e) us) + , plusFVs [fv_getField, fv_setField, fv_e, fv_us] ) } + + rnExpr (ExprWithTySig _ expr pty) = do { (pty', fvTy) <- rnHsSigWcType ExprWithTySigCtx pty ; (expr', fvExpr) <- bindSigTyVarsFV (hsWcScopedTvs pty') $ @@ -510,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 @@ -544,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]) } + {- ************************************************************************ * * @@ -567,10 +656,10 @@ unlessXOptM LangExt.StaticPointers $ addErr $ TcRnIllegalStaticExpression e (expr',fvExpr) <- rnLExpr expr - stage <- getStage - case stage of - Splice _ -> addErr $ TcRnIllegalStaticFormInSplice e - _ -> return () + level <- getThLevel + case level of + Splice _ _ -> addErr $ TcRnTHError $ IllegalStaticFormInSplice e + _ -> return () mod <- getModule let fvExpr' = filterNameSet (nameIsLocalOrFrom mod) fvExpr return (HsStatic fvExpr' expr', fvExpr) @@ -588,12 +677,22 @@ { (body',fvBody) <- rnCmdTop body ; return (HsProc x pat' body', fvBody) } -rnExpr other = pprPanic "rnExpr: unexpected expression" (ppr other) - -- HsWrap {- ************************************************************************ * * + Type syntax +* * +********************************************************************* -} + +checkTypeSyntaxExtension :: TypeSyntax -> RnM () +checkTypeSyntaxExtension syntax = + unlessXOptM (typeSyntaxExtension syntax) $ + addErr (TcRnUnexpectedTypeSyntaxInTerms syntax) + +{- +************************************************************************ +* * Operator sections * * ********************************************************************* -} @@ -622,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) } @@ -756,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. @@ -784,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) {- ************************************************************************ @@ -839,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) @@ -861,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 @@ -875,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 @@ -892,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) <- @@ -918,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 @@ -948,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) ------------------------------------------------- @@ -972,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 @@ -1041,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))] @@ -1069,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 } @@ -1077,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)) @@ -1147,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)) @@ -1166,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 [] @@ -1193,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), @@ -1289,51 +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) = removeDups cmpByOcc 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) } - cmpByOcc n1 n2 = nameOccName n1 `compare` nameOccName n2 + 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 @@ -1341,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 @@ -1413,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 @@ -1432,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 @@ -1496,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" @@ -1518,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) @@ -1573,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)] @@ -1587,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) @@ -1727,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] @@ -1745,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] @@ -1761,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 @@ -1813,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 @@ -1954,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 @@ -2038,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] @@ -2059,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 @@ -2098,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 @@ -2119,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) @@ -2134,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 @@ -2170,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 @@ -2221,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) @@ -2237,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] @@ -2259,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] @@ -2305,11 +2410,16 @@ -} -hasRefutablePattern :: DynFlags -> ApplicativeArg GhcRn -> Bool -hasRefutablePattern dflags (ApplicativeArgOne { app_arg_pattern = pat - , is_body_stmt = False}) = - not (isIrrefutableHsPat dflags pat) -hasRefutablePattern _ _ = False +hasRefutablePattern :: Bool -- ^ is -XStrict enabled? + -> HscEnv + -> GlobalRdrEnv + -> CompleteMatches + -> ApplicativeArg GhcRn -> Bool +hasRefutablePattern is_strict hsc_env rdr_env comps arg = + case arg of + ApplicativeArgOne { app_arg_pattern = pat, is_body_stmt = False} + -> not (isIrrefutableHsPat is_strict (irrefutableConLikeRn hsc_env rdr_env comps) pat) + _ -> False isLetStmt :: LStmt (GhcPass a) b -> Bool isLetStmt (L _ LetStmt{}) = True @@ -2349,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) @@ -2393,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 @@ -2408,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 @@ -2429,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) {- @@ -2463,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 @@ -2477,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) @@ -2509,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) @@ -2525,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 @@ -2539,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 @@ -2589,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 () @@ -2609,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 | isIrrefutableHsPat dflags pat -> return (Nothing, emptyFVs) + if | isIrrefutableHsPat strict (irrefutableConLikeRn hscEnv rdrEnv comps) pat + -> return (Nothing, emptyFVs) -- For non-monadic contexts (e.g. guard patterns, list -- comprehensions, etc.) we should not need to fail, or failure is handled in -- a different way. See Note [Failing pattern matches in Stmts]. - | not (isMonadStmtContext ctxt) -> return (Nothing, emptyFVs) + | not (isMonadStmtContext ctxt) + -> return (Nothing, emptyFVs) - | otherwise -> getMonadFailOp ctxt + | otherwise + -> getMonadFailOp ctxt {- Note [Monad fail : Rebindable syntax, overloaded strings] @@ -2661,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 @@ -2673,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) @@ -2691,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. -- @@ -2713,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) @@ -2732,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. @@ -2747,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)] @@ -2777,4 +2908,4 @@ hfbAnn = noAnn , hfbLHS = fmap rnFieldLabelStrings fs , hfbRHS = arg - , hfbPun = pun}), fv ) } + , hfbPun = pun }), fv ) } 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 @@ -24,9 +26,7 @@ import GHC.Types.Fixity.Env import GHC.Types.Name import GHC.Types.Name.Env -import GHC.Types.Name.Reader import GHC.Types.Fixity -import GHC.Types.SourceText import GHC.Types.SrcLoc import GHC.Utils.Outputable @@ -64,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. @@ -107,10 +136,7 @@ -} lookupFixityRn :: Name -> RnM Fixity -lookupFixityRn name = lookupFixityRn' name (nameOccName name) - -lookupFixityRn' :: Name -> OccName -> RnM Fixity -lookupFixityRn' name = fmap snd . lookupFixityRn_help' name +lookupFixityRn = fmap snd . lookupFixityRn_help -- | 'lookupFixityRn_help' returns @(True, fixity)@ if it finds a 'Fixity' -- in a local environment or from an interface file. Otherwise, it returns @@ -118,15 +144,9 @@ -- user-supplied fixity declarations). lookupFixityRn_help :: Name -> RnM (Bool, Fixity) -lookupFixityRn_help name = - lookupFixityRn_help' name (nameOccName name) - -lookupFixityRn_help' :: Name - -> OccName - -> RnM (Bool, Fixity) -lookupFixityRn_help' name occ +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) @@ -144,6 +164,7 @@ then return (False, defaultFixity) else lookup_imported } } } where + occ = nameOccName name lookup_imported -- For imported names, we have to get their fixities by doing a -- loadInterfaceForName, and consulting the Ifaces that comes back @@ -162,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 @@ -180,10 +201,5 @@ lookupTyFixityRn :: LocatedN Name -> RnM Fixity lookupTyFixityRn = lookupFixityRn . unLoc --- | Look up the fixity of an occurrence of a record field selector. --- We use 'lookupFixityRn'' so that we can specify the 'OccName' as --- the field label, which might be different to the 'OccName' of the --- selector 'Name' if @DuplicateRecordFields@ is in use (#1173). lookupFieldFixityRn :: FieldOcc GhcRn -> RnM Fixity -lookupFieldFixityRn (FieldOcc n lrdr) - = lookupFixityRn' n (rdrNameOcc (unLoc lrdr)) +lookupFieldFixityRn (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 @@ -13,23 +13,24 @@ module GHC.Rename.HsType ( -- Type related stuff rnHsType, rnLHsType, rnLHsTypes, rnContext, rnMaybeContext, - rnHsKind, rnLHsKind, rnLHsTypeArgs, - rnHsSigType, rnHsWcType, rnHsPatSigTypeBindingVars, - HsPatSigTypeScoping(..), rnHsSigWcType, rnHsPatSigType, + rnLHsKind, rnLHsTypeArgs, + 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,28 +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.Driver.Session +import GHC.Core.TyCon ( isKindName ) import GHC.Hs import GHC.Rename.Env import GHC.Rename.Doc import GHC.Rename.Utils ( mapFvRn, bindLocalNamesFV - , typeAppErr, newLocalBndrRn, checkDupRdrNamesN - , checkShadowedRdrNames, warnForallIdentifier ) + , typeAppErr, newLocalBndrRn, checkDupRdrNames + , 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 ( pprScopeError - , inHsDocContext, pprHsDocContext ) +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(..) ) @@ -74,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 {- @@ -140,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' }} @@ -151,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 @@ -158,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) @@ -168,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' @@ -181,66 +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 $ mkTcRnUnknownMessage $ mkPlainError noHints $ - vcat - [ text "Type variable" <> plural varsInScope - <+> hcat (punctuate (text ",") (map (quotes . ppr) varsInScope)) - <+> isOrAre varsInScope - <+> text "already in scope." - , text "Type applications in patterns must bind fresh variables, without shadowing." - ] - (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 } @@ -371,7 +342,7 @@ = setSrcSpanA loc $ do { traceRn "rnHsSigType" (ppr sig_ty) ; case outer_bndrs of - HsOuterExplicit{} -> checkPolyKinds env sig_ty + HsOuterExplicit{} -> checkPolyKinds env (HsSigType sig_ty) HsOuterImplicit{} -> pure () ; imp_vars <- filterInScopeM $ extractHsTyRdrTyVars body ; bindHsOuterTyVarBndrs ctx Nothing imp_vars outer_bndrs $ \outer_bndrs' -> @@ -403,7 +374,7 @@ -- See Note [Source locations for implicitly bound type variables]. ; loc <- getSrcSpanM ; let loc' = noAnnSrcSpan loc - ; vars <- mapM (newTyVarNameRn mb_assoc . L loc' . unLoc) implicit_vs + ; vars <- mapM (newTyVarNameRnImplicit mb_assoc . L loc' . unLoc) implicit_vs ; bindLocalNamesFV vars $ thing_inside vars } @@ -431,34 +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 - let msg = mkTcRnUnknownMessage $ mkPlainError noHints $ - text "Variable" <+> text "`" <> ppr x <> text "'" <+> text "would be bound multiple times by" <+> pprHsDocContext ctx <> text "." - addErr msg - 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 @@ -468,35 +411,6 @@ {- rnHsType is here because we call it from loadInstDecl, and I didn't want a gratuitous knot. - -Note [HsQualTy in kinds] -~~~~~~~~~~~~~~~~~~~~~~ -I was wondering whether HsQualTy could occur only at TypeLevel. But no, -we can have a qualified type in a kind too. Here is an example: - - type family F a where - F Bool = Nat - F Nat = Type - - type family G a where - G Type = Type -> Type - G () = Nat - - data X :: forall k1 k2. (F k1 ~ G k2) => k1 -> k2 -> Type where - MkX :: X 'True '() - -See that k1 becomes Bool and k2 becomes (), so the equality is -satisfied. If I write MkX :: X 'True 'False, compilation fails with a -suitable message: - - MkX :: X 'True '() - • Couldn't match kind ‘G Bool’ with ‘Nat’ - Expected kind: G Bool - Actual kind: F Bool - -However: in a kind, the constraints in the HsQualTy must all be -equalities; or at least, any kinds with a class constraint are -uninhabited. See Note [Constraints in kinds] in GHC.Core.TyCo.Rep. -} data RnTyKiEnv @@ -538,32 +452,34 @@ 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 rnLHsKind :: HsDocContext -> LHsKind GhcPs -> RnM (LHsKind GhcRn, FreeVars) rnLHsKind ctxt kind = rnLHsTyKi (mkTyKiEnv ctxt KindLevel RnTypeBody) kind -rnHsKind :: HsDocContext -> HsKind GhcPs -> RnM (HsKind GhcRn, FreeVars) -rnHsKind ctxt kind = rnHsTyKi (mkTyKiEnv ctxt KindLevel RnTypeBody) kind - -- 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) @@ -603,46 +519,54 @@ rnHsTyKi :: RnTyKiEnv -> HsType GhcPs -> RnM (HsType GhcRn, FreeVars) rnHsTyKi env ty@(HsForAllTy { hst_tele = tele, hst_body = tau }) - = do { checkPolyKinds env ty + = do { checkPolyKinds env (HsType ty) ; bindHsForAllTelescope (rtke_ctxt env) tele $ \ tele' -> do { (tau', fvs) <- rnLHsTyKi env tau ; return ( HsForAllTy { hst_xforall = noExtField , hst_tele = tele' , hst_body = tau' } , fvs) } } -rnHsTyKi env ty@(HsQualTy { hst_ctxt = lctxt, hst_body = tau }) - = do { data_kinds <- xoptM LangExt.DataKinds -- See Note [HsQualTy in kinds] - ; when (not data_kinds && isRnKindLevel env) - (addErr (dataKindsErr env ty)) - ; (ctxt', fvs1) <- rnTyKiContext env lctxt +rnHsTyKi env (HsQualTy { hst_ctxt = lctxt, hst_body = tau }) + = do { -- no need to check type vs kind level here; this is + -- checked in the type checker. See + -- Note [No constraints in kinds] in GHC.Tc.Validity + (ctxt', fvs1) <- rnTyKiContext env lctxt ; (tau', fvs2) <- rnLHsTyKi env tau ; return (HsQualTy { hst_xqual = noExtField, hst_ctxt = ctxt' , 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) $ - mkTcRnUnknownMessage $ mkPlainError noHints $ - vcat [ text "Unexpected kind variable" <+> quotes (ppr rdr_name) - , text "Perhaps you intended to use PolyKinds" ] + TcRnUnexpectedKindVar rdr_name -- 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]) } @@ -651,86 +575,58 @@ = 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) - = concatMapM (lookupConstructorFields . unLoc) names - get_fields _ - = do { addErr $ mkTcRnUnknownMessage $ mkPlainError noHints $ - (hang (text "Record syntax is illegal here:") 2 (ppr 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) - ; (ty', lhs_fvs) <- rnLHsTyKi 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 ; return (HsKindSig x ty' k', lhs_fvs `plusFV` sig_fvs) } -- 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 negLitErr) - ; return (HsTyLit src (rnHsTyLit t), emptyFVs) } - where - negLit :: HsTyLit (GhcPass p) -> Bool - negLit (HsStrTy _ _) = False - negLit (HsNumTy _ i) = i < 0 - negLit (HsCharTy _ _) = False - negLitErr :: TcRnMessage - negLitErr = mkTcRnUnknownMessage $ mkPlainError noHints $ - text "Illegal literal in type (type literals must not be negative):" <+> ppr tyLit + = 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 l ty k) +rnHsTyKi env (HsAppKindTy _ ty k) = do { kind_app <- xoptM LangExt.TypeApplications - ; unless kind_app (addErr (typeAppErr "kind" k)) + ; unless kind_app (addErr (typeAppErr KindLevel k)) ; (ty', fvs1) <- rnLHsTyKi env ty ; (k', fvs2) <- rnLHsTyKi (env {rtke_level = KindLevel }) k - ; return (HsAppKindTy l ty' k', fvs1 `plusFV` fvs2) } + ; return (HsAppKindTy noExtField ty' k', fvs1 `plusFV` fvs2) } rnHsTyKi env t@(HsIParamTy x n ty) = do { notInKinds env t @@ -749,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 @@ -759,44 +655,61 @@ check_in_scope :: RdrName -> RnM () check_in_scope rdr_name = do mb_name <- lookupLocalOccRn_maybe rdr_name - -- TODO: refactor this to avoid mkTcRnUnknownMessage when (isNothing mb_name) $ addErr $ TcRnWithHsDocContext (rtke_ctxt env) $ - mkTcRnUnknownMessage $ mkPlainError noHints $ - pprScopeError rdr_name (notInScopeErr WL_LocalOnly 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] @@ -909,6 +822,7 @@ ExprWithTySigCtx {} -> True PatCtx {} -> True RuleCtx {} -> True + SpecECtx {} -> True FamPatCtx {} -> True -- Not named wildcards though GHCiCtx {} -> True HsTypeCtx {} -> True @@ -919,27 +833,22 @@ --------------- -- | Ensures either that we're in a type or that -XPolyKinds is set -checkPolyKinds :: Outputable ty - => RnTyKiEnv - -> ty -- ^ type - -> RnM () +checkPolyKinds :: RnTyKiEnv + -> HsTypeOrSigType GhcPs + -> RnM () checkPolyKinds env ty | isRnKindLevel env = do { polykinds <- xoptM LangExt.PolyKinds ; unless polykinds $ - addErr $ mkTcRnUnknownMessage $ mkPlainError noHints $ - (text "Illegal kind:" <+> ppr ty $$ - text "Did you mean to enable PolyKinds?") } + addErr $ TcRnIllegalKind ty True } checkPolyKinds _ _ = return () -notInKinds :: Outputable ty - => RnTyKiEnv - -> ty +notInKinds :: RnTyKiEnv + -> HsType GhcPs -> RnM () notInKinds env ty | isRnKindLevel env - = addErr $ mkTcRnUnknownMessage $ mkPlainError noHints $ - text "Illegal kind:" <+> ppr ty + = addErr $ TcRnIllegalKind (HsType ty) False notInKinds _ _ = return () {- ***************************************************** @@ -964,11 +873,11 @@ --------------- 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 -> Bool -> RnM (b, FreeVars)) - -- The Bool is True <=> all kind variables used in the + -> (LHsQTyVars GhcRn -> FreeKiTyVars -> RnM (b, FreeVars)) + -- The FreeKiTyVars is null <=> all kind variables used in the -- kind signature are bound on the left. Reason: -- the last clause of Note [CUSKs: complete user-supplied kind signatures] -- in GHC.Hs.Decls @@ -985,14 +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 - all_bound_on_lhs = null body_remaining + ; 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 @@ -1006,7 +920,8 @@ -- This is the only call site for bindLHsTyVarBndrs where we pass -- NoWarnUnusedForalls, which suppresses -Wunused-foralls warnings. -- See Note [Suppress -Wunused-foralls when binding LHsQTyVars]. - do { let -- The SrcSpan that rnImplicitTvOccs will attach to each Name will + do { rn_bndrs <- traverse rnLHsTyVarBndrVisFlag rn_bndrs + ; let -- The SrcSpan that rnImplicitTvOccs will attach to each Name will -- span the entire declaration to which the LHsQTyVars belongs, -- which will be reflected in warning and error messages. We can -- be a little more precise than that by pointing to the location @@ -1017,7 +932,7 @@ ; traceRn "bindHsQTyVars" (ppr hsq_bndrs $$ ppr implicit_kv_nms $$ ppr rn_bndrs) ; thing_inside (HsQTvs { hsq_ext = implicit_kv_nms , hsq_explicit = rn_bndrs }) - all_bound_on_lhs } } + body_remaining } } where hs_tv_bndrs = hsQTvExplicit hsq_bndrs @@ -1034,10 +949,18 @@ -- The in-tree API annotations extend the LHsTyVarBndr location to -- include surrounding parens. for error messages to be -- compatible, we recreate the location from the contents - get_bndr_loc :: LHsTyVarBndr () 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 :: LHsTyVarBndr flag GhcPs -> SrcSpan + 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] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1064,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. @@ -1179,10 +1107,26 @@ -- 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' } +-- See Note [Term variable capture and implicit quantification] +warn_term_var_capture :: LocatedN RdrName -> RnM () +warn_term_var_capture lVar = do + gbl_env <- getGlobalRdrEnv + local_env <- getLocalRdrEnv + case demoteRdrNameTv $ unLoc lVar of + Nothing -> return () + Just demoted_name -> do + let global_vars = lookupGRE gbl_env (LookupRdrName demoted_name SameNameSpace) + let mlocal_var = lookupLocalRdrEnv local_env demoted_name + case mlocal_var of + Just name -> warnCapturedTerm lVar (Right name) + Nothing -> unless (null global_vars) $ + warnCapturedTerm lVar (Left global_vars) + bindHsForAllTelescope :: HsDocContext -> HsForAllTelescope GhcPs -> (HsForAllTelescope GhcRn -> RnM (a, FreeVars)) @@ -1190,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. @@ -1218,10 +1189,10 @@ -> RnM (b, FreeVars) bindLHsTyVarBndrs doc wuf mb_assoc tv_bndrs thing_inside = do { when (isNothing mb_assoc) (checkShadowedRdrNames tv_names_w_loc) - ; checkDupRdrNamesN tv_names_w_loc + ; 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' -> @@ -1239,72 +1210,152 @@ -> 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) -newTyVarNameRn :: Maybe a -- associated class - -> LocatedN RdrName -> RnM Name -newTyVarNameRn mb_assoc lrdr@(L _ rdr) +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 + :: LHsTyVarBndr (HsBndrVis GhcPs) GhcRn + -> RnM (LHsTyVarBndr (HsBndrVis GhcRn) GhcRn) +rnLHsTyVarBndrVisFlag (L loc bndr) = do + let lbndr = L loc (updateHsTyVarBndrFlag rnHsBndrVis bndr) + unlessXOptM LangExt.TypeAbstractions $ do + when (isHsBndrInvisible (hsTyVarBndrFlag bndr)) $ + addErr (TcRnIllegalInvisTyVarBndr lbndr) + when (isHsBndrWildCard (hsBndrVar bndr)) $ + addErr (TcRnIllegalWildcardTyVarBndr lbndr) + return lbndr + +-- rnHsBndrVis is almost a no-op, it simply discards the token for "@". +rnHsBndrVis :: HsBndrVis GhcPs -> HsBndrVis GhcRn +rnHsBndrVis (HsBndrRequired _) = HsBndrRequired noExtField +rnHsBndrVis (HsBndrInvisible _at) = HsBndrInvisible noExtField + +newTyVarNameRn, newTyVarNameRnImplicit + :: Maybe a -- associated class + -> LocatedN RdrName -> RnM Name +newTyVarNameRn mb_assoc = new_tv_name_rn mb_assoc newLocalBndrRn +newTyVarNameRnImplicit mb_assoc = new_tv_name_rn mb_assoc $ \lrdr -> + do { warn_term_var_capture lrdr + ; newLocalBndrRn lrdr } + +new_tv_name_rn :: Maybe a -- associated class + -> (LocatedN RdrName -> RnM Name) -- how to create a new name + -> (LocatedN RdrName -> RnM Name) +new_tv_name_rn Nothing cont lrdr = cont lrdr +new_tv_name_rn (Just _) cont lrdr@(L _ rdr) = do { rdr_env <- getLocalRdrEnv - ; case (mb_assoc, lookupLocalRdrEnv rdr_env rdr) of - (Just _, Just n) -> return n - -- Use the same Name as the parent class decl + ; case lookupLocalRdrEnv rdr_env rdr of + Just n -> return n -- Use the same Name as the parent class decl + _ -> cont lrdr } - _ -> newLocalBndrRn lrdr } +{- Note [Term variable capture and implicit quantification] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-Wterm-variable-capture is a warning introduced in GHC Proposal #281 "Visible forall in types of terms", +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. 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 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 +implicitly quantified type variable (`TvName` becomes `VarName`) and looking it up +in the environment. But when do we call `warn_term_var_capture`? It's tempting +to do so at the start of `rnImplicitTvOccs`, as soon as we know our implicit +variables: + + rnImplicitTvOccs mb_assoc implicit_vs_with_dups thing_inside + = do { let implicit_vs = nubN implicit_vs_with_dups + ; mapM_ warn_term_var_capture implicit_vs + ... } + +This approach generates false positives (#23434) because it misses a corner +case: class variables in associated types. Consider the following example: + + k = 12 + class C k a where + type AT a :: k -> Type + +If we look at the signature for `AT` in isolation, the `k` looks like a free +variable, so it's passed to `rnImplicitTvOccs`. And if we passed it to +`warn_term_var_capture`, we would find the `k` bound by `k = 12` and report a warning. +But we don't want that: `k` is actually bound in the declaration header of the +parent class. + +The solution is to check if it's a class variable (this is done in `new_tv_name_rn`) +before we check for term variable capture. +-} + {- ********************************************************* * * - 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 (flSelector fl) (L lr rdr) + FieldOcc (mkRdrUnqual $ occName sel) (L lr sel) where lbl = occNameFS $ rdrNameOcc rdr - fl = expectJust "lookupField" $ lookupFsEnv fl_env lbl + sel = flSelector + $ expectJust + $ lookupFsEnv fl_env lbl {- ************************************************************************ @@ -1338,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 @@ -1362,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 @@ -1422,25 +1473,13 @@ ---------------------------- --- | 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 - -instance Outputable OpName where - ppr (NormalOp n) = ppr n - ppr NegateOp = ppr negateName - ppr (UnboundOp uv) = ppr uv - ppr (RecFldOp fld) = ppr fld - 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 @@ -1464,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 @@ -1506,7 +1517,7 @@ (NormalOp (unLoc op2),fix2) ; return $ ConPat { pat_con_ext = noExtField - , pat_con = op2 + , pat_con = op2 , pat_args = InfixCon p1 p2 } } @@ -1548,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 @@ -1566,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) @@ -1595,22 +1606,20 @@ _ -> 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) (arg_op, arg_fix) section) --- | Look up the fixity for an operator name. Be careful to use --- 'lookupFieldFixityRn' for record fields (see #13132). +-- | 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 () @@ -1618,35 +1627,21 @@ | is_unbound n1 || is_unbound n2 = return () -- Avoid error cascade | otherwise - = addErr $ mkTcRnUnknownMessage $ mkPlainError noHints $ - hang (text "Precedence parsing error") - 4 (hsep [text "cannot mix", ppr_opfix op1, text "and", - ppr_opfix op2, - text "in the same infix expression"]) + = addErr $ TcRnPrecedenceParsingError op1 op2 sectionPrecErr :: (OpName,Fixity) -> (OpName,Fixity) -> HsExpr GhcPs -> RnM () sectionPrecErr op@(n1,_) arg_op@(n2,_) section | is_unbound n1 || is_unbound n2 = return () -- Avoid error cascade | otherwise - = addErr $ mkTcRnUnknownMessage $ mkPlainError noHints $ - 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))] + = 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 -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) - {- ***************************************************** * * Errors @@ -1655,37 +1650,41 @@ unexpectedPatSigTypeErr :: HsPatSigType GhcPs -> TcRnMessage unexpectedPatSigTypeErr ty - = mkTcRnUnknownMessage $ mkPlainError noHints $ - hang (text "Illegal type signature:" <+> quotes (ppr ty)) - 2 (text "Type signatures are only allowed in patterns with ScopedTypeVariables") + = TcRnUnexpectedPatSigType ty badKindSigErr :: HsDocContext -> LHsType GhcPs -> TcM () badKindSigErr doc (L loc ty) = setSrcSpanA loc $ addErr $ TcRnWithHsDocContext doc $ - mkTcRnUnknownMessage $ mkPlainError noHints $ - hang (text "Illegal kind signature:" <+> quotes (ppr ty)) - 2 (text "Perhaps you intended to use KindSignatures") + TcRnKindSignaturesDisabled (Left ty) -dataKindsErr :: RnTyKiEnv -> HsType GhcPs -> TcRnMessage -dataKindsErr env thing - = mkTcRnUnknownMessage $ mkPlainError noHints $ - hang (text "Illegal" <+> pp_what <> colon <+> quotes (ppr thing)) - 2 (text "Perhaps you intended to use DataKinds") +-- | 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 - pp_what | isRnKindLevel env = text "kind" - | otherwise = text "type" + 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 = mkTcRnUnknownMessage $ - mkPlainDiagnostic (WarningWithFlag Opt_WarnUnusedForalls) noHints $ - vcat [ text "Unused quantified type variable" <+> quotes (ppr tv) - , inHsDocContext doc ] - 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 + = let msg = TcRnCapturedTermName tv shadowed_term_names + in addDiagnosticAt (locA loc) msg + {- ************************************************************************ * * @@ -1754,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 @@ -1762,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 @@ -1789,15 +1791,17 @@ a free variable 'a', which we implicitly quantify over. That is why we can also use it to the left of the double colon: 'Left a -The logic resides in extractHsTyRdrTyVarsKindVars. We use it both for type -synonyms and type family instances. +The logic resides in extractHsTyRdrTyVarsKindVars. -This is something of a stopgap solution until we can explicitly bind invisible +This was a stopgap solution until we could explicitly bind invisible type/kind variables: type TySyn3 :: forall a. Maybe a type TySyn3 @a = 'Just ('Nothing :: Maybe a) +Now that the new syntax was proposed in #425 and implemented in 9.8, we issue a warning +-Wimplicit-rhs-quantification for TySyn2 and TySyn4 and will eventually disallow them. + Note [Implicit quantification in type synonyms: non-taken alternatives] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1844,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 @@ -1913,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 @@ -1923,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: @@ -1940,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 @@ -1955,10 +2072,6 @@ extract_lty (L _ ty) acc = case ty of HsTyVar _ _ ltv -> extract_tv ltv acc - HsBangTy _ _ ty -> extract_lty ty acc - HsRecTy _ flds -> foldr (extract_lty - . cd_fld_type . unLoc) acc - flds HsAppTy _ ty1 ty2 -> extract_lty ty1 $ extract_lty ty2 acc HsAppKindTy _ ty k -> extract_lty ty $ @@ -1966,22 +2079,21 @@ 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_lty ty $ - extract_lty ki acc + HsKindSig _ ty ki -> extract_kind_sig ty ki acc HsForAllTy { hst_tele = tele, hst_body = ty } -> extract_hs_for_all_telescope tele acc $ extract_lty ty [] @@ -1992,14 +2104,26 @@ -- We deal with these separately in rnLHsTypeWithWildCards HsWildCardTy {} -> acc +extract_kind_sig :: LHsType GhcPs -- type + -> LHsType GhcPs -- kind + -> FreeKiTyVars -> FreeKiTyVars +extract_kind_sig ty ki acc + | (L _ HsForAllTy { hst_tele = HsForAllInvis { hsf_invis_bndrs = bndrs } + , hst_body = ki_body }) <- ki + = extract_hs_tv_bndrs bndrs acc $ + extract_lty ty $ + extract_lty ki_body [] +extract_kind_sig ty ki acc + = extract_lty ty $ + extract_lty ki acc + extract_lhs_sig_ty :: LHsSigType GhcPs -> FreeKiTyVars 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 @@ -2020,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 @@ -2036,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 @@ -2047,11 +2179,11 @@ -- 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 = - if isRdrTyVar (unLoc tv) then tv:acc else acc + if isRdrTyVar (unLoc tv) && (not . isQual) (unLoc tv) then tv:acc else acc -- Deletes duplicates in a list of Located things. This is used to: -- diff --git a/GHC/Rename/Module.hs b/GHC/Rename/Module.hs --- a/GHC/Rename/Module.hs +++ b/GHC/Rename/Module.hs @@ -1,2940 +1,2875 @@ {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} - -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} - -{- -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 - -Main pass of renamer --} - -module GHC.Rename.Module ( - rnSrcDecls, addTcgDUs, findSplice, rnWarningTxt - ) where - -import GHC.Prelude hiding ( head ) - -import {-# SOURCE #-} GHC.Rename.Expr( rnLExpr ) -import {-# SOURCE #-} GHC.Rename.Splice ( rnSpliceDecl, rnTopSpliceDecls ) - -import GHC.Hs -import GHC.Types.Error -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 - , checkDupRdrNamesN, bindLocalNamesFV - , checkShadowedRdrNames, warnUnusedTypePatterns - , newLocalBndrsRn - , noNestedForallsContextsErr - , addNoNestedForallsContextsErr, checkInferredVars, warnForallIdentifier ) -import GHC.Rename.Unbound ( mkUnboundName, notInScopeErr, WhereLooking(WL_Global) ) -import GHC.Rename.Names -import GHC.Tc.Errors.Types -import GHC.Tc.Errors.Ppr (pprScopeError) -import GHC.Tc.Gen.Annotation ( annCtxt ) -import GHC.Tc.Utils.Monad - -import GHC.Types.ForeignCall ( CCallTarget(..) ) -import GHC.Unit -import GHC.Unit.Module.Warnings -import GHC.Builtin.Names( applicativeClassName, pureAName, thenAName - , monadClassName, returnMName, thenMName - , semigroupClassName, sappendName - , monoidClassName, mappendName - ) -import GHC.Types.Name -import GHC.Types.Name.Set -import GHC.Types.Name.Env -import GHC.Types.Avail -import GHC.Utils.Outputable -import GHC.Data.Bag -import GHC.Types.Basic ( pprRuleName, TypeOrKind(..) ) -import GHC.Data.FastString -import GHC.Types.SrcLoc as SrcLoc -import GHC.Driver.Session -import GHC.Utils.Misc ( lengthExceeds, partitionWith ) -import GHC.Utils.Panic -import GHC.Driver.Env ( HscEnv(..), hsc_home_unit) -import GHC.Data.List.SetOps ( findDupsEq, removeDups, equivClasses ) -import GHC.Data.Graph.Directed ( SCC, flattenSCC, flattenSCCs, Node(..) - , stronglyConnCompFromEdgedVerticesUniq ) -import GHC.Types.Unique.Set -import GHC.Data.OrdList -import qualified GHC.LanguageExtensions as LangExt -import GHC.Core.DataCon ( isSrcStrict ) - -import Control.Monad -import Control.Arrow ( first ) -import Data.Foldable ( toList ) -import Data.List ( mapAccumL ) -import qualified Data.List.NonEmpty as NE -import Data.List.NonEmpty ( NonEmpty(..), head ) -import Data.Maybe ( isNothing, fromMaybe, mapMaybe ) -import qualified Data.Set as Set ( difference, fromList, toList, null ) -import Data.Function ( on ) - -{- | @rnSourceDecl@ "renames" declarations. -It simultaneously performs dependency analysis and precedence parsing. -It also does the following error checks: - -* Checks that tyvars are used properly. This includes checking - for undefined tyvars, and tyvars in contexts that are ambiguous. - (Some of this checking has now been moved to module @TcMonoType@, - since we don't have functional dependency information at this point.) - -* Checks that all variable occurrences are defined. - -* Checks the @(..)@ etc constraints in the export list. - -Brings the binders of the group into scope in the appropriate places; -does NOT assume that anything is in scope already --} -rnSrcDecls :: HsGroup GhcPs -> RnM (TcGblEnv, HsGroup GhcRn) --- Rename a top-level HsGroup; used for normal source files *and* hs-boot files -rnSrcDecls group@(HsGroup { hs_valds = val_decls, - hs_splcds = splice_decls, - hs_tyclds = tycl_decls, - hs_derivds = deriv_decls, - hs_fixds = fix_decls, - hs_warnds = warn_decls, - hs_annds = ann_decls, - hs_fords = foreign_decls, - hs_defds = default_decls, - hs_ruleds = rule_decls, - hs_docs = docs }) - = do { - -- (A) Process the top-level fixity declarations, creating a mapping from - -- FastStrings to FixItems. Also checks for duplicates. - -- See Note [Top-level fixity signatures in an HsGroup] in GHC.Hs.Decls - local_fix_env <- makeMiniFixityEnv $ hsGroupTopLevelFixitySigs group ; - - -- (B) Bring top level binders (and their fixities) into scope, - -- *except* for the value bindings, which get done in step (D) - -- with collectHsIdBinders. However *do* include - -- - -- * Class ops, data constructors, and record fields, - -- because they do not have value declarations. - -- - -- * For hs-boot files, include the value signatures - -- Again, they have no value declarations - -- - (tc_envs, tc_bndrs) <- getLocalNonValBinders local_fix_env group ; - - - restoreEnvs tc_envs $ do { - - failIfErrsM ; -- No point in continuing if (say) we have duplicate declarations - - -- (D1) Bring pattern synonyms into scope. - -- Need to do this before (D2) because rnTopBindsLHS - -- looks up those pattern synonyms (#9889) - - dup_fields_ok <- xopt_DuplicateRecordFields <$> getDynFlags ; - has_sel <- xopt_FieldSelectors <$> getDynFlags ; - extendPatSynEnv dup_fields_ok has_sel val_decls local_fix_env $ \pat_syn_bndrs -> do { - - -- (D2) Rename the left-hand sides of the value bindings. - -- This depends on everything from (B) being in scope. - -- It uses the fixity env from (A) to bind fixities for view patterns. - - -- We need to throw an error on such value bindings when in a boot file. - is_boot <- tcIsHsBootOrSig ; - new_lhs <- if is_boot - then rnTopBindsLHSBoot local_fix_env val_decls - else rnTopBindsLHS local_fix_env val_decls ; - - -- Bind the LHSes (and their fixities) in the global rdr environment - let { id_bndrs = collectHsIdBinders CollNoDictBinders new_lhs } ; - -- Excludes pattern-synonym binders - -- They are already in scope - traceRn "rnSrcDecls" (ppr id_bndrs) ; - tc_envs <- extendGlobalRdrEnvRn (map avail id_bndrs) local_fix_env ; - restoreEnvs tc_envs $ do { - - -- Now everything is in scope, as the remaining renaming assumes. - - -- (E) Rename type and class decls - -- (note that value LHSes need to be in scope for default methods) - -- - -- You might think that we could build proper def/use information - -- for type and class declarations, but they can be involved - -- in mutual recursion across modules, and we only do the SCC - -- analysis for them in the type checker. - -- So we content ourselves with gathering uses only; that - -- means we'll only report a declaration as unused if it isn't - -- mentioned at all. Ah well. - traceRn "Start rnTyClDecls" (ppr tycl_decls) ; - (rn_tycl_decls, src_fvs1) <- rnTyClDecls tycl_decls ; - - -- (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 - -- 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.) - then rnTopBindsBoot tc_bndrs new_lhs - else rnValBindsRHS (TopSigCtxt val_bndr_set) new_lhs ; - traceRn "finish rnmono" (ppr rn_val_decls) ; - - -- (G) Rename Fixity and deprecations - - -- Rename fixity declarations and error if we try to - -- fix something from another module (duplicates were checked in (A)) - let { all_bndrs = tc_bndrs `unionNameSet` val_bndr_set } ; - rn_fix_decls <- mapM (mapM (rnSrcFixityDecl (TopSigCtxt all_bndrs))) - fix_decls ; - - -- Rename deprec decls; - -- check for duplicates and ensure that deprecated things are defined locally - -- at the moment, we don't keep these around past renaming - rn_warns <- rnSrcWarnDecls all_bndrs warn_decls ; - - -- (H) Rename Everything else - - (rn_rule_decls, src_fvs2) <- setXOptM LangExt.ScopedTypeVariables $ - rnList rnHsRuleDecls rule_decls ; - -- Inside RULES, scoped type variables are on - (rn_foreign_decls, src_fvs3) <- rnList rnHsForeignDecl foreign_decls ; - (rn_ann_decls, src_fvs4) <- rnList rnAnnDecl ann_decls ; - (rn_default_decls, src_fvs5) <- rnList rnDefaultDecl default_decls ; - (rn_deriv_decls, src_fvs6) <- rnList rnSrcDerivDecl deriv_decls ; - (rn_splice_decls, src_fvs7) <- rnList rnSpliceDecl splice_decls ; - rn_docs <- traverse rnLDocDecl docs ; - - last_tcg_env <- getGblEnv ; - -- (I) Compute the results and return - let {rn_group = HsGroup { hs_ext = noExtField, - hs_valds = rn_val_decls, - hs_splcds = rn_splice_decls, - hs_tyclds = rn_tycl_decls, - hs_derivds = rn_deriv_decls, - hs_fixds = rn_fix_decls, - hs_warnds = [], -- warns are returned in the tcg_env - -- (see below) not in the HsGroup - hs_fords = rn_foreign_decls, - hs_annds = rn_ann_decls, - hs_defds = rn_default_decls, - hs_ruleds = rn_rule_decls, - hs_docs = rn_docs } ; - - tcf_bndrs = hsTyClForeignBinders rn_tycl_decls rn_foreign_decls ; - other_def = (Just (mkNameSet tcf_bndrs), emptyNameSet) ; - other_fvs = plusFVs [src_fvs1, src_fvs2, src_fvs3, src_fvs4, - src_fvs5, src_fvs6, src_fvs7] ; - -- It is tiresome to gather the binders from type and class decls - - src_dus = unitOL other_def `plusDU` bind_dus `plusDU` usesOnly other_fvs ; - -- Instance decls may have occurrences of things bound in bind_dus - -- so we must put other_fvs last - - final_tcg_env = let tcg_env' = (last_tcg_env `addTcgDUs` src_dus) - in -- we return the deprecs in the env, not in the HsGroup above - tcg_env' { tcg_warns = tcg_warns tcg_env' `plusWarns` rn_warns }; - } ; - traceRn "finish rnSrc" (ppr rn_group) ; - traceRn "finish Dus" (ppr src_dus ) ; - return (final_tcg_env, rn_group) - }}}} - -addTcgDUs :: TcGblEnv -> DefUses -> TcGblEnv --- This function could be defined lower down in the module hierarchy, --- but there doesn't seem anywhere very logical to put it. -addTcgDUs tcg_env dus = tcg_env { tcg_dus = tcg_dus tcg_env `plusDU` dus } - -rnList :: (a -> RnM (b, FreeVars)) -> [LocatedA a] -> RnM ([LocatedA b], FreeVars) -rnList f xs = mapFvRn (wrapLocFstMA f) xs - -{- -********************************************************* -* * - Source-code deprecations declarations -* * -********************************************************* - -Check that the deprecated names are defined, are defined locally, and -that there are no duplicate deprecations. - -It's only imported deprecations, dealt with in RnIfaces, that we -gather them together. --} - --- checks that the deprecations are defined locally, and that there are no duplicates -rnSrcWarnDecls :: NameSet -> [LWarnDecls GhcPs] -> RnM (Warnings GhcRn) -rnSrcWarnDecls _ [] - = return NoWarnings - -rnSrcWarnDecls bndr_set decls' - = do { -- check for duplicates - ; mapM_ (\ dups -> let ((L loc rdr) :| (lrdr':_)) = dups - in addErrAt (locA loc) (TcRnDuplicateWarningDecls lrdr' rdr)) - warn_rdr_dups - ; pairs_s <- mapM (addLocMA rn_deprec) decls - ; return (WarnSome ((concat pairs_s))) } - where - decls = concatMap (wd_warnings . unLoc) decls' - - sig_ctxt = TopSigCtxt bndr_set - - rn_deprec (Warning _ rdr_names txt) - -- ensures that the names are defined locally - = do { names <- concatMapM (lookupLocalTcNames sig_ctxt what . unLoc) - rdr_names - ; txt' <- rnWarningTxt txt - ; return [(rdrNameOcc rdr, txt') | (rdr, _) <- names] } - - what = text "deprecation" - - warn_rdr_dups = findDupRdrNames - $ concatMap (\(L _ (Warning _ ns _)) -> ns) decls - -rnWarningTxt :: WarningTxt GhcPs -> RnM (WarningTxt GhcRn) -rnWarningTxt (WarningTxt st wst) = do - wst' <- traverse (traverse rnHsDoc) wst - pure (WarningTxt 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)) - --- look for duplicates among the OccNames; --- we check that the names are defined above --- invt: the lists returned by findDupsEq always have at least two elements - -{- -********************************************************* -* * -\subsection{Annotation declarations} -* * -********************************************************* --} - -rnAnnDecl :: AnnDecl GhcPs -> RnM (AnnDecl GhcRn, FreeVars) -rnAnnDecl ann@(HsAnnotation (_, s) provenance expr) - = addErrCtxt (annCtxt ann) $ - do { (provenance', provenance_fvs) <- rnAnnProvenance provenance - ; (expr', expr_fvs) <- setStage (Splice Untyped) $ - rnLExpr expr - ; return (HsAnnotation (noAnn, s) provenance' expr', - provenance_fvs `plusFV` expr_fvs) } - -rnAnnProvenance :: AnnProvenance GhcPs - -> RnM (AnnProvenance GhcRn, FreeVars) -rnAnnProvenance provenance = do - provenance' <- case provenance of - ValueAnnProvenance n -> ValueAnnProvenance - <$> lookupLocatedTopBndrRnN n - TypeAnnProvenance n -> TypeAnnProvenance - <$> lookupLocatedTopConstructorRnN n - ModuleAnnProvenance -> return ModuleAnnProvenance - return (provenance', maybe emptyFVs unitFV (annProvenanceName_maybe provenance')) - -{- -********************************************************* -* * -\subsection{Default declarations} -* * -********************************************************* --} - -rnDefaultDecl :: DefaultDecl GhcPs -> RnM (DefaultDecl GhcRn, FreeVars) -rnDefaultDecl (DefaultDecl _ tys) - = do { (tys', fvs) <- rnLHsTypes doc_str tys - ; return (DefaultDecl noExtField tys', fvs) } - where - doc_str = DefaultDeclCtx - -{- -********************************************************* -* * -\subsection{Foreign declarations} -* * -********************************************************* --} - -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 - ; (ty', fvs) <- rnHsSigType (ForeignDeclCtx name) TypeLevel ty - - -- Mark any PackageTarget style imports as coming from the current package - ; let home_unit = hsc_home_unit topEnv - spec' = patchForeignImport (homeUnitAsUnit home_unit) spec - - ; return (ForeignImport { fd_i_ext = noExtField - , fd_name = name', fd_sig_ty = ty' - , fd_fi = spec' }, fvs) } - -rnHsForeignDecl (ForeignExport { fd_name = name, fd_sig_ty = ty, fd_fe = spec }) - = do { name' <- lookupLocatedOccRn name - ; (ty', fvs) <- rnHsSigType (ForeignDeclCtx name) TypeLevel ty - ; return (ForeignExport { fd_e_ext = noExtField - , fd_name = name', fd_sig_ty = ty' - , fd_fe = (\(CExport x c) -> CExport x c) spec } - , fvs `addOneFV` unLoc name') } - -- NB: a foreign export is an *occurrence site* for name, so - -- we add it to the free-variable list. It might, for example, - -- be imported from another module - --- | For Windows DLLs we need to know what packages imported symbols are from --- to generate correct calls. Imported symbols are tagged with the current --- package, so if they get inlined across a package boundary we'll still --- know where they're from. --- -patchForeignImport :: Unit -> (ForeignImport GhcPs) -> (ForeignImport GhcRn) -patchForeignImport unit (CImport ext cconv safety fs spec) - = CImport ext cconv safety fs (patchCImportSpec unit spec) - -patchCImportSpec :: Unit -> CImportSpec -> CImportSpec -patchCImportSpec unit spec - = case spec of - CFunction callTarget -> CFunction $ patchCCallTarget unit callTarget - _ -> spec - -patchCCallTarget :: Unit -> CCallTarget -> CCallTarget -patchCCallTarget unit callTarget = - case callTarget of - StaticTarget src label Nothing isFun - -> StaticTarget src label (Just unit) isFun - _ -> callTarget - -{- -********************************************************* -* * -\subsection{Instance declarations} -* * -********************************************************* --} - -rnSrcInstDecl :: InstDecl GhcPs -> RnM (InstDecl GhcRn, FreeVars) -rnSrcInstDecl (TyFamInstD { tfid_inst = tfi }) - = do { (tfi', fvs) <- rnTyFamInstDecl (NonAssocTyFamEqn NotClosedTyFam) tfi - ; return (TyFamInstD { tfid_ext = noExtField, tfid_inst = tfi' }, fvs) } - -rnSrcInstDecl (DataFamInstD { dfid_inst = dfi }) - = do { (dfi', fvs) <- rnDataFamInstDecl (NonAssocTyFamEqn NotClosedTyFam) dfi - ; return (DataFamInstD { dfid_ext = noExtField, dfid_inst = dfi' }, fvs) } - -rnSrcInstDecl (ClsInstD { cid_inst = cid }) - = do { traceRn "rnSrcIstDecl {" (ppr cid) - ; (cid', fvs) <- rnClsInstDecl cid - ; traceRn "rnSrcIstDecl end }" empty - ; return (ClsInstD { cid_d_ext = noExtField, cid_inst = cid' }, fvs) } - --- | Warn about non-canonical typeclass instance declarations --- --- A "non-canonical" instance definition can occur for instances of a --- class which redundantly defines an operation its superclass --- provides as well (c.f. `return`/`pure`). In such cases, a canonical --- instance is one where the subclass inherits its method --- implementation from its superclass instance (usually the subclass --- has a default method implementation to that effect). Consequently, --- a non-canonical instance occurs when this is not the case. --- --- See also descriptions of 'checkCanonicalMonadInstances' and --- 'checkCanonicalMonoidInstances' -checkCanonicalInstances :: Name -> LHsSigType GhcRn -> LHsBinds GhcRn -> RnM () -checkCanonicalInstances cls poly_ty mbinds = do - whenWOptM Opt_WarnNonCanonicalMonadInstances - $ checkCanonicalMonadInstances - "https://gitlab.haskell.org/ghc/ghc/-/wikis/proposal/monad-of-no-return" - - whenWOptM Opt_WarnNonCanonicalMonoidInstances - $ checkCanonicalMonoidInstances - "https://gitlab.haskell.org/ghc/ghc/-/wikis/proposal/semigroup-monoid" - - where - -- Warn about unsound/non-canonical 'Applicative'/'Monad' instance - -- declarations. Specifically, the following conditions are verified: - -- - -- In 'Monad' instances declarations: - -- - -- * If 'return' is overridden it must be canonical (i.e. @return = pure@) - -- * If '(>>)' is overridden it must be canonical (i.e. @(>>) = (*>)@) - -- - -- In 'Applicative' instance declarations: - -- - -- * Warn if 'pure' is defined backwards (i.e. @pure = return@). - -- * Warn if '(*>)' is defined backwards (i.e. @(*>) = (>>)@). - -- - checkCanonicalMonadInstances refURL - | cls == applicativeClassName = - forM_ (bagToList mbinds) $ \(L loc mbind) -> setSrcSpanA loc $ - case mbind of - FunBind { fun_id = L _ name - , fun_matches = mg } - | name == pureAName, isAliasMG mg == Just returnMName - -> addWarnNonCanonicalMethod1 refURL - Opt_WarnNonCanonicalMonadInstances "pure" "return" - - | name == thenAName, isAliasMG mg == Just thenMName - -> addWarnNonCanonicalMethod1 refURL - Opt_WarnNonCanonicalMonadInstances "(*>)" "(>>)" - - _ -> return () - - | cls == monadClassName = - forM_ (bagToList mbinds) $ \(L loc mbind) -> setSrcSpanA loc $ - case mbind of - FunBind { fun_id = L _ name - , fun_matches = mg } - | name == returnMName, isAliasMG mg /= Just pureAName - -> addWarnNonCanonicalMethod2 refURL - Opt_WarnNonCanonicalMonadInstances "return" "pure" - - | name == thenMName, isAliasMG mg /= Just thenAName - -> addWarnNonCanonicalMethod2 refURL - Opt_WarnNonCanonicalMonadInstances "(>>)" "(*>)" - - _ -> return () - - | otherwise = return () - - -- Check whether Monoid(mappend) is defined in terms of - -- Semigroup((<>)) (and not the other way round). Specifically, - -- the following conditions are verified: - -- - -- In 'Monoid' instances declarations: - -- - -- * If 'mappend' is overridden it must be canonical - -- (i.e. @mappend = (<>)@) - -- - -- In 'Semigroup' instance declarations: - -- - -- * Warn if '(<>)' is defined backwards (i.e. @(<>) = mappend@). - -- - checkCanonicalMonoidInstances refURL - | cls == semigroupClassName = - forM_ (bagToList mbinds) $ \(L loc mbind) -> setSrcSpanA loc $ - case mbind of - FunBind { fun_id = L _ name - , fun_matches = mg } - | name == sappendName, isAliasMG mg == Just mappendName - -> addWarnNonCanonicalMethod1 refURL - Opt_WarnNonCanonicalMonoidInstances "(<>)" "mappend" - - _ -> return () - - | cls == monoidClassName = - forM_ (bagToList mbinds) $ \(L loc mbind) -> setSrcSpanA loc $ - case mbind of - FunBind { fun_id = L _ name - , fun_matches = mg } - | name == mappendName, isAliasMG mg /= Just sappendName - -> addWarnNonCanonicalMethod2 refURL - Opt_WarnNonCanonicalMonoidInstances - "mappend" "(<>)" - - _ -> return () - - | otherwise = return () - - -- 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 = [] - , m_grhss = grhss })])} - | GRHSs _ [L _ (GRHS _ [] body)] lbinds <- grhss - , EmptyLocalBinds _ <- lbinds - , HsVar _ lrhsName <- unLoc body = Just (unLoc lrhsName) - isAliasMG _ = Nothing - - -- got "lhs = rhs" but expected something different - addWarnNonCanonicalMethod1 refURL flag lhs rhs = do - let dia = mkTcRnUnknownMessage $ - mkPlainDiagnostic (WarningWithFlag flag) noHints $ - vcat [ text "Noncanonical" <+> - quotes (text (lhs ++ " = " ++ rhs)) <+> - text "definition detected" - , instDeclCtxt1 poly_ty - , text "Move definition from" <+> - quotes (text rhs) <+> - text "to" <+> quotes (text lhs) - , text "See also:" <+> - text refURL - ] - addDiagnostic dia - - -- expected "lhs = rhs" but got something else - addWarnNonCanonicalMethod2 refURL flag lhs rhs = do - let dia = mkTcRnUnknownMessage $ - mkPlainDiagnostic (WarningWithFlag flag) noHints $ - vcat [ text "Noncanonical" <+> - quotes (text lhs) <+> - text "definition detected" - , instDeclCtxt1 poly_ty - , quotes (text lhs) <+> - text "will eventually be removed in favour of" <+> - quotes (text rhs) - , text "Either remove definition for" <+> - quotes (text lhs) <+> text "(recommended)" <+> - text "or define as" <+> - quotes (text (lhs ++ " = " ++ rhs)) - , text "See also:" <+> - text refURL - ] - addDiagnostic dia - - -- 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 ".") - - -rnClsInstDecl :: ClsInstDecl GhcPs -> RnM (ClsInstDecl GhcRn, FreeVars) -rnClsInstDecl (ClsInstDecl { 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 inf_err 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 - (text "Instance head") 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' - , mkTcRnUnknownMessage $ mkPlainError noHints $ - hang (text "Illegal head of an instance declaration:" - <+> quotes (ppr head_ty')) - 2 (vcat [ 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" - ]) - ) - -- ...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 - - -- Rename the bindings - -- The typechecker (not the renamer) checks that all - -- the bindings are for the right class - -- (Slightly strangely) when scoped type variables are on, the - -- forall-d tyvars scope over the method bindings too - ; (mbinds', uprags', meth_fvs) <- rnMethodBinds False cls ktv_names mbinds uprags - - ; checkCanonicalInstances cls inst_ty' mbinds' - - -- Rename the associated types, and type signatures - -- Both need to have the instance type variables in scope - ; traceRn "rnSrcInstDecl" (ppr inst_ty' $$ ppr ktv_names) - ; ((ats', adts'), more_fvs) - <- bindLocalNamesFV ktv_names $ - do { (ats', at_fvs) <- rnATInstDecls rnTyFamInstDecl cls ktv_names ats - ; (adts', adt_fvs) <- rnATInstDecls rnDataFamInstDecl cls ktv_names adts - ; return ( (ats', adts'), at_fvs `plusFV` adt_fvs) } - - ; let all_fvs = meth_fvs `plusFV` more_fvs - `plusFV` inst_fvs - ; return (ClsInstDecl { cid_ext = noExtField - , cid_poly_ty = inst_ty', cid_binds = mbinds' - , cid_sigs = uprags', cid_tyfam_insts = ats' - , cid_overlap_mode = oflag - , cid_datafam_insts = adts' }, - all_fvs) } - -- We return the renamed associated data type declarations so - -- that they can be entered into the list of type declarations - -- for the binding group, but we also keep a copy in the instance. - -- The latter is needed for well-formedness checks in the type - -- checker (eg, to ensure that all ATs of the instance actually - -- receive a declaration). - -- NB: Even the copies in the instance declaration carry copies of - -- the instance context after renaming. This is a bit - -- strange, but should not matter (and it would be more work - -- to remove the context). - where - ctxt = GenericCtx $ text "an instance declaration" - inf_err = Just (text "Inferred type variables are not allowed") - - -- 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 - addErrAt l $ TcRnWithHsDocContext ctxt err_msg - pure $ mkUnboundName (mkTcOccFS (fsLit "")) - -rnFamEqn :: HsDocContext - -> AssocTyFamInfo - -> FreeKiTyVars - -- ^ Additional kind variables to implicitly bind if there is no - -- explicit forall. (See the comments on @all_imp_vars@ below for a - -- more detailed explanation.) - -> FamEqn GhcPs rhs - -> (HsDocContext -> rhs -> RnM (rhs', FreeVars)) - -> RnM (FamEqn GhcRn rhs', FreeVars) -rnFamEqn doc atfi extra_kvars - (FamEqn { feqn_tycon = tycon - , feqn_bndrs = outer_bndrs - , feqn_pats = pats - , feqn_fixity = fixity - , feqn_rhs = payload }) rn_payload - = do { tycon' <- lookupFamInstName mb_cls tycon - - -- all_imp_vars represent the implicitly bound type variables. This is - -- empty if we have an explicit `forall` (see - -- Note [forall-or-nothing rule] in GHC.Hs.Type), which means - -- ignoring: - -- - -- - pat_kity_vars, the free variables mentioned in the type patterns - -- on the LHS of the equation, and - -- - extra_kvars, which is one of the following: - -- * For type family instances, extra_kvars are the free kind - -- variables mentioned in an outermost kind signature on the RHS - -- of the equation. - -- (See Note [Implicit quantification in type synonyms] in - -- GHC.Rename.HsType.) - -- * For data family instances, extra_kvars are the free kind - -- variables mentioned in the explicit return kind, if one is - -- provided. (e.g., the `k` in `data instance T :: k -> Type`). - -- - -- Some examples: - -- - -- @ - -- type family F a b - -- type instance forall a b c. F [(a, b)] c = a -> b -> c - -- -- all_imp_vars = [] - -- type instance F [(a, b)] c = a -> b -> c - -- -- all_imp_vars = [a, b, c] - -- - -- type family G :: Maybe a - -- type instance forall a. G = (Nothing :: Maybe a) - -- -- all_imp_vars = [] - -- type instance G = (Nothing :: Maybe a) - -- -- all_imp_vars = [a] - -- - -- data family H :: k -> Type - -- data instance forall k. H :: k -> Type where ... - -- -- all_imp_vars = [] - -- data instance H :: k -> Type where ... - -- -- all_imp_vars = [k] - -- @ - -- - -- For associated type family instances, exclude the type variables - -- bound by the instance head with filterInScopeM (#19649). - ; all_imp_vars <- filterInScopeM $ pat_kity_vars ++ extra_kvars - - ; bindHsOuterTyVarBndrs doc mb_cls all_imp_vars outer_bndrs $ \rn_outer_bndrs -> - do { (pats', pat_fvs) <- rnLHsTypeArgs (FamPatCtx tycon) pats - ; (payload', rhs_fvs) <- rn_payload doc payload - - -- Report unused binders on the LHS - -- See Note [Unused type variables in family instances] - ; let -- The SrcSpan that bindHsOuterFamEqnTyVarBndrs will attach to each - -- implicitly bound type variable Name in outer_bndrs' will - -- span the entire type family instance, which will be reflected in - -- -Wunused-type-patterns warnings. We can be a little more precise - -- than that by pointing to the LHS of the instance instead, which - -- is what lhs_loc corresponds to. - rn_outer_bndrs' = mapHsOuterImplicit (map (`setNameLoc` lhs_loc)) - rn_outer_bndrs - - groups :: [NonEmpty (LocatedN RdrName)] - groups = equivClasses cmpLocated pat_kity_vars - ; nms_dups <- mapM (lookupOccRn . unLoc) $ - [ tv | (tv :| (_:_)) <- groups ] - -- Add to the used variables - -- a) any variables that appear *more than once* on the LHS - -- e.g. F a Int a = Bool - -- b) for associated instances, the variables - -- of the instance decl. See - -- Note [Unused type variables in family instances] - ; let nms_used = extendNameSetList rhs_fvs $ - nms_dups {- (a) -} ++ inst_head_tvs {- (b) -} - all_nms = hsOuterTyVarNames rn_outer_bndrs' - ; warnUnusedTypePatterns all_nms nms_used - - -- For associated family instances, if a type variable from the - -- parent instance declaration is mentioned on the RHS of the - -- associated family instance but not bound on the LHS, then reject - -- that type variable as being out of scope. - -- See Note [Renaming associated types]. - -- Per that Note, the LHS type variables consist of: - -- - -- - The variables mentioned in the instance's type patterns - -- (pat_fvs), and - -- - -- - The variables mentioned in an outermost kind signature on the - -- RHS. This is a subset of `rhs_fvs`. To compute it, we look up - -- each RdrName in `extra_kvars` to find its corresponding Name in - -- the LocalRdrEnv. - ; extra_kvar_nms <- mapMaybeM (lookupLocalOccRn_maybe . unLoc) extra_kvars - ; let lhs_bound_vars = pat_fvs `extendNameSetList` extra_kvar_nms - improperly_scoped cls_tkv = - cls_tkv `elemNameSet` rhs_fvs - -- Mentioned on the RHS... - && not (cls_tkv `elemNameSet` lhs_bound_vars) - -- ...but not bound on the LHS. - bad_tvs = filter improperly_scoped inst_head_tvs - ; unless (null bad_tvs) (badAssocRhs bad_tvs) - - ; let eqn_fvs = rhs_fvs `plusFV` pat_fvs - -- See Note [Type family equations and occurrences] - all_fvs = case atfi of - NonAssocTyFamEqn ClosedTyFam - -> eqn_fvs - _ -> eqn_fvs `addOneFV` unLoc tycon' - - ; return (FamEqn { feqn_ext = noAnn - , feqn_tycon = tycon' - -- Note [Wildcards in family instances] - , feqn_bndrs = rn_outer_bndrs' - , feqn_pats = pats' - , feqn_fixity = fixity - , feqn_rhs = payload' }, - all_fvs) } } - where - -- The parent class, if we are dealing with an associated type family - -- instance. - mb_cls = case atfi of - NonAssocTyFamEqn _ -> Nothing - AssocTyFamDeflt cls -> Just cls - AssocTyFamInst cls _ -> Just cls - - -- The type variables from the instance head, if we are dealing with an - -- associated type family instance. - inst_head_tvs = case atfi of - NonAssocTyFamEqn _ -> [] - AssocTyFamDeflt _ -> [] - AssocTyFamInst _ inst_head_tvs -> inst_head_tvs - - pat_kity_vars = extractHsTyArgRdrKiTyVars pats - -- It is crucial that extractHsTyArgRdrKiTyVars return - -- duplicate occurrences, since they're needed to help - -- determine unused binders on the LHS. - - -- The SrcSpan of the LHS of the instance. For example, lhs_loc would be - -- the highlighted part in the example below: - -- - -- type instance F a b c = Either a b - -- ^^^^^ - lhs_loc = case map lhsTypeArgSrcSpan pats ++ map getLocA extra_kvars of - [] -> panic "rnFamEqn.lhs_loc" - [loc] -> loc - (loc:locs) -> loc `combineSrcSpans` last locs - - badAssocRhs :: [Name] -> RnM () - badAssocRhs ns - = addErr $ mkTcRnUnknownMessage $ mkPlainError noHints $ - (hang (text "The RHS of an associated type declaration mentions" - <+> text "out-of-scope variable" <> plural ns - <+> pprWithCommas (quotes . ppr) ns) - 2 (text "All such variables must be bound on the LHS")) - -rnTyFamInstDecl :: AssocTyFamInfo - -> TyFamInstDecl GhcPs - -> RnM (TyFamInstDecl GhcRn, FreeVars) -rnTyFamInstDecl atfi (TyFamInstDecl { tfid_xtn = x, tfid_eqn = eqn }) - = do { (eqn', fvs) <- rnTyFamInstEqn atfi eqn - ; return (TyFamInstDecl { tfid_xtn = x, tfid_eqn = eqn' }, fvs) } - --- | Tracks whether we are renaming: --- --- 1. A type family equation that is not associated --- with a parent type class ('NonAssocTyFamEqn'). Examples: --- --- @ --- type family F a --- type instance F Int = Bool -- NonAssocTyFamEqn NotClosed --- --- type family G a where --- G Int = Bool -- NonAssocTyFamEqn Closed --- @ --- --- 2. An associated type family default declaration ('AssocTyFamDeflt'). --- Example: --- --- @ --- class C a where --- type A a --- type instance A a = a -> a -- AssocTyFamDeflt C --- @ --- --- 3. An associated type family instance declaration ('AssocTyFamInst'). --- Example: --- --- @ --- instance C a => C [a] where --- type A [a] = Bool -- AssocTyFamInst C [a] --- @ -data AssocTyFamInfo - = NonAssocTyFamEqn - ClosedTyFamInfo -- Is this a closed type family? - | AssocTyFamDeflt - Name -- Name of the parent class - | AssocTyFamInst - Name -- Name of the parent class - [Name] -- Names of the tyvars of the parent instance decl - --- | Tracks whether we are renaming an equation in a closed type family --- equation ('ClosedTyFam') or not ('NotClosedTyFam'). -data ClosedTyFamInfo - = NotClosedTyFam - | ClosedTyFam - -rnTyFamInstEqn :: AssocTyFamInfo - -> TyFamInstEqn GhcPs - -> RnM (TyFamInstEqn GhcRn, FreeVars) -rnTyFamInstEqn atfi eqn@(FamEqn { feqn_tycon = tycon, feqn_rhs = rhs }) - = rnFamEqn (TySynCtx tycon) atfi extra_kvs eqn rnTySyn - where - extra_kvs = extractHsTyRdrTyVarsKindVars rhs - -rnTyFamDefltDecl :: Name - -> TyFamDefltDecl GhcPs - -> RnM (TyFamDefltDecl GhcRn, FreeVars) -rnTyFamDefltDecl cls = rnTyFamInstDecl (AssocTyFamDeflt cls) - -rnDataFamInstDecl :: AssocTyFamInfo - -> DataFamInstDecl GhcPs - -> RnM (DataFamInstDecl GhcRn, FreeVars) -rnDataFamInstDecl atfi (DataFamInstDecl { dfid_eqn = - eqn@(FamEqn { feqn_tycon = tycon - , feqn_rhs = rhs })}) - = do { let extra_kvs = extractDataDefnKindVars rhs - ; (eqn', fvs) <- - rnFamEqn (TyDataCtx tycon) atfi extra_kvs eqn rnDataDefn - ; return (DataFamInstDecl { dfid_eqn = eqn' }, fvs) } - --- Renaming of the associated types in instances. - --- Rename associated type family decl in class -rnATDecls :: Name -- Class - -> [LFamilyDecl GhcPs] - -> RnM ([LFamilyDecl GhcRn], FreeVars) -rnATDecls cls at_decls - = rnList (rnFamDecl (Just cls)) at_decls - -rnATInstDecls :: (AssocTyFamInfo -> -- The function that renames - decl GhcPs -> -- an instance. rnTyFamInstDecl - RnM (decl GhcRn, FreeVars)) -- or rnDataFamInstDecl - -> Name -- Class - -> [Name] - -> [LocatedA (decl GhcPs)] - -> RnM ([LocatedA (decl GhcRn)], FreeVars) --- Used for data and type family defaults in a class decl --- and the family instance declarations in an instance --- --- NB: We allow duplicate associated-type decls; --- See Note [Associated type instances] in GHC.Tc.TyCl.Instance -rnATInstDecls rnFun cls tv_ns at_insts - = rnList (rnFun (AssocTyFamInst cls tv_ns)) at_insts - -- See Note [Renaming associated types] - -{- Note [Wildcards in family instances] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Wild cards can be used in type/data family instance declarations to indicate -that the name of a type variable doesn't matter. Each wild card will be -replaced with a new unique type variable. For instance: - - type family F a b :: * - type instance F Int _ = Int - -is the same as - - type family F a b :: * - type instance F Int b = Int - -This is implemented as follows: Unnamed wildcards remain unchanged after -the renamer, and then given fresh meta-variables during typechecking, and -it is handled pretty much the same way as the ones in partial type signatures. -We however don't want to emit hole constraints on wildcards in family -instances, so we turn on PartialTypeSignatures and turn off warning flag to -let typechecker know this. -See related Note [Wildcards in visible kind application] in GHC.Tc.Gen.HsType - -Note [Unused type variables in family instances] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When the flag -fwarn-unused-type-patterns is on, the compiler reports -warnings about unused type variables in type-family instances. A -tpye variable is considered used (i.e. cannot be turned into a wildcard) -when - - * it occurs on the RHS of the family instance - e.g. type instance F a b = a -- a is used on the RHS - - * it occurs multiple times in the patterns on the LHS - e.g. type instance F a a = Int -- a appears more than once on LHS - - * it is one of the instance-decl variables, for associated types - e.g. instance C (a,b) where - type T (a,b) = a - Here the type pattern in the type instance must be the same as that - for the class instance, so - type T (a,_) = a - would be rejected. So we should not complain about an unused variable b - -As usual, the warnings are not reported for type variables with names -beginning with an underscore. - -Extra-constraints wild cards are not supported in type/data family -instance declarations. - -Relevant tickets: #3699, #10586, #10982 and #11451. - -Note [Renaming associated types] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When renaming a type/data family instance, be it top-level or associated with -a class, we must check that all of the type variables mentioned on the RHS are -properly scoped. Specifically, the rule is this: - - Every variable mentioned on the RHS of a type instance declaration - (whether associated or not) must be either - * Mentioned on the LHS, or - * Mentioned in an outermost kind signature on the RHS - (see Note [Implicit quantification in type synonyms]) - -Here is a simple example of something we should reject: - - class C a b where - type F a x - instance C Int Bool where - type F Int x = z - -Here, `z` is mentioned on the RHS of the associated instance without being -mentioned on the LHS, nor is `z` mentioned in an outermost kind signature. The -renamer will reject `z` as being out of scope without much fuss. - -Things get slightly trickier when the instance header itself binds type -variables. Consider this example (adapted from #5515): - - instance C (p,q) z where - type F (p,q) x = (x, z) - -According to the rule above, this instance is improperly scoped. However, due -to the way GHC's renamer works, `z` is /technically/ in scope, as GHC will -always bring type variables from an instance header into scope over the -associated type family instances. As a result, the renamer won't simply reject -the `z` as being out of scope (like it would for the `type F Int x = z` -example) unless further action is taken. It is important to reject this sort of -thing in the renamer, because if it is allowed to make it through to the -typechecker, unexpected shenanigans can occur (see #18021 for examples). - -To prevent these sorts of shenanigans, we reject programs like the one above -with an extra validity check in rnFamEqn. For each type variable bound in the -parent instance head, we check if it is mentioned on the RHS of the associated -family instance but not bound on the LHS. If any of the instance-head-bound -variables meet these criteria, we throw an error. -(See rnFamEqn.improperly_scoped for how this is implemented.) - -Some additional wrinkles: - -* This Note only applies to *instance* declarations. In *class* declarations - there is no RHS to worry about, and the class variables can all be in scope - (#5862): - - class Category (x :: k -> k -> *) where - type Ob x :: k -> Constraint - id :: Ob x a => x a a - (.) :: (Ob x a, Ob x b, Ob x c) => x b c -> x a b -> x a c - - Here 'k' is in scope in the kind signature, just like 'x'. - -* Although type family equations can bind type variables with explicit foralls, - it need not be the case that all variables that appear on the RHS must be - bound by a forall. For instance, the following is acceptable: - - class C4 a where - type T4 a b - instance C4 (Maybe a) where - type forall b. T4 (Maybe a) b = Either a b - - Even though `a` is not bound by the forall, this is still accepted because `a` - was previously bound by the `instance C4 (Maybe a)` part. (see #16116). - -* In addition to the validity check in rnFamEqn.improperly_scoped, there is an - additional check in GHC.Tc.Validity.checkFamPatBinders that checks each family - instance equation for type variables used on the RHS but not bound on the - LHS. This is not made redundant by rmFamEqn.improperly_scoped, as there are - programs that each check will reject that the other check will not catch: - - - checkValidFamPats is used on all forms of family instances, whereas - rmFamEqn.improperly_scoped only checks associated family instances. Since - checkFamPatBinders occurs after typechecking, it can catch programs that - introduce dodgy scoping by way of type synonyms (see #7536), which is - impractical to accomplish in the renamer. - - rnFamEqn.improperly_scoped catches some programs that, if allowed to escape - the renamer, would accidentally be accepted by the typechecker. Here is one - such program (#18021): - - class C5 a where - data family D a - - instance forall a. C5 Int where - data instance D Int = MkD a - - If this is not rejected in the renamer, the typechecker would treat this - program as though the `a` were existentially quantified, like so: - - data instance D Int = forall a. MkD a - - This is likely not what the user intended! - - Here is another such program (#9574): - - class Funct f where - type Codomain f - instance Funct ('KProxy :: KProxy o) where - type Codomain 'KProxy = NatTr (Proxy :: o -> Type) - - Where: - - data Proxy (a :: k) = Proxy - data KProxy (t :: Type) = KProxy - data NatTr (c :: o -> Type) - - Note that the `o` in the `Codomain 'KProxy` instance should be considered - improperly scoped. It does not meet the criteria for being explicitly - quantified, as it is not mentioned by name on the LHS, nor does it meet the - criteria for being implicitly quantified, as it is used in a RHS kind - signature that is not outermost (see Note [Implicit quantification in type - synonyms]). However, `o` /is/ bound by the instance header, so if this - program is not rejected by the renamer, the typechecker would treat it as - though you had written this: - - instance Funct ('KProxy :: KProxy o) where - type Codomain ('KProxy @o) = NatTr (Proxy :: o -> Type) - - Although this is a valid program, it's probably a stretch too far to turn - `type Codomain 'KProxy = ...` into `type Codomain ('KProxy @o) = ...` here. - If the user really wants the latter, it is simple enough to communicate - their intent by mentioning `o` on the LHS by name. - -Note [Type family equations and occurrences] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In most data/type family equations, the type family name used in the equation -is treated as an occurrence. For example: - - module A where - type family F a - - module B () where - import B (F) - type instance F Int = Bool - -We do not want to warn about `F` being unused in the module `B`, as the -instance constitutes a use site for `F`. The exception to this rule is closed -type families, whose equations constitute a definition, not occurrences. For -example: - - module C () where - type family CF a where - CF Char = Float - -Here, we /do/ want to warn that `CF` is unused in the module `C`, as it is -defined but not used (#18470). - -GHC accomplishes this in rnFamEqn when determining the set of free -variables to return at the end. If renaming a data family or open type family -equation, we add the name of the type family constructor to the set of returned -free variables to ensure that the name is marked as an occurrence. If renaming -a closed type family equation, we avoid adding the type family constructor name -to the free variables. This is quite simple, but it is not a perfect solution. -Consider this example: - - module X () where - type family F a where - F Int = Bool - F Double = F Int - -At present, GHC will treat any use of a type family constructor on the RHS of a -type family equation as an occurrence. Since `F` is used on the RHS of the -second equation of `F`, it is treated as an occurrence, causing `F` not to be -warned about. This is not ideal, since `F` isn't exported—it really /should/ -cause a warning to be emitted. There is some discussion in #10089/#12920 about -how this limitation might be overcome, but until then, we stick to the -simplistic solution above, as it fixes the egregious bug in #18470. --} - - -{- -********************************************************* -* * -\subsection{Stand-alone deriving declarations} -* * -********************************************************* --} - -rnSrcDerivDecl :: DerivDecl GhcPs -> RnM (DerivDecl GhcRn, FreeVars) -rnSrcDerivDecl (DerivDecl _ ty mds overlap) - = do { standalone_deriv_ok <- xoptM LangExt.StandaloneDeriving - ; unless standalone_deriv_ok (addErr standaloneDerivErr) - ; checkInferredVars ctxt inf_err nowc_ty - ; (mds', ty', fvs) <- rnLDerivStrategy ctxt mds $ rnHsSigWcType ctxt 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). - ; addNoNestedForallsContextsErr ctxt - (text "Standalone-derived instance head") - (getLHsInstDeclHead $ dropWildCards ty') - ; warnNoDerivStrat mds' loc - ; return (DerivDecl noAnn ty' mds' overlap, fvs) } - where - ctxt = DerivDeclCtx - inf_err = Just (text "Inferred type variables are not allowed") - loc = getLocA nowc_ty - nowc_ty = dropWildCards ty - -standaloneDerivErr :: TcRnMessage -standaloneDerivErr - = mkTcRnUnknownMessage $ mkPlainError noHints $ - hang (text "Illegal standalone deriving declaration") - 2 (text "Use StandaloneDeriving to enable this extension") - -{- -********************************************************* -* * -\subsection{Rules} -* * -********************************************************* --} - -rnHsRuleDecls :: RuleDecls GhcPs -> RnM (RuleDecls GhcRn, FreeVars) -rnHsRuleDecls (HsRules { rds_ext = (_, src) - , rds_rules = rules }) - = do { (rn_rules,fvs) <- rnList rnHsRuleDecl rules - ; return (HsRules { rds_ext = src - , 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 - ; checkDupRdrNamesN 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' -> - 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 - -{- -Note [Rule LHS validity checking] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Check the shape of a rewrite rule LHS. Currently we only allow -LHSs of the form @(f e1 .. en)@, where @f@ is not one of the -@forall@'d variables. - -We used restrict the form of the 'ei' to prevent you writing rules -with LHSs with a complicated desugaring (and hence unlikely to match); -(e.g. a case expression is not allowed: too elaborate.) - -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. --} - -checkValidRule :: FastString -> [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 - Nothing -> return () - Just bad -> failWithTc (badRuleLhsErr rule_name lhs' bad) - - -- Check that LHS vars are all bound - ; let bad_vars = [var | var <- ids, not (var `elemNameSet` fv_lhs')] - ; mapM_ (addErr . badRuleVar rule_name) bad_vars } - -validRuleLhs :: [Name] -> LHsExpr GhcRn -> Maybe (HsExpr GhcRn) --- Nothing => OK --- Just e => Not ok, and e is the offending sub-expression -validRuleLhs foralls lhs - = checkl lhs - where - checkl = check . unLoc - - 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 (HsVar _ lv) - | (unLoc lv) `notElem` foralls = Nothing - check other = Just other -- Failure - - -- Check an argument - checkl_e _ = Nothing - -- Was (check_e e); see Note [Rule LHS validity checking] - -{- Commented out; see Note [Rule LHS validity checking] above - check_e (HsVar v) = Nothing - check_e (HsPar e) = checkl_e e - check_e (HsLit e) = Nothing - check_e (HsOverLit e) = Nothing - - check_e (OpApp e1 op _ e2) = checkl_e e1 `mplus` checkl_e op `mplus` checkl_e e2 - check_e (HsApp e1 e2) = checkl_e e1 `mplus` checkl_e e2 - check_e (NegApp e _) = checkl_e e - check_e (ExplicitList _ es) = checkl_es es - check_e other = Just other -- Fails - - checkl_es es = foldr (mplus . checkl_e) Nothing es --} - -badRuleVar :: FastString -> Name -> TcRnMessage -badRuleVar name var - = mkTcRnUnknownMessage $ mkPlainError noHints $ - sep [text "Rule" <+> doubleQuotes (ftext name) <> colon, - text "Forall'd variable" <+> quotes (ppr var) <+> - text "does not appear on left hand side"] - -badRuleLhsErr :: FastString -> LHsExpr GhcRn -> HsExpr GhcRn -> TcRnMessage -badRuleLhsErr name lhs bad_e - = mkTcRnUnknownMessage $ mkPlainError noHints $ - 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 bad_e of - HsUnboundVar _ uv -> - pprScopeError uv $ notInScopeErr WL_Global uv - _ -> text "Illegal expression:" <+> ppr bad_e - -{- ************************************************************** - * * - Renaming type, class, instance and role declarations -* * -***************************************************************** - -@rnTyDecl@ uses the `global name function' to create a new type -declaration in which local names have been replaced by their original -names, reporting any unknown names. - -Renaming type variables is a pain. Because they now contain uniques, -it is necessary to pass in an association list which maps a parsed -tyvar to its @Name@ representation. -In some cases (type signatures of values), -it is even necessary to go over the type first -in order to get the set of tyvars used by it, make an assoc list, -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: - -* Improve kind error messages. Consider - - data T f a = MkT f a - data S f a = MkS f (T f a) - - This has a kind error, but the error message is better if you - check T first, (fixing its kind) and *then* S. If you do kind - 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 - -* 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. - -* 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. - -* 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! - - 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@. - ------------------------------------- -So much for WHY. What about HOW? It's pretty easy: - -(1) Rename the type/class, instance, and role declarations - individually - -(2) Do strongly-connected component analysis of the type/class decls, - We'll make a TyClGroup for each SCC - - 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. - - In this step we ignore instances; see - Note [No dependencies on data instances] - -(3) Attach roles to the appropriate SCC - -(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 - -(5) We make an initial TyClGroup, with empty group_tyclds, for any - (orphan) instances that affect only imported types/classes - -Steps (3) and (4) are done by the (mapAccumL mk_group) call. - -Note [No dependencies on data instances] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider this - data family D a - data instance D Int = D1 - data S = MkS (Proxy 'D1) - -Here the declaration of S depends on the /data instance/ declaration -for 'D Int'. That makes things a lot more complicated, especially -if the data instance is an associated type of an enclosing class instance. -(And the class instance might have several associated type instances -with different dependency structure!) - -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 --} - - -rnTyClDecls :: [TyClGroup GhcPs] - -> 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 - ; tycls_w_fvs <- mapM (wrapLocFstMA rnTyClDecl) (tyClGroupTyClDecls tycl_ds) - ; let tc_names = mkNameSet (map (tcdName . unLoc . fst) tycls_w_fvs) - ; kisigs_w_fvs <- rnStandaloneKindSignatures tc_names (tyClGroupKindSigs tycl_ds) - ; 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 - ; rdr_env <- getGlobalRdrEnv - ; let tycl_sccs = depAnalTyClDecls rdr_env kisig_fv_env tycls_w_fvs - role_annot_env = mkRoleAnnotEnv role_annots - (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 - - first_group - | null init_inst_ds = [] - | otherwise = [TyClGroup { group_ext = noExtField - , group_tyclds = [] - , group_kisigs = [] - , group_roles = [] - , group_instds = init_inst_ds }] - - (final_inst_ds, groups) - = mapAccumL (mk_group role_annot_env kisig_env) rest_inst_ds tycl_sccs - - 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 - mk_group :: RoleAnnotEnv - -> KindSigEnv - -> InstDeclFreeVarsMap - -> SCC (LTyClDecl GhcRn) - -> (InstDeclFreeVarsMap, TyClGroup GhcRn) - mk_group role_env kisig_env inst_map scc - = (inst_map', 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 - , group_tyclds = tycl_ds - , group_kisigs = kisigs - , group_roles = roles - , group_instds = inst_ds } - --- | Free variables of standalone kind signatures. -newtype KindSig_FV_Env = KindSig_FV_Env (NameEnv FreeVars) - -lookupKindSig_FV_Env :: KindSig_FV_Env -> Name -> FreeVars -lookupKindSig_FV_Env (KindSig_FV_Env e) name - = fromMaybe emptyFVs (lookupNameEnv e name) - --- | Standalone kind signatures. -type KindSigEnv = NameEnv (LStandaloneKindSig GhcRn) - -mkKindSig_fv_env :: [(LStandaloneKindSig GhcRn, FreeVars)] -> (KindSigEnv, KindSig_FV_Env) -mkKindSig_fv_env kisigs_w_fvs = (kisig_env, kisig_fv_env) - where - kisig_env = mapNameEnv fst compound_env - kisig_fv_env = KindSig_FV_Env (mapNameEnv snd compound_env) - compound_env :: NameEnv (LStandaloneKindSig GhcRn, FreeVars) - = mkNameEnvWith (standaloneKindSigName . unLoc . fst) kisigs_w_fvs - -getKindSigs :: [Name] -> KindSigEnv -> [LStandaloneKindSig GhcRn] -getKindSigs bndrs kisig_env = mapMaybe (lookupNameEnv kisig_env) bndrs - -rnStandaloneKindSignatures - :: NameSet -- names of types and classes in the current TyClGroup - -> [LStandaloneKindSig GhcPs] - -> RnM [(LStandaloneKindSig GhcRn, FreeVars)] -rnStandaloneKindSignatures tc_names kisigs - = do { let (no_dups, dup_kisigs) = removeDups (compare `on` get_name) kisigs - get_name = standaloneKindSigName . unLoc - ; mapM_ dupKindSig_Err dup_kisigs - ; mapM (wrapLocFstMA (rnStandaloneKindSignature tc_names)) no_dups - } - -rnStandaloneKindSignature - :: NameSet -- names of types and classes in the current TyClGroup - -> StandaloneKindSig GhcPs - -> RnM (StandaloneKindSig GhcRn, FreeVars) -rnStandaloneKindSignature tc_names (StandaloneKindSig _ v ki) - = do { standalone_ki_sig_ok <- xoptM LangExt.StandaloneKindSignatures - ; unless standalone_ki_sig_ok $ addErr standaloneKiSigErr - ; new_v <- lookupSigCtxtOccRnN (TopSigCtxt tc_names) (text "standalone kind signature") v - ; let doc = StandaloneKindSigCtx (ppr v) - ; (new_ki, fvs) <- rnHsSigType doc KindLevel ki - ; return (StandaloneKindSig noExtField new_v new_ki, fvs) - } - where - standaloneKiSigErr :: TcRnMessage - standaloneKiSigErr = mkTcRnUnknownMessage $ mkPlainError noHints $ - hang (text "Illegal standalone kind signature") - 2 (text "Did you mean to enable StandaloneKindSignatures?") - -depAnalTyClDecls :: GlobalRdrEnv - -> KindSig_FV_Env - -> [(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 - = stronglyConnCompFromEdgedVerticesUniq edges - where - edges :: [ Node Name (LTyClDecl GhcRn) ] - edges = [ DigraphNode d name (map (getParent rdr_env) (nonDetEltsUniqSet deps)) - | (d, fvs) <- ds_w_fvs, - let { name = tcdName (unLoc d) - ; kisig_fvs = lookupKindSig_FV_Env kisig_fv_env name - ; deps = fvs `plusFV` kisig_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 - = nonDetStrictFoldUniqSet add emptyNameSet ns - -- It's OK to use a non-deterministic fold because we immediately forget the - -- ordering by creating a set - where - add n s = extendNameSet s (getParent rdr_env n) - -getParent :: GlobalRdrEnv -> Name -> Name -getParent rdr_env n - = case lookupGRE_Name rdr_env n of - Just gre -> case gre_par gre of - ParentIs { par_is = p } -> p - _ -> n - Nothing -> n - - -{- ****************************************************** -* * - Role annotations -* * -****************************************************** -} - --- | Renames role annotations, returning them as the values in a NameEnv --- and checks for duplicate role annotations. --- It is quite convenient to do both of these in the same place. --- See also Note [Role annotations in the renamer] -rnRoleAnnots :: NameSet - -> [LRoleAnnotDecl GhcPs] - -> RnM [LRoleAnnotDecl GhcRn] -rnRoleAnnots tc_names role_annots - = do { -- Check for duplicates *before* renaming, to avoid - -- lumping together all the unboundNames - let (no_dups, dup_annots) = removeDups (compare `on` get_name) role_annots - get_name = roleAnnotDeclName . unLoc - ; mapM_ dupRoleAnnotErr dup_annots - ; mapM (wrapLocMA rn_role_annot1) no_dups } - where - rn_role_annot1 (RoleAnnotDecl _ tycon roles) - = do { -- the name is an *occurrence*, but look it up only in the - -- decls defined in this group (see #10263) - tycon' <- lookupSigCtxtOccRnN (RoleAnnotCtxt tc_names) - (text "role annotation") - tycon - ; return $ RoleAnnotDecl noExtField tycon' roles } - -dupRoleAnnotErr :: NonEmpty (LRoleAnnotDecl GhcPs) -> RnM () -dupRoleAnnotErr list - = addErrAt (locA loc) $ mkTcRnUnknownMessage $ mkPlainError noHints $ - 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 loc first_decl) :| _) = sorted_list - - pp_role_annot (L loc decl) = hang (ppr decl) - 4 (text "-- written at" <+> ppr (locA loc)) - - cmp_loc = SrcLoc.leftmost_smallest `on` getLocA - -dupKindSig_Err :: NonEmpty (LStandaloneKindSig GhcPs) -> RnM () -dupKindSig_Err list - = addErrAt (locA loc) $ mkTcRnUnknownMessage $ mkPlainError noHints $ - 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 loc first_decl) :| _) = sorted_list - - pp_kisig (L loc decl) = - hang (ppr decl) 4 (text "-- written at" <+> ppr (locA loc)) - - cmp_loc = SrcLoc.leftmost_smallest `on` getLocA - -{- Note [Role annotations in the renamer] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We must ensure that a type's role annotation is put in the same group as the -proper type declaration. This is because role annotations are needed during -type-checking when creating the type's TyCon. So, rnRoleAnnots builds a -NameEnv (LRoleAnnotDecl Name) that maps a name to a role annotation for that -type, if any. Then, this map can be used to add the role annotations to the -groups after dependency analysis. - -This process checks for duplicate role annotations, where we must be careful -to do the check *before* renaming to avoid calling all unbound names duplicates -of one another. - -The renaming process, as usual, might identify and report errors for unbound -names. This is done by using lookupSigCtxtOccRn in rnRoleAnnots (using -lookupGlobalOccRn led to #8485). --} - - -{- ****************************************************** -* * - Dependency info for instances -* * -****************************************************** -} - ----------------------------------------------------------- --- | '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 - 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 - -{- ****************************************************** -* * - Renaming a type or class declaration -* * -****************************************************** -} - -rnTyClDecl :: TyClDecl GhcPs - -> RnM (TyClDecl GhcRn, FreeVars) - --- All flavours of top-level type family declarations ("type family", "newtype --- family", and "data family") -rnTyClDecl (FamDecl { tcdFam = fam }) - = do { (fam', fvs) <- rnFamDecl Nothing fam - ; return (FamDecl noExtField fam', fvs) } - -rnTyClDecl (SynDecl { tcdLName = tycon, tcdTyVars = tyvars, - tcdFixity = fixity, tcdRhs = rhs }) - = do { tycon' <- lookupLocatedTopConstructorRnN tycon - ; let kvs = extractHsTyRdrTyVarsKindVars rhs - doc = TySynCtx tycon - ; traceRn "rntycl-ty" (ppr tycon <+> ppr kvs) - ; bindHsQTyVars doc Nothing kvs tyvars $ \ tyvars' _ -> - do { (rhs', fvs) <- rnTySyn doc rhs - ; return (SynDecl { tcdLName = tycon', tcdTyVars = tyvars' - , tcdFixity = fixity - , tcdRhs = rhs', tcdSExt = fvs }, fvs) } } - --- "data", "newtype" declarations -rnTyClDecl (DataDecl - { tcdLName = tycon, tcdTyVars = tyvars, - tcdFixity = fixity, - tcdDataDefn = defn@HsDataDefn{ dd_cons = cons, dd_kindSig = kind_sig} }) - = do { tycon' <- lookupLocatedTopConstructorRnN tycon - ; let kvs = extractDataDefnKindVars defn - doc = TyDataCtx tycon - new_or_data = dataDefnConsNewOrData cons - ; traceRn "rntycl-data" (ppr tycon <+> ppr kvs) - ; bindHsQTyVars doc Nothing kvs tyvars $ \ tyvars' no_rhs_kvs -> - do { (defn', fvs) <- rnDataDefn doc defn - ; cusk <- data_decl_has_cusk tyvars' new_or_data no_rhs_kvs kind_sig - ; let rn_info = DataDeclRn { tcdDataCusk = cusk - , tcdFVs = fvs } - ; traceRn "rndata" (ppr tycon <+> ppr cusk <+> ppr no_rhs_kvs) - ; return (DataDecl { tcdLName = tycon' - , tcdTyVars = tyvars' - , tcdFixity = fixity - , tcdDataDefn = defn' - , tcdDExt = rn_info }, fvs) } } - -rnTyClDecl (ClassDecl { tcdLayout = layout, - 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 - ; let cls' = unLoc lcls' - kvs = [] -- No scoped kind vars except those in - -- kind signatures on the tyvars - - -- Tyvars scope over superclass context and method signatures - ; ((tyvars', context', fds', ats'), stuff_fvs) - <- bindHsQTyVars cls_doc Nothing kvs tyvars $ \ tyvars' _ -> do - -- Checks for distinct tyvars - { (context', cxt_fvs) <- rnMaybeContext cls_doc context - ; fds' <- rnFds fds - -- The fundeps have no free variables - ; (ats', fv_ats) <- rnATDecls cls' ats - ; let fvs = cxt_fvs `plusFV` - fv_ats - ; return ((tyvars', context', fds', ats'), fvs) } - - ; (at_defs', fv_at_defs) <- rnList (rnTyFamDefltDecl cls') at_defs - - -- No need to check for duplicate associated type decls - -- since that is done by GHC.Rename.Names.extendGlobalRdrEnvRn - - -- Check the signatures - -- First process the class op sigs (op_sigs), then the fixity sigs (non_op_sigs). - ; let sig_rdr_names_w_locs = - [op | L _ (ClassOpSig _ False ops _) <- sigs - , op <- ops] - ; checkDupRdrNamesN sig_rdr_names_w_locs - -- Typechecker is responsible for checking that we only - -- give default-method bindings for things in this class. - -- The renamer *could* check this for class decls, but can't - -- for instance decls. - - -- The newLocals call is tiresome: given a generic class decl - -- class C a where - -- op :: a -> a - -- op {| x+y |} (Inl a) = ... - -- op {| x+y |} (Inr b) = ... - -- op {| a*b |} (a*b) = ... - -- we want to name both "x" tyvars with the same unique, so that they are - -- easy to group together in the typechecker. - ; (mbinds', sigs', meth_fvs) - <- rnMethodBinds True cls' (hsAllLTyVarNames tyvars') mbinds sigs - -- No need to check for duplicate method signatures - -- since that is done by GHC.Rename.Names.extendGlobalRdrEnvRn - -- and the methods are already in scope - - ; 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', - tcdTyVars = tyvars', tcdFixity = fixity, - tcdFDs = fds', tcdSigs = sigs', - tcdMeths = mbinds', tcdATs = ats', tcdATDefs = at_defs', - tcdDocs = docs', tcdCExt = all_fvs }, - all_fvs ) } - 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 - { -- See Note [Unlifted Newtypes and CUSKs], and for a broader - -- picture, see Note [Implementation of UnliftedNewtypes]. - ; unlifted_newtypes <- xoptM LangExt.UnliftedNewtypes - ; let non_cusk_newtype - | NewType <- new_or_data = - unlifted_newtypes && isNothing kind_sig - | otherwise = False - -- See Note [CUSKs: complete user-supplied kind signatures] in GHC.Hs.Decls - ; return $ hsTvbAllKinded tyvars && no_rhs_kvs && not non_cusk_newtype - } - -{- Note [Unlifted Newtypes and CUSKs] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When unlifted newtypes are enabled, a newtype must have a kind signature -in order to be considered have a CUSK. This is because the flow of -kind inference works differently. Consider: - - newtype Foo = FooC Int - -When UnliftedNewtypes is disabled, we decide that Foo has kind -`TYPE 'LiftedRep` without looking inside the data constructor. So, we -can say that Foo has a CUSK. However, when UnliftedNewtypes is enabled, -we fill in the kind of Foo as a metavar that gets solved by unification -with the kind of the field inside FooC (that is, Int, whose kind is -`TYPE 'LiftedRep`). But since we have to look inside the data constructors -to figure out the kind signature of Foo, it does not have a CUSK. - -See Note [Implementation of UnliftedNewtypes] for where this fits in to -the broader picture of UnliftedNewtypes. --} - --- "type" and "type instance" declarations -rnTySyn :: HsDocContext -> LHsType GhcPs -> RnM (LHsType GhcRn, FreeVars) -rnTySyn doc rhs = rnLHsType doc rhs - -rnDataDefn :: HsDocContext -> HsDataDefn GhcPs - -> RnM (HsDataDefn GhcRn, FreeVars) -rnDataDefn doc (HsDataDefn { dd_cType = cType, dd_ctxt = context, dd_cons = condecls - , dd_kindSig = m_sig, dd_derivs = derivs }) - = do { -- DatatypeContexts (i.e., stupid contexts) can't be combined with - -- GADT syntax. See Note [The stupid context] in GHC.Core.DataCon. - checkTc (h98_style || null (fromMaybeContext context)) - (badGadtStupidTheta doc) - - -- Check restrictions on "type data" declarations. - -- See Note [Type data declarations]. - ; when (isTypeDataDefnCons condecls) check_type_data - - ; (m_sig', sig_fvs) <- case m_sig of - Just sig -> first Just <$> rnLHsKind doc sig - Nothing -> return (Nothing, emptyFVs) - ; (context', fvs1) <- rnMaybeContext doc context - ; (derivs', fvs3) <- rn_derivs derivs - - -- For the constructor declarations, drop the LocalRdrEnv - -- in the GADT case, where the type variables in the declaration - -- do not scope over the constructor signatures - -- data T a where { T1 :: forall b. b-> b } - ; let { zap_lcl_env | h98_style = \ thing -> thing - | otherwise = setLocalRdrEnv emptyLocalRdrEnv } - ; (condecls', con_fvs) <- zap_lcl_env $ rnConDecls condecls - -- No need to check for duplicate constructor decls - -- since that is done by GHC.Rename.Names.extendGlobalRdrEnvRn - - ; let all_fvs = fvs1 `plusFV` fvs3 `plusFV` - con_fvs `plusFV` sig_fvs - ; return ( HsDataDefn { dd_ext = noExtField, dd_cType = cType - , dd_ctxt = context', dd_kindSig = m_sig' - , dd_cons = condecls' - , dd_derivs = derivs' } - , all_fvs ) - } - where - h98_style = not $ anyLConIsGadt condecls -- Note [Stupid theta] - - rn_derivs ds - = do { deriv_strats_ok <- xoptM LangExt.DerivingStrategies - ; failIfTc (lengthExceeds ds 1 && not deriv_strats_ok) - multipleDerivClausesErr - ; (ds', fvs) <- mapFvRn (rnLHsDerivingClause doc) ds - ; return (ds', fvs) } - - -- Given a "type data" declaration, check that the TypeData extension - -- is enabled and check restrictions (R1), (R2), (R3) and (R5) - -- on the declaration. See Note [Type data declarations]. - check_type_data - = do { unlessXOptM LangExt.TypeData $ failWith TcRnIllegalTypeData - ; unless (null (fromMaybeContext context)) $ - failWith $ TcRnTypeDataForbids TypeDataForbidsDatatypeContexts - ; mapM_ (addLocMA check_type_data_condecl) condecls - ; unless (null derivs) $ - failWith $ TcRnTypeDataForbids TypeDataForbidsDerivingClauses - } - - -- Check restrictions (R2) and (R3) on a "type data" constructor. - -- See Note [Type data declarations]. - check_type_data_condecl :: ConDecl GhcPs -> RnM () - check_type_data_condecl condecl - = do { - ; when (has_labelled_fields condecl) $ - failWith $ TcRnTypeDataForbids TypeDataForbidsLabelledFields - ; when (has_strictness_flags condecl) $ - failWith $ TcRnTypeDataForbids TypeDataForbidsStrictnessAnnotations - } - - has_labelled_fields (ConDeclGADT { con_g_args = RecConGADT _ _ }) = True - has_labelled_fields (ConDeclH98 { con_args = RecCon rec }) - = not (null (unLoc rec)) - has_labelled_fields _ = False - - has_strictness_flags condecl - = any (is_strict . getBangStrictness . hsScaledThing) (con_args condecl) - - is_strict (HsSrcBang _ _ s) = isSrcStrict s - - 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 _ = [] - -{- -Note [Type data declarations] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -With the TypeData extension (GHC proposal #106), one can write `type data` -declarations, like - - type data Nat = Zero | Succ Nat - -or equivalently in GADT style: - - type data Nat where - Zero :: Nat - Succ :: Nat -> Nat - -This defines the constructors `Zero` and `Succ` in the TcCls namespace -(type constructors and classes) instead of the Data namespace (data -constructors). This contrasts with the DataKinds extension, which -allows constructors defined in the Data namespace to be promoted to the -TcCls namespace at the point of use in a type. - -Type data declarations have the syntax of `data` declarations (but not -`newtype` declarations), either ordinary algebraic data types or GADTs, -preceded by `type`, with the following restrictions: - -(R0) 'data' decls only, not 'newtype' decls. This is checked by - the parser. - -(R1) There are no data type contexts (even with the DatatypeContexts - extension). - -(R2) There are no labelled fields. Perhaps these could be supported - using type families, but they are omitted for now. - -(R3) There are no strictness flags, because they don't make sense at - the type level. - -(R4) The types of the constructors contain no constraints other than - equality constraints. (This is the same restriction imposed - on constructors to be promoted with the DataKinds extension in - dc_theta_illegal_constraint called from GHC.Tc.Gen.HsType.tcTyVar, - but in that case the restriction is imposed if and when a data - constructor is used in a type, whereas here it is imposed at - the point of definition. See also Note [Constraints in kinds] - in GHC.Core.TyCo.Rep.) - -(R5) There are no deriving clauses. - -The data constructors of a `type data` declaration obey the following -Core invariant: - -(I1) The data constructors of a `type data` declaration may be mentioned in - /types/, but never in /terms/ or the /pattern of a case alternative/. - -Wrinkles: - -(W0) Wrappers. The data constructor of a `type data` declaration has a worker - (like every data constructor) but does /not/ have a wrapper. Wrappers - only make sense for value-level data constructors. Indeed, the worker Id - is never used (invariant (I1)), so it barely makes sense to talk about - the worker. A `type data` constructor only shows up in types, where it - appears as a TyCon, specifically a PromotedDataCon -- no Id in sight. - See #24620 for an example of what happens if you accidentally include - a wrapper. - - See `wrapped_reqd` in GHC.Types.Id.Make.mkDataConRep` for the place where - this check is implemented. - - This specifically includes `type data` declarations implemented as GADTs, - such as this example from #22948: - - type data T a where - A :: T Int - B :: T a - - If `T` were an ordinary `data` declaration, then `A` would have a wrapper - to account for the GADT-like equality in its return type. Because `T` is - declared as a `type data` declaration, however, the wrapper is omitted. - -(W1) To prevent users from conjuring up `type data` values at the term level, - we disallow using the tagToEnum# function on a type headed by a `type - data` type. For instance, GHC will reject this code: - - type data Letter = A | B | C - - f :: Letter - f = tagToEnum# 0# - - See `GHC.Tc.Gen.App.checkTagToEnum`, specifically `check_enumeration`. - -(W2) Although `type data` data constructors do not exist at the value level, - it is still possible to match on a value whose type is headed by a `type data` - type constructor, such as this example from #22964: - - type data T a where - A :: T Int - B :: T a - - f :: T a -> () - f x = case x of {} - - And yet we must guarantee invariant (I1). This has three consequences: - - (W2a) During checking the coverage of `f`'s pattern matches, we treat `T` - as if it were an empty data type so that GHC does not warn the user - to match against `A` or `B`. (Otherwise, you end up with the bug - reported in #22964.) See GHC.HsToCore.Pmc.Solver.vanillaCompleteMatchTC. - - (W2b) In `GHC.Core.Utils.refineDataAlt`, do /not/ fill in the DEFAULT case - 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`, 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 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. - -The main parts of the implementation are: - -* (R0): The parser recognizes `type data` (but not `type newtype`). - -* During the initial construction of the AST, - GHC.Parser.PostProcess.checkNewOrData sets the `Bool` argument of the - `DataTypeCons` inside a `HsDataDefn` to mark a `type data` declaration. - It also puts the the constructor names (`Zero` and `Succ` in our - example) in the TcCls namespace. - -* GHC.Rename.Module.rnDataDefn calls `check_type_data` on these - declarations, which checks that the TypeData extension is enabled and - checks restrictions (R1), (R2), (R3) and (R5). They could equally - well be checked in the typechecker, but we err on the side of catching - imposters early. - -* GHC.Tc.TyCl.checkValidDataCon checks restriction (R4) on these declarations. - -* When beginning to type check a mutually recursive group of declarations, - the `type data` constructors (`Zero` and `Succ` in our example) are - added to the type-checker environment as `APromotionErr TyConPE` by - GHC.Tc.TyCl.mkPromotionErrorEnv, so they cannot be used within the - recursive group. This mirrors the DataKinds behaviour described - at Note [Recursion and promoting data constructors] in GHC.Tc.TyCl. - For example, this is rejected: - - type data T f = K (f (K Int)) -- illegal: tycon K is recursively defined - -* The `type data` data type, such as `Nat` in our example, is represented - by a `TyCon` that is an `AlgTyCon`, but its `AlgTyConRhs` has the - `is_type_data` field set. - -* The constructors of the data type, `Zero` and `Succ` in our example, - are each represented by a `DataCon` as usual. That `DataCon`'s - `dcPromotedField` is a `TyCon` (for `Zero`, say) that you can use - in a type. - -* After a `type data` declaration has been type-checked, the - type-checker environment entry (a `TyThing`) for each constructor - (`Zero` and `Succ` in our example) is - - just an `ATyCon` for the promoted type constructor, - - not the bundle (`ADataCon` for the data con, `AnId` for the work id, - wrap id) required for a normal data constructor - See GHC.Types.TyThing.implicitTyConThings. - -* GHC.Core.TyCon.isDataKindsPromotedDataCon ignores promoted constructors - 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` - declaration (by checking the `is_type_data` field), so that these do - not contribute executable code such as constructor wrappers. - -* The `is_type_data` field is copied into a Boolean argument - of the `IfDataTyCon` constructor of `IfaceConDecls` by - GHC.Iface.Make.tyConToIfaceDecl. - -* The Template Haskell `Dec` type has an constructor `TypeDataD` for - `type data` declarations. When these are converted back to Hs types - in a splice, the constructors are placed in the TcCls namespace. - -* A `type data` declaration _never_ generates wrappers for its data - constructors, as they only make sense for value-level data constructors. - See `wrapped_reqd` in GHC.Types.Id.Make.mkDataConRep` for the place where - this check is implemented. - - This includes `type data` declarations implemented as GADTs, such as - this example from #22948: - - type data T a where - A :: T Int - B :: T a - - If `T` were an ordinary `data` declaration, then `A` would have a wrapper - to account for the GADT-like equality in its return type. Because `T` is - declared as a `type data` declaration, however, the wrapper is omitted. - -* Although `type data` data constructors do not exist at the value level, - it is still possible to match on a value whose type is headed by a `type data` - type constructor, such as this example from #22964: - - type data T a where - A :: T Int - B :: T a - - f :: T a -> () - f x = case x of {} - - This has two consequences: - - * During checking the coverage of `f`'s pattern matches, we treat `T` as if it - were an empty data type so that GHC does not warn the user to match against - `A` or `B`. (Otherwise, you end up with the bug reported in #22964.) - See GHC.HsToCore.Pmc.Solver.vanillaCompleteMatchTC. - - * In `GHC.Core.Utils.refineDataAlt`, do /not/ fill in the DEFAULT case with - the data constructor. See - Note [Refine DEFAULT case alternatives] Exception 2, in GHC.Core.Utils. - -* To prevent users from conjuring up `type data` values at the term level, we - disallow using the tagToEnum# function on a type headed by a `type data` - type. For instance, GHC will reject this code: - - type data Letter = A | B | C - - f :: Letter - f = tagToEnum# 0# - - See `GHC.Tc.Gen.App.checkTagToEnum`, specifically `check_enumeration`. --} - -warnNoDerivStrat :: Maybe (LDerivStrategy GhcRn) - -> SrcSpan - -> RnM () -warnNoDerivStrat mds loc - = do { dyn_flags <- getDynFlags - ; case mds of - Nothing -> - let dia = mkTcRnUnknownMessage $ - mkPlainDiagnostic (WarningWithFlag Opt_WarnMissingDerivingStrategies) noHints $ - (if xopt LangExt.DerivingStrategies dyn_flags - then no_strat_warning - else no_strat_warning $+$ deriv_strat_nenabled - ) - in addDiagnosticAt loc dia - _ -> pure () - } - where - no_strat_warning :: SDoc - no_strat_warning = text "No deriving strategy specified. Did you want stock" - <> text ", newtype, or anyclass?" - deriv_strat_nenabled :: SDoc - deriv_strat_nenabled = text "Use DerivingStrategies to specify a strategy." - -rnLHsDerivingClause :: HsDocContext -> LHsDerivingClause GhcPs - -> RnM (LHsDerivingClause GhcRn, FreeVars) -rnLHsDerivingClause doc - (L loc (HsDerivingClause - { deriv_clause_ext = noExtField - , deriv_clause_strategy = dcs - , 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' }) - , fvs ) } - where - rn_deriv_clause_tys :: LDerivClauseTys GhcPs - -> RnM (LDerivClauseTys GhcRn, FreeVars) - rn_deriv_clause_tys (L l dct) = case dct of - DctSingle x ty -> do - (ty', fvs) <- rn_clause_pred ty - pure (L l (DctSingle x ty'), fvs) - DctMulti x tys -> do - (tys', fvs) <- mapFvRn rn_clause_pred tys - pure (L l (DctMulti x tys'), fvs) - - rn_clause_pred :: LHsSigType GhcPs -> RnM (LHsSigType GhcRn, FreeVars) - rn_clause_pred pred_ty = do - let inf_err = Just (text "Inferred type variables are not allowed") - checkInferredVars doc inf_err pred_ty - ret@(pred_ty', _) <- rnHsSigType doc TypeLevel pred_ty - -- Check if there are any nested `forall`s, which are illegal in a - -- `deriving` clause. - -- See Note [No nested foralls or contexts in instance types] - -- (Wrinkle: Derived instances) in GHC.Hs.Type. - addNoNestedForallsContextsErr doc (text "Derived class type") - (getLHsInstDeclHead pred_ty') - pure ret - -rnLDerivStrategy :: forall a. - HsDocContext - -> Maybe (LDerivStrategy GhcPs) - -> RnM (a, FreeVars) - -> RnM (Maybe (LDerivStrategy GhcRn), a, FreeVars) -rnLDerivStrategy doc mds thing_inside - = case mds of - Nothing -> boring_case Nothing - Just (L loc ds) -> - setSrcSpanA loc $ do - (ds', thing, fvs) <- rn_deriv_strat ds - pure (Just (L loc ds'), thing, fvs) - where - rn_deriv_strat :: DerivStrategy GhcPs - -> RnM (DerivStrategy GhcRn, a, FreeVars) - rn_deriv_strat ds = do - let extNeeded :: LangExt.Extension - extNeeded - | ViaStrategy{} <- ds - = LangExt.DerivingVia - | otherwise - = LangExt.DerivingStrategies - - unlessXOptM extNeeded $ - failWith $ illegalDerivStrategyErr ds - - case ds of - StockStrategy _ -> boring_case (StockStrategy noExtField) - AnyclassStrategy _ -> boring_case (AnyclassStrategy noExtField) - NewtypeStrategy _ -> boring_case (NewtypeStrategy noExtField) - ViaStrategy (XViaStrategyPs _ via_ty) -> - do checkInferredVars doc inf_err via_ty - (via_ty', fvs1) <- rnHsSigType doc TypeLevel via_ty - let HsSig { sig_bndrs = via_outer_bndrs - , sig_body = via_body } = unLoc via_ty' - via_tvs = hsOuterTyVarNames via_outer_bndrs - -- Check if there are any nested `forall`s, which are illegal in a - -- `via` type. - -- See Note [No nested foralls or contexts in instance types] - -- (Wrinkle: Derived instances) in GHC.Hs.Type. - addNoNestedForallsContextsErr doc - (quotes (text "via") <+> text "type") via_body - (thing, fvs2) <- bindLocalNamesFV via_tvs thing_inside - pure (ViaStrategy via_ty', thing, fvs1 `plusFV` fvs2) - - inf_err = Just (text "Inferred type variables are not allowed") - - boring_case :: ds -> RnM (ds, a, FreeVars) - boring_case ds = do - (thing, fvs) <- thing_inside - pure (ds, thing, fvs) - -badGadtStupidTheta :: HsDocContext -> TcRnMessage -badGadtStupidTheta _ - = mkTcRnUnknownMessage $ mkPlainError noHints $ - vcat [text "No context is allowed on a GADT-style data declaration", - text "(You can put a context on each constructor, though.)"] - -illegalDerivStrategyErr :: DerivStrategy GhcPs -> TcRnMessage -illegalDerivStrategyErr ds - = mkTcRnUnknownMessage $ mkPlainError noHints $ - vcat [ text "Illegal deriving strategy" <> colon <+> derivStrategyName ds - , text enableStrategy ] - - where - enableStrategy :: String - enableStrategy - | ViaStrategy{} <- ds - = "Use DerivingVia to enable this extension" - | otherwise - = "Use DerivingStrategies to enable this extension" - -multipleDerivClausesErr :: TcRnMessage -multipleDerivClausesErr - = mkTcRnUnknownMessage $ mkPlainError noHints $ - vcat [ text "Illegal use of multiple, consecutive deriving clauses" - , text "Use DerivingStrategies to allow this" ] - -rnFamDecl :: Maybe Name -- Just cls => this FamilyDecl is nested - -- inside an *class decl* for cls - -- used for associated types - -> FamilyDecl GhcPs - -> RnM (FamilyDecl GhcRn, FreeVars) -rnFamDecl mb_cls (FamilyDecl { fdLName = tycon, fdTyVars = tyvars - , fdTopLevel = toplevel - , fdFixity = fixity - , fdInfo = info, fdResultSig = res_sig - , fdInjectivityAnn = injectivity }) - = do { tycon' <- lookupLocatedTopConstructorRnN tycon - ; ((tyvars', res_sig', injectivity'), fv1) <- - bindHsQTyVars doc mb_cls kvs tyvars $ \ tyvars' _ -> - do { let rn_sig = rnFamResultSig doc - ; (res_sig', fv_kind) <- wrapLocFstMA rn_sig res_sig - ; injectivity' <- traverse (rnInjectivityAnn tyvars' res_sig') - injectivity - ; return ( (tyvars', res_sig', injectivity') , fv_kind ) } - ; (info', fv2) <- rn_info info - ; return (FamilyDecl { fdExt = noAnn - , fdLName = tycon', fdTyVars = tyvars' - , fdTopLevel = toplevel - , fdFixity = fixity - , fdInfo = info', fdResultSig = res_sig' - , fdInjectivityAnn = injectivity' } - , fv1 `plusFV` fv2) } - where - doc = TyFamilyCtx tycon - kvs = extractRdrKindSigVars res_sig - - ---------------------- - rn_info :: FamilyInfo GhcPs -> RnM (FamilyInfo GhcRn, FreeVars) - rn_info (ClosedTypeFamily (Just eqns)) - = do { (eqns', fvs) - <- rnList (rnTyFamInstEqn (NonAssocTyFamEqn ClosedTyFam)) eqns - -- no class context - ; return (ClosedTypeFamily (Just eqns'), fvs) } - rn_info (ClosedTypeFamily Nothing) - = return (ClosedTypeFamily Nothing, emptyFVs) - rn_info OpenTypeFamily = return (OpenTypeFamily, emptyFVs) - rn_info DataFamily = return (DataFamily, emptyFVs) - -rnFamResultSig :: HsDocContext - -> FamilyResultSig GhcPs - -> RnM (FamilyResultSig GhcRn, FreeVars) -rnFamResultSig _ (NoSig _) - = return (NoSig noExtField, emptyFVs) -rnFamResultSig doc (KindSig _ kind) - = do { (rndKind, ftvs) <- rnLHsKind doc kind - ; return (KindSig noExtField rndKind, ftvs) } -rnFamResultSig doc (TyVarSig _ tvbndr) - = do { -- `TyVarSig` tells us that user named the result of a type family by - -- writing `= tyvar` or `= (tyvar :: kind)`. In such case we want to - -- be sure that the supplied result name is not identical to an - -- already in-scope type variable from an enclosing class. - -- - -- Example of disallowed declaration: - -- 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) $ mkTcRnUnknownMessage $ mkPlainError noHints $ - (hsep [ text "Type variable", quotes (ppr resName) <> comma - , text "naming a type family result," - ] $$ - text "shadows an already bound type variable") - - ; 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')) } - --- Note [Renaming injectivity annotation] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- --- During renaming of injectivity annotation we have to make several checks to --- make sure that it is well-formed. At the moment injectivity annotation --- consists of a single injectivity condition, so the terms "injectivity --- annotation" and "injectivity condition" might be used interchangeably. See --- Note [Injectivity annotation] for a detailed discussion of currently allowed --- injectivity annotations. --- --- Checking LHS is simple because the only type variable allowed on the LHS of --- injectivity condition is the variable naming the result in type family head. --- Example of disallowed annotation: --- --- type family Foo a b = r | b -> a --- --- Verifying RHS of injectivity consists of checking that: --- --- 1. only variables defined in type family head appear on the RHS (kind --- variables are also allowed). Example of disallowed annotation: --- --- type family Foo a = r | r -> b --- --- 2. for associated types the result variable does not shadow any of type --- class variables. Example of disallowed annotation: --- --- class Foo a b where --- type F a = b | b -> a --- --- Breaking any of these assumptions results in an error. - --- | Rename injectivity annotation. Note that injectivity annotation is just the --- part after the "|". Everything that appears before it is renamed in --- rnFamDecl. -rnInjectivityAnn :: LHsQTyVars GhcRn -- ^ Type variables declared in - -- type family head - -> LFamilyResultSig GhcRn -- ^ Result signature - -> LInjectivityAnn GhcPs -- ^ Injectivity annotation - -> RnM (LInjectivityAnn GhcRn) -rnInjectivityAnn tvBndrs (L _ (TyVarSig _ resTv)) - (L srcSpan (InjectivityAnn x injFrom injTo)) - = do - { (injDecl'@(L _ (InjectivityAnn _ injFrom' injTo')), noRnErrors) - <- askNoErrs $ - bindLocalNames [hsLTyVarName resTv] $ - -- The return type variable scopes over the injectivity annotation - -- e.g. type family F a = (r::*) | r -> a - do { injFrom' <- rnLTyVar injFrom - ; injTo' <- mapM rnLTyVar injTo - -- Note: srcSpan is unchanged, but typechecker gets - -- confused, l2l call makes it happy - ; return $ L (l2l srcSpan) (InjectivityAnn x injFrom' injTo') } - - ; let tvNames = Set.fromList $ hsAllLTyVarNames tvBndrs - resName = hsLTyVarName resTv - -- See Note [Renaming injectivity annotation] - lhsValid = EQ == (stableNameCmp resName (unLoc injFrom')) - rhsValid = Set.fromList (map unLoc injTo') `Set.difference` tvNames - - -- if renaming of type variables ended with errors (eg. there were - -- not-in-scope variables) don't check the validity of injectivity - -- annotation. This gives better error messages. - ; when (noRnErrors && not lhsValid) $ - addErrAt (getLocA injFrom) $ mkTcRnUnknownMessage $ mkPlainError noHints $ - ( vcat [ text $ "Incorrect type variable on the LHS of " - ++ "injectivity condition" - , nest 5 - ( vcat [ text "Expected :" <+> ppr resName - , text "Actual :" <+> ppr injFrom ])]) - - ; when (noRnErrors && not (Set.null rhsValid)) $ - do { let errorVars = Set.toList rhsValid - ; addErrAt (locA srcSpan) $ mkTcRnUnknownMessage $ mkPlainError noHints $ - ( hsep - [ text "Unknown type variable" <> plural errorVars - , text "on the RHS of injectivity condition:" - , interpp'SP errorVars ] ) } - - ; return injDecl' } - --- We can only hit this case when the user writes injectivity annotation without --- naming the result: --- --- type family F a | result -> a --- type family F a :: * | result -> a --- --- So we rename injectivity annotation like we normally would except that --- this time we expect "result" to be reported not in scope by rnLTyVar. -rnInjectivityAnn _ _ (L srcSpan (InjectivityAnn x injFrom injTo)) = - setSrcSpanA srcSpan $ do - (injDecl', _) <- askNoErrs $ do - injFrom' <- rnLTyVar injFrom - injTo' <- mapM rnLTyVar injTo - return $ L srcSpan (InjectivityAnn x injFrom' injTo') - return $ injDecl' - -{- -Note [Stupid theta] -~~~~~~~~~~~~~~~~~~~ -#3850 complains about a regression wrt 6.10 for - data Show a => T a -There is no reason not to allow the stupid theta if there are no data -constructors. It's still stupid, but does no harm, and I don't want -to cause programs to break unnecessarily (notably HList). So if there -are no data constructors we allow h98_style = True --} - - -{- ***************************************************** -* * - Support code for type/data declarations -* * -***************************************************** -} - ------------------ -rnConDecls :: DataDefnCons (LConDecl GhcPs) -> RnM (DataDefnCons (LConDecl GhcRn), FreeVars) -rnConDecls = mapFvRn (wrapLocFstMA rnConDecl) - -rnConDecl :: ConDecl GhcPs -> RnM (ConDecl GhcRn, FreeVars) -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 - - -- We bind no implicit binders here; this is just like - -- a nested HsForAllTy. E.g. consider - -- data T a = forall (b::k). MkT (...) - -- The 'k' will already be in scope from the bindHsQTyVars - -- for the data decl itself. So we'll get - -- data T {k} a = ... - -- And indeed we may later discover (a::k). But that's the - -- scoping we get. So no implicit binders at the existential forall - - ; let ctxt = ConDeclCtx [new_name] - ; bindLHsTyVarBndrs ctxt WarnUnusedForalls - Nothing ex_tvs $ \ new_ex_tvs -> - do { (new_context, fvs1) <- rnMbContext ctxt mcxt - ; (new_args, fvs2) <- rnConDeclH98Details (unLoc new_name) ctxt args - ; let all_fvs = fvs1 `plusFV` fvs2 - ; traceRn "rnConDecl (ConDeclH98)" (ppr name <+> vcat - [ text "ex_tvs:" <+> ppr ex_tvs - , text "new_ex_dqtvs':" <+> ppr new_ex_tvs ]) - - ; mb_doc' <- traverse rnLHsDoc mb_doc - ; return (decl { con_ext = noAnn - , con_name = new_name, con_ex_tvs = new_ex_tvs - , con_mb_cxt = new_context, con_args = new_args - , con_doc = mb_doc' - , con_forall = forall_ }, -- Remove when #18311 is fixed - all_fvs) }} - -rnConDecl (ConDeclGADT { con_names = names - , con_dcolon = dcol - , con_bndrs = L l outer_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 - - ; let -- We must ensure that we extract the free tkvs in left-to-right - -- order of their appearance in the constructor type. - -- That order governs the order the implicitly-quantified type - -- variable, and hence the order needed for visible type application - -- See #14808. - implicit_bndrs = - extractHsOuterTvBndrs outer_bndrs $ - extractHsTysRdrTyVars (hsConDeclTheta mcxt) $ - extractConDeclGADTDetailsTyVars args $ - extractHsTysRdrTyVars [res_ty] [] - - ; let ctxt = ConDeclCtx (toList new_names) - - ; bindHsOuterTyVarBndrs ctxt Nothing implicit_bndrs outer_bndrs $ \outer_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 - - -- Ensure that there are no nested `forall`s or contexts, per - -- Note [GADT abstract syntax] (Wrinkle: No nested foralls or contexts) - -- in GHC.Hs.Type. - ; addNoNestedForallsContextsErr ctxt - (text "GADT constructor type signature") new_res_ty - - ; let all_fvs = fvs1 `plusFV` fvs2 `plusFV` fvs3 - - ; traceRn "rnConDecl (ConDeclGADT)" - (ppr names $$ ppr outer_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 - , con_g_args = new_args, con_res_ty = new_res_ty - , con_doc = new_mb_doc }, - all_fvs) } } - -rnMbContext :: HsDocContext -> Maybe (LHsContext GhcPs) - -> RnM (Maybe (LHsContext GhcRn), FreeVars) -rnMbContext _ Nothing = return (Nothing, emptyFVs) -rnMbContext doc cxt = do { (ctx',fvs) <- rnMaybeContext doc cxt - ; return (ctx',fvs) } - -rnConDeclH98Details :: - Name - -> 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 (InfixCon ty1 ty2) - = do { (new_ty1, fvs1) <- rnScaledLHsType doc ty1 - ; (new_ty2, fvs2) <- rnScaledLHsType doc ty2 - ; return (InfixCon new_ty1 new_ty2, fvs1 `plusFV` fvs2) } -rnConDeclH98Details con doc (RecCon flds) - = do { (new_flds, fvs) <- rnRecConDeclFields con doc flds - ; return (RecCon new_flds, fvs) } - -rnConDeclGADTDetails :: - Name - -> 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) } - -rnRecConDeclFields :: - 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 - -- No need to check for duplicate fields - -- since that is done by GHC.Rename.Names.extendGlobalRdrEnvRn - ; pure (L l new_fields, fvs) } - -------------------------------------------------- - --- | Brings pattern synonym names and also pattern synonym selectors --- from record pattern synonyms into scope. -extendPatSynEnv :: DuplicateRecordFields -> FieldSelectors -> HsValBinds GhcPs -> MiniFixityEnv - -> ([Name] -> TcRnIf TcGblEnv TcLclEnv a) -> TcM a -extendPatSynEnv dup_fields_ok has_sel val_decls local_fix_env thing = do { - names_with_fls <- new_ps val_decls - ; let pat_syn_bndrs = concat [ name: map flSelector fields - | (name, fields) <- names_with_fls ] - ; let avails = map avail (map fst names_with_fls) - ++ map availField (concatMap snd names_with_fls) - ; (gbl_env, lcl_env) <- extendGlobalRdrEnvRn avails local_fix_env - - ; let field_env' = extendNameEnvList (tcg_field_env gbl_env) names_with_fls - final_gbl_env = gbl_env { tcg_field_env = field_env' } - ; restoreEnvs (final_gbl_env, lcl_env) (thing pat_syn_bndrs) } - where - new_ps :: HsValBinds GhcPs -> TcM [(Name, [FieldLabel])] - new_ps (ValBinds _ binds _) = foldrM new_ps' [] binds - new_ps _ = panic "new_ps" - - new_ps' :: LHsBindLR GhcPs GhcPs - -> [(Name, [FieldLabel])] - -> TcM [(Name, [FieldLabel])] - new_ps' bind names - | (L bind_loc (PatSynBind _ (PSB { psb_id = L _ n - , psb_args = RecCon as }))) <- bind - = do - bnd_name <- newTopSrcBinder (L (l2l bind_loc) n) - let field_occs = map ((\ f -> L (noAnnSrcSpan $ getLocA (foLabel f)) f) . recordPatSynField) as - flds <- mapM (newRecordSelector dup_fields_ok has_sel [bnd_name]) field_occs - return ((bnd_name, flds): names) - | L bind_loc (PatSynBind _ (PSB { psb_id = L _ n})) <- bind - = do - bnd_name <- newTopSrcBinder (L (la2na bind_loc) n) - return ((bnd_name, []): names) - | otherwise - = return names - -{- -********************************************************* -* * -\subsection{Support code to rename types} -* * -********************************************************* --} - -rnFds :: [LHsFunDep GhcPs] -> RnM [LHsFunDep GhcRn] -rnFds fds - = mapM (wrapLocMA rn_fds) fds - where - rn_fds :: FunDep GhcPs -> RnM (FunDep GhcRn) - rn_fds (FunDep x tys1 tys2) - = do { tys1' <- rnHsTyVars tys1 - ; tys2' <- rnHsTyVars tys2 - ; return (FunDep x tys1' tys2') } - -rnHsTyVars :: [LocatedN RdrName] -> RnM [LocatedN Name] -rnHsTyVars tvs = mapM rnHsTyVar tvs - -rnHsTyVar :: LocatedN RdrName -> RnM (LocatedN Name) -rnHsTyVar (L l tyvar) = do - tyvar' <- lookupOccRn tyvar - return (L l tyvar') - -{- -********************************************************* -* * - findSplice -* * -********************************************************* - -This code marches down the declarations, looking for the first -Template Haskell splice. As it does so it - a) groups the declarations into a HsGroup - b) runs any top-level quasi-quotes --} - -findSplice :: [LHsDecl GhcPs] - -> RnM (HsGroup GhcPs, Maybe (SpliceDecl GhcPs, [LHsDecl GhcPs])) -findSplice ds = addl emptyRdrGroup ds - -addl :: HsGroup GhcPs -> [LHsDecl GhcPs] - -> RnM (HsGroup GhcPs, Maybe (SpliceDecl GhcPs, [LHsDecl GhcPs])) --- This stuff reverses the declarations (again) but it doesn't matter -addl gp [] = return (gp, Nothing) -addl gp (L l d : ds) = add gp l d ds - - -add :: HsGroup GhcPs -> SrcSpanAnnA -> HsDecl GhcPs -> [LHsDecl GhcPs] - -> RnM (HsGroup GhcPs, Maybe (SpliceDecl GhcPs, [LHsDecl GhcPs])) - --- #10047: Declaration QuasiQuoters are expanded immediately, without --- causing a group split -add gp _ (SpliceD _ (SpliceDecl _ (L _ qq@HsQuasiQuote{}) _)) ds - = do { (ds', _) <- rnTopSpliceDecls qq - ; addl gp (ds' ++ ds) - } - -add gp loc (SpliceD _ splice@(SpliceDecl _ _ flag)) ds - = do { -- We've found a top-level splice. If it is an *implicit* one - -- (i.e. a naked top level expression) - case flag of - DollarSplice -> return () - BareSplice -> do { th_on <- xoptM LangExt.TemplateHaskell - ; unless th_on $ setSrcSpan (locA loc) $ - failWith badImplicitSplice } - - ; return (gp, Just (splice, ds)) } - where - badImplicitSplice :: TcRnMessage - badImplicitSplice = mkTcRnUnknownMessage $ mkPlainError noHints $ - text "Parse error: module header, import declaration" - $$ text "or top-level declaration expected." - -- The compiler should suggest the above, and not using - -- TemplateHaskell since the former suggestion is more - -- relevant to the larger base of users. - -- See #12146 for discussion. - --- Class declarations: added to the TyClGroup -add gp@(HsGroup {hs_tyclds = ts}) l (TyClD _ d) ds - = addl (gp { hs_tyclds = add_tycld (L l d) ts }) ds - --- Signatures: fixity sigs go a different place than all others -add gp@(HsGroup {hs_fixds = ts}) l (SigD _ (FixSig _ f)) ds - = addl (gp {hs_fixds = L l f : ts}) ds - --- Standalone kind signatures: added to the TyClGroup -add gp@(HsGroup {hs_tyclds = ts}) l (KindSigD _ s) ds - = addl (gp {hs_tyclds = add_kisig (L l s) ts}) ds - -add gp@(HsGroup {hs_valds = ts}) l (SigD _ d) ds - = addl (gp {hs_valds = add_sig (L l d) ts}) ds - --- Value declarations: use add_bind -add gp@(HsGroup {hs_valds = ts}) l (ValD _ d) ds - = addl (gp { hs_valds = add_bind (L l d) ts }) ds - --- Role annotations: added to the TyClGroup -add gp@(HsGroup {hs_tyclds = ts}) l (RoleAnnotD _ d) ds - = addl (gp { hs_tyclds = add_role_annot (L l d) ts }) ds - --- NB instance declarations go into TyClGroups. We throw them into the first --- group, just as we do for the TyClD case. The renamer will go on to group --- and order them later. -add gp@(HsGroup {hs_tyclds = ts}) l (InstD _ d) ds - = addl (gp { hs_tyclds = add_instd (L l d) ts }) ds - --- The rest are routine -add gp@(HsGroup {hs_derivds = ts}) l (DerivD _ d) ds - = addl (gp { hs_derivds = L l d : ts }) ds -add gp@(HsGroup {hs_defds = ts}) l (DefD _ d) ds - = addl (gp { hs_defds = L l d : ts }) ds -add gp@(HsGroup {hs_fords = ts}) l (ForD _ d) ds - = addl (gp { hs_fords = L l d : ts }) ds -add gp@(HsGroup {hs_warnds = ts}) l (WarningD _ d) ds - = addl (gp { hs_warnds = L l d : ts }) ds -add gp@(HsGroup {hs_annds = ts}) l (AnnD _ d) ds - = addl (gp { hs_annds = L l d : ts }) ds -add gp@(HsGroup {hs_ruleds = ts}) l (RuleD _ d) ds - = addl (gp { hs_ruleds = L l d : ts }) ds -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 d [] = [TyClGroup { group_ext = noExtField - , group_tyclds = [d] - , group_kisigs = [] - , group_roles = [] - , group_instds = [] - } - ] -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 d [] = [TyClGroup { group_ext = noExtField - , group_tyclds = [] - , group_kisigs = [] - , group_roles = [] - , group_instds = [d] - } - ] -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 d [] = [TyClGroup { group_ext = noExtField - , group_tyclds = [] - , group_kisigs = [] - , group_roles = [d] - , group_instds = [] - } - ] -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 d [] = [TyClGroup { group_ext = noExtField - , group_tyclds = [] - , group_kisigs = [d] - , group_roles = [] - , group_instds = [] - } - ] -add_kisig d (tycls@(TyClGroup { group_kisigs = kisigs }) : rest) - = 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 +{-# 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 + +Main pass of renamer +-} + +module GHC.Rename.Module ( + rnSrcDecls, addTcgDUs, findSplice, rnWarningTxt, rnLWarningTxt + ) where + +import GHC.Prelude hiding ( head ) + +import {-# SOURCE #-} GHC.Rename.Expr( rnLExpr ) +import {-# SOURCE #-} GHC.Rename.Splice ( rnSpliceDecl, rnTopSpliceDecls ) + +import GHC.Hs + +import GHC.Rename.HsType +import GHC.Rename.Bind +import GHC.Rename.Doc +import GHC.Rename.Env +import GHC.Rename.Utils ( mapFvRn, bindLocalNames + , checkDupRdrNames, bindLocalNamesFV + , warnUnusedTypePatterns + , noNestedForallsContextsErr + , addNoNestedForallsContextsErr, checkInferredVars ) +import GHC.Rename.Unbound ( mkUnboundName, notInScopeErr, WhereLooking(WL_Global) ) +import GHC.Rename.Names + +import GHC.Tc.Errors.Types +import GHC.Tc.Utils.Monad +import GHC.Tc.Types.Origin ( TypedThing(..) ) + +import GHC.Unit +import GHC.Unit.Module.Warnings +import GHC.Builtin.Names( applicativeClassName, pureAName, thenAName + , monadClassName, returnMName, thenMName + , 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.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.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, Node(..) + , stronglyConnCompFromEdgedVerticesUniq ) +import GHC.Data.OrdList +import qualified GHC.LanguageExtensions as LangExt +import GHC.Core.DataCon ( isSrcStrict ) + +import Control.Monad +import Control.Arrow ( first ) +import Data.Foldable ( toList, for_ ) +import Data.List.NonEmpty ( NonEmpty(..), head, nonEmpty ) +import Data.Maybe ( isNothing, fromMaybe, mapMaybe, maybeToList ) +import qualified Data.Set as Set ( difference, fromList, toList, null ) + +{- | @rnSourceDecl@ "renames" declarations. +It simultaneously performs dependency analysis and precedence parsing. +It also does the following error checks: + +* Checks that tyvars are used properly. This includes checking + for undefined tyvars, and tyvars in contexts that are ambiguous. + (Some of this checking has now been moved to module @TcMonoType@, + since we don't have functional dependency information at this point.) + +* Checks that all variable occurrences are defined. + +* Checks the @(..)@ etc constraints in the export list. + +Brings the binders of the group into scope in the appropriate places; +does NOT assume that anything is in scope already +-} +rnSrcDecls :: HsGroup GhcPs -> RnM (TcGblEnv, HsGroup GhcRn) +-- Rename a top-level HsGroup; used for normal source files *and* hs-boot files +rnSrcDecls group@(HsGroup { hs_valds = val_decls, + hs_splcds = splice_decls, + hs_tyclds = tycl_decls, + hs_derivds = deriv_decls, + hs_fixds = fix_decls, + hs_warnds = warn_decls, + hs_annds = ann_decls, + hs_fords = foreign_decls, + hs_defds = default_decls, + hs_ruleds = rule_decls, + hs_docs = docs }) + = do { + -- (A) Process the top-level fixity declarations, creating a mapping from + -- FastStrings to FixItems. Also checks for duplicates. + -- See Note [Top-level fixity signatures in an HsGroup] in GHC.Hs.Decls + local_fix_env <- makeMiniFixityEnv $ hsGroupTopLevelFixitySigs group ; + + -- (B) Bring top level binders (and their fixities) into scope, + -- *except* for the value bindings, which get done in step (D) + -- with collectHsIdBinders. However *do* include + -- + -- * Class ops, data constructors, and record fields, + -- because they do not have value declarations. + -- + -- * For hs-boot files, include the value signatures + -- Again, they have no value declarations + -- + (tc_envs, tc_bndrs) <- getLocalNonValBinders local_fix_env group ; + + + restoreEnvs tc_envs $ do { + + failIfErrsM ; -- No point in continuing if (say) we have duplicate declarations + + -- (D1) Bring pattern synonyms into scope. + -- Need to do this before (D2) because rnTopBindsLHS + -- looks up those pattern synonyms (#9889) + + dup_fields_ok <- xopt_DuplicateRecordFields <$> getDynFlags ; + has_sel <- xopt_FieldSelectors <$> getDynFlags ; + extendPatSynEnv dup_fields_ok has_sel val_decls local_fix_env $ \pat_syn_bndrs -> do { + + -- (D2) Rename the left-hand sides of the value bindings. + -- This depends on everything from (B) being in scope. + -- It uses the fixity env from (A) to bind fixities for view patterns. + + -- We need to throw an error on such value bindings when in a boot file. + is_boot <- tcIsHsBootOrSig ; + new_lhs <- if is_boot + then rnTopBindsLHSBoot local_fix_env val_decls + else rnTopBindsLHS local_fix_env val_decls ; + + -- Bind the LHSes (and their fixities) in the global rdr environment + let { id_bndrs = collectHsIdBinders CollNoDictBinders new_lhs } ; + -- Excludes pattern-synonym binders + -- They are already in scope + traceRn "rnSrcDecls" (ppr id_bndrs) ; + tc_envs <- extendGlobalRdrEnvRn (map (mkLocalVanillaGRE NoParent) id_bndrs) local_fix_env ; + restoreEnvs tc_envs $ do { + + -- Now everything is in scope, as the remaining renaming assumes. + + -- (E) Rename type and class decls + -- (note that value LHSes need to be in scope for default methods) + -- + -- You might think that we could build proper def/use information + -- for type and class declarations, but they can be involved + -- in mutual recursion across modules, and we only do the SCC + -- analysis for them in the type checker. + -- So we content ourselves with gathering uses only; that + -- means we'll only report a declaration as unused if it isn't + -- mentioned at all. Ah well. + traceRn "Start rnTyClDecls" (ppr tycl_decls) ; + (rn_tycl_decls, src_fvs1) <- rnTyClDecls tycl_decls ; + + -- (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@(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.) + then rnTopBindsBoot tc_bndrs new_lhs + else rnValBindsRHS (TopSigCtxt val_bndr_set) new_lhs ; + traceRn "finish rnmono" (ppr rn_val_decls) ; + + -- (G) Rename Fixity and deprecations + + -- Rename fixity declarations and error if we try to + -- fix something from another module (duplicates were checked in (A)) + let { all_bndrs = tc_bndrs `unionNameSet` val_bndr_set } ; + traceRn "rnSrcDecls fixity" $ + vcat [ text "all_bndrs:" <+> ppr all_bndrs ] ; + rn_fix_decls <- mapM (mapM (rnSrcFixityDecl (TopSigCtxt all_bndrs))) + fix_decls ; + + -- Rename deprec decls; + -- check for duplicates and ensure that deprecated things are defined locally + -- at the moment, we don't keep these around past renaming + rn_decl_warns <- rnSrcWarnDecls all_bndrs warn_decls ; + + -- (H) Rename Everything else + + (rn_rule_decls, src_fvs2) <- setXOptM LangExt.ScopedTypeVariables $ + rnList rnHsRuleDecls rule_decls ; + -- Inside RULES, scoped type variables are on + (rn_foreign_decls, src_fvs3) <- rnList rnHsForeignDecl foreign_decls ; + (rn_ann_decls, src_fvs4) <- rnList rnAnnDecl ann_decls ; + (rn_default_decls, src_fvs5) <- rnList rnDefaultDecl default_decls ; + (rn_deriv_decls, src_fvs6) <- rnList rnSrcDerivDecl deriv_decls ; + (rn_splice_decls, src_fvs7) <- rnList rnSpliceDecl splice_decls ; + rn_docs <- traverse rnLDocDecl docs ; + + -- 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, + hs_splcds = rn_splice_decls, + hs_tyclds = rn_tycl_decls, + hs_derivds = rn_deriv_decls, + hs_fixds = rn_fix_decls, + hs_warnds = [], -- warns are returned in the tcg_env + -- (see below) not in the HsGroup + hs_fords = rn_foreign_decls, + hs_annds = rn_ann_decls, + hs_defds = rn_default_decls, + hs_ruleds = rn_rule_decls, + hs_docs = rn_docs } ; + + tcf_bndrs = hsTyClForeignBinders rn_tycl_decls rn_foreign_decls ; + other_def = (Just (mkNameSet tcf_bndrs), emptyNameSet) ; + other_fvs = plusFVs [src_fvs1, src_fvs2, src_fvs3, src_fvs4, + src_fvs5, src_fvs6, src_fvs7] ; + -- It is tiresome to gather the binders from type and class decls + + src_dus = unitOL other_def `plusDU` bind_dus `plusDU` usesOnly other_fvs ; + -- Instance decls may have occurrences of things bound in bind_dus + -- so we must put other_fvs last + + final_tcg_env = let tcg_env' = (last_tcg_env `addTcgDUs` src_dus) + in -- we return the deprecs in the env, not in the HsGroup above + tcg_env' { tcg_warns = insertWarnDecls (tcg_warns tcg_env') rn_decl_warns }; + } ; + traceRn "finish rnSrc" (ppr rn_group) ; + traceRn "finish Dus" (ppr src_dus ) ; + return (final_tcg_env, rn_group) + }}}} + +addTcgDUs :: TcGblEnv -> DefUses -> TcGblEnv +-- This function could be defined lower down in the module hierarchy, +-- but there doesn't seem anywhere very logical to put it. +addTcgDUs tcg_env dus = tcg_env { tcg_dus = tcg_dus tcg_env `plusDU` dus } + +rnList :: (a -> RnM (b, FreeVars)) -> [LocatedA a] -> RnM ([LocatedA b], FreeVars) +rnList f xs = mapFvRn (wrapLocFstMA f) xs + +{- +********************************************************* +* * + Source-code deprecations declarations +* * +********************************************************* + +Check that the deprecated names are defined, are defined locally, and +that there are no duplicate deprecations. + +It's only imported deprecations, dealt with in RnIfaces, that we +gather them together. +-} + +-- checks that the deprecations are defined locally, and that there are no duplicates +rnSrcWarnDecls :: NameSet -> [LWarnDecls GhcPs] -> RnM (DeclWarnOccNames GhcRn) +rnSrcWarnDecls _ [] + = return [] + +rnSrcWarnDecls bndr_set decls' + = do { -- check for duplicates + ; mapM_ (\ dups -> let ((L loc rdr) :| (lrdr':_)) = fmap snd dups + in addErrAt (locA loc) (TcRnDuplicateWarningDecls lrdr' rdr)) + warn_rdr_dups + ; 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 w@(Warning (ns_spec, _) rdr_names txt) + -- ensures that the names are defined locally + = 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). + + warn_rdr_dups = find_dup_warning_names + $ concatMap (\(L _ (Warning (ns_spec, _) ns _)) -> (ns_spec,) <$> 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 (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') + +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 +-- invt: the lists returned by findDupsEq always have at least two elements + +{- +********************************************************* +* * +\subsection{Annotation declarations} +* * +********************************************************* +-} + +rnAnnDecl :: AnnDecl GhcPs -> RnM (AnnDecl GhcRn, FreeVars) +rnAnnDecl ann@(HsAnnotation (_, s) provenance expr) + = addErrCtxt (AnnCtxt ann) $ + do { (provenance', provenance_fvs) <- rnAnnProvenance provenance + ; cur_level <- getThLevel + ; (expr', expr_fvs) <- setThLevel (Splice Untyped cur_level) $ + rnLExpr expr + ; return (HsAnnotation (noAnn, s) provenance' expr', + provenance_fvs `plusFV` expr_fvs) } + +rnAnnProvenance :: AnnProvenance GhcPs + -> RnM (AnnProvenance GhcRn, FreeVars) +rnAnnProvenance provenance = do + provenance' <- case provenance of + ValueAnnProvenance n -> ValueAnnProvenance + <$> lookupLocatedTopBndrRnN WL_Term n + TypeAnnProvenance n -> TypeAnnProvenance + <$> lookupLocatedTopBndrRnN WL_Type n + ModuleAnnProvenance -> return ModuleAnnProvenance + return (provenance', maybe emptyFVs unitFV (annProvenanceName_maybe provenance')) + +{- +********************************************************* +* * +\subsection{Default declarations} +* * +********************************************************* +-} + +rnDefaultDecl :: DefaultDecl GhcPs -> RnM (DefaultDecl GhcRn, FreeVars) +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 + +{- +********************************************************* +* * +\subsection{Foreign declarations} +* * +********************************************************* +-} + +rnHsForeignDecl :: ForeignDecl GhcPs -> RnM (ForeignDecl GhcRn, FreeVars) +rnHsForeignDecl (ForeignImport { fd_name = name, fd_sig_ty = ty, fd_fi = spec }) + = do { topEnv :: HscEnv <- getTopEnv + ; name' <- lookupLocatedTopBndrRnN WL_TermVariable name + ; (ty', fvs) <- rnHsSigType (ForeignDeclCtx name) TypeLevel ty + + -- Mark any PackageTarget style imports as coming from the current package + ; let home_unit = hsc_home_unit topEnv + spec' = patchForeignImport (homeUnitAsUnit home_unit) spec + + ; return (ForeignImport { fd_i_ext = noExtField + , fd_name = name', fd_sig_ty = ty' + , fd_fi = spec' }, fvs) } + +rnHsForeignDecl (ForeignExport { fd_name = name, fd_sig_ty = ty, fd_fe = spec }) + = 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' + , fd_fe = (\(CExport x c) -> CExport x c) spec } + , fvs `addOneFV` unLoc name') } + -- NB: a foreign export is an *occurrence site* for name, so + -- we add it to the free-variable list. It might, for example, + -- be imported from another module + +-- | For Windows DLLs we need to know what packages imported symbols are from +-- to generate correct calls. Imported symbols are tagged with the current +-- package, so if they get inlined across a package boundary we'll still +-- know where they're from. +-- +patchForeignImport :: Unit -> (ForeignImport GhcPs) -> (ForeignImport GhcRn) +patchForeignImport unit (CImport ext cconv safety fs spec) + = CImport ext cconv safety fs (patchCImportSpec unit spec) + +patchCImportSpec :: Unit -> CImportSpec -> CImportSpec +patchCImportSpec unit spec + = case spec of + CFunction callTarget -> CFunction $ patchCCallTarget unit callTarget + _ -> spec + +patchCCallTarget :: Unit -> CCallTarget -> CCallTarget +patchCCallTarget unit callTarget = + case callTarget of + StaticTarget src label Nothing isFun + -> StaticTarget src label (Just unit) isFun + _ -> callTarget + +{- +********************************************************* +* * +\subsection{Instance declarations} +* * +********************************************************* +-} + +rnSrcInstDecl :: InstDecl GhcPs -> RnM (InstDecl GhcRn, FreeVars) +rnSrcInstDecl (TyFamInstD { tfid_inst = tfi }) + = do { (tfi', fvs) <- rnTyFamInstDecl (NonAssocTyFamEqn NotClosedTyFam) tfi + ; return (TyFamInstD { tfid_ext = noExtField, tfid_inst = tfi' }, fvs) } + +rnSrcInstDecl (DataFamInstD { dfid_inst = dfi }) + = do { (dfi', fvs) <- rnDataFamInstDecl (NonAssocTyFamEqn NotClosedTyFam) dfi + ; return (DataFamInstD { dfid_ext = noExtField, dfid_inst = dfi' }, fvs) } + +rnSrcInstDecl (ClsInstD { cid_inst = cid }) + = do { traceRn "rnSrcIstDecl {" (ppr cid) + ; (cid', fvs) <- rnClsInstDecl cid + ; traceRn "rnSrcIstDecl end }" empty + ; return (ClsInstD { cid_d_ext = noExtField, cid_inst = cid' }, fvs) } + +-- | Warn about non-canonical typeclass instance declarations +-- +-- A "non-canonical" instance definition can occur for instances of a +-- class which redundantly defines an operation its superclass +-- provides as well (c.f. `return`/`pure`). In such cases, a canonical +-- instance is one where the subclass inherits its method +-- implementation from its superclass instance (usually the subclass +-- has a default method implementation to that effect). Consequently, +-- a non-canonical instance occurs when this is not the case. +-- +-- See also descriptions of 'checkCanonicalMonadInstances' and +-- 'checkCanonicalMonoidInstances' +checkCanonicalInstances :: Name -> LHsSigType GhcRn -> LHsBinds GhcRn -> RnM () +checkCanonicalInstances cls poly_ty mbinds = do + whenWOptM Opt_WarnNonCanonicalMonadInstances + $ checkCanonicalMonadInstances + + whenWOptM Opt_WarnNonCanonicalMonoidInstances + $ checkCanonicalMonoidInstances + + where + -- Warn about unsound/non-canonical 'Applicative'/'Monad' instance + -- declarations. Specifically, the following conditions are verified: + -- + -- In 'Monad' instances declarations: + -- + -- * If 'return' is overridden it must be canonical (i.e. @return = pure@) + -- * If '(>>)' is overridden it must be canonical (i.e. @(>>) = (*>)@) + -- + -- In 'Applicative' instance declarations: + -- + -- * Warn if 'pure' is defined backwards (i.e. @pure = return@). + -- * Warn if '(*>)' is defined backwards (i.e. @(*>) = (>>)@). + -- + checkCanonicalMonadInstances + | cls == applicativeClassName = + forM_ mbinds $ \(L loc mbind) -> setSrcSpanA loc $ + case mbind of + FunBind { fun_id = L _ name + , fun_matches = mg } + | name == pureAName, isAliasMG mg == Just returnMName + -> addWarnNonCanonicalMonad NonCanonical_Pure + + | name == thenAName, isAliasMG mg == Just thenMName + -> addWarnNonCanonicalMonad NonCanonical_ThenA + + _ -> return () + + | cls == monadClassName = + forM_ mbinds $ \(L loc mbind) -> setSrcSpanA loc $ + case mbind of + FunBind { fun_id = L _ name + , fun_matches = mg } + | name == returnMName, isAliasMG mg /= Just pureAName + -> addWarnNonCanonicalMonad NonCanonical_Return + + | name == thenMName, isAliasMG mg /= Just thenAName + -> addWarnNonCanonicalMonad NonCanonical_ThenM + + _ -> return () + + | otherwise = return () + + -- Check whether Monoid(mappend) is defined in terms of + -- Semigroup((<>)) (and not the other way round). Specifically, + -- the following conditions are verified: + -- + -- In 'Monoid' instances declarations: + -- + -- * If 'mappend' is overridden it must be canonical + -- (i.e. @mappend = (<>)@) + -- + -- In 'Semigroup' instance declarations: + -- + -- * Warn if '(<>)' is defined backwards (i.e. @(<>) = mappend@). + -- + checkCanonicalMonoidInstances + | cls == semigroupClassName = + forM_ mbinds $ \(L loc mbind) -> setSrcSpanA loc $ + case mbind of + FunBind { fun_id = L _ name + , fun_matches = mg } + | name == sappendName, isAliasMG mg == Just mappendName + -> addWarnNonCanonicalMonoid NonCanonical_Sappend + + _ -> return () + + | cls == monoidClassName = + forM_ mbinds $ \(L loc mbind) -> setSrcSpanA loc $ + case mbind of + FunBind { fun_id = L _ name + , fun_matches = mg } + | name == mappendName, isAliasMG mg /= Just sappendName + -> addWarnNonCanonicalMonoid NonCanonical_Mappend + + _ -> return () + + | otherwise = return () + + -- 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 = L _ [] + , m_grhss = grhss })])} + | GRHSs _ (L _ (GRHS _ [] body) :| []) lbinds <- grhss + , EmptyLocalBinds _ <- lbinds + , HsVar _ lrhsName <- unLoc body + = Just (getName lrhsName) + isAliasMG _ = Nothing + + addWarnNonCanonicalMonoid reason = + addWarnNonCanonicalDefinition (NonCanonicalMonoid reason) + + addWarnNonCanonicalMonad reason = + addWarnNonCanonicalDefinition (NonCanonicalMonad reason) + + addWarnNonCanonicalDefinition reason = + addDiagnostic (TcRnNonCanonicalDefinition reason poly_ty) + +rnClsInstDecl :: ClsInstDecl GhcPs -> RnM (ClsInstDecl GhcRn, FreeVars) +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 { 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 ctxt err1 + (_, Left err2) -> bail_out ctxt err2 + + -- Rename the bindings + -- The typechecker (not the renamer) checks that all + -- the bindings are for the right class + -- (Slightly strangely) when scoped type variables are on, the + -- forall-d tyvars scope over the method bindings too + ; (mbinds', uprags', meth_fvs) <- rnMethodBinds False cls ktv_names mbinds uprags + + ; checkCanonicalInstances cls inst_ty' mbinds' + + -- Rename the associated types, and type signatures + -- Both need to have the instance type variables in scope + ; traceRn "rnSrcInstDecl" (ppr inst_ty' $$ ppr ktv_names) + ; ((ats', adts'), more_fvs) + <- bindLocalNamesFV ktv_names $ + do { (ats', at_fvs) <- rnATInstDecls rnTyFamInstDecl cls ktv_names ats + ; (adts', adt_fvs) <- rnATInstDecls rnDataFamInstDecl cls ktv_names adts + ; return ( (ats', adts'), at_fvs `plusFV` adt_fvs) } + + ; let all_fvs = meth_fvs `plusFV` more_fvs + `plusFV` inst_fvs + ; 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 + , cid_datafam_insts = adts' }, + all_fvs) } + -- We return the renamed associated data type declarations so + -- that they can be entered into the list of type declarations + -- for the binding group, but we also keep a copy in the instance. + -- The latter is needed for well-formedness checks in the type + -- checker (eg, to ensure that all ATs of the instance actually + -- receive a declaration). + -- NB: Even the copies in the instance declaration carry copies of + -- the instance context after renaming. This is a bit + -- strange, but should not matter (and it would be more work + -- to remove the context). + where + -- 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 ctxt (l, err_msg) = do + addErrAt l $ TcRnWithHsDocContext ctxt err_msg + pure $ mkUnboundName (mkTcOccFS (fsLit "")) + +rnFamEqn :: HsDocContext + -> AssocTyFamInfo + -> FamEqn GhcPs rhs + -> (HsDocContext -> rhs -> RnM (rhs', FreeVars)) + -> RnM (FamEqn GhcRn rhs', FreeVars) +rnFamEqn doc atfi + (FamEqn { feqn_tycon = tycon + , feqn_bndrs = outer_bndrs + , feqn_pats = pats + , feqn_fixity = fixity + , feqn_rhs = payload }) rn_payload + = do { tycon' <- lookupFamInstName mb_cls tycon + + -- all_imp_vars represent the implicitly bound type variables. This is + -- empty if we have an explicit `forall` (see + -- Note [forall-or-nothing rule] in GHC.Hs.Type), which means + -- ignoring pat_kity_vars, the free variables mentioned in the type patterns + -- on the LHS of the equation + -- + -- Some examples: + -- + -- @ + -- type family F a b + -- type instance forall a b c. F [(a, b)] c = a -> b -> c + -- -- all_imp_vars = [] + -- type instance F [(a, b)] c = a -> b -> c + -- -- all_imp_vars = [a, b, c] + -- + -- type family G :: Maybe a + -- type instance forall a. G = (Nothing :: Maybe a) + -- -- all_imp_vars = [] + -- + -- data family H :: k -> Type + -- data instance forall k. H :: k -> Type where ... + -- -- all_imp_vars = [] + -- data instance H :: k -> Type where ... + -- -- all_imp_vars = [k] + -- @ + -- + -- For associated type family instances, exclude the type variables + -- bound by the instance head with filterInScopeM (#19649). + ; all_imp_vars <- filterInScopeM $ pat_kity_vars + + ; bindHsOuterTyVarBndrs doc mb_cls all_imp_vars outer_bndrs $ \rn_outer_bndrs -> + do { (pats', pat_fvs) <- rnLHsTypeArgs (FamPatCtx tycon) pats + ; (payload', rhs_fvs) <- rn_payload doc payload + + -- Report unused binders on the LHS + -- See Note [Unused type variables in family instances] + ; let -- The SrcSpan that bindHsOuterFamEqnTyVarBndrs will attach to each + -- implicitly bound type variable Name in outer_bndrs' will + -- span the entire type family instance, which will be reflected in + -- -Wunused-type-patterns warnings. We can be a little more precise + -- than that by pointing to the LHS of the instance instead, which + -- is what lhs_loc corresponds to. + rn_outer_bndrs' = mapHsOuterImplicit (map (`setNameLoc` lhs_loc)) + rn_outer_bndrs + + groups :: [NonEmpty (LocatedN RdrName)] + groups = equivClasses cmpLocated pat_kity_vars + ; 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 + -- e.g. F a Int a = Bool + -- b) for associated instances, the variables + -- of the instance decl. See + -- Note [Unused type variables in family instances] + ; let nms_used = extendNameSetList rhs_fvs $ + nms_dups {- (a) -} ++ inst_head_tvs {- (b) -} + all_nms = hsOuterTyVarNames rn_outer_bndrs' + ; warnUnusedTypePatterns all_nms nms_used + + -- For associated family instances, if a type variable from the + -- parent instance declaration is mentioned on the RHS of the + -- associated family instance but not bound on the LHS, then reject + -- that type variable as being out of scope. + -- See Note [Renaming associated types]. + -- Per that Note, the LHS type variables consist of the variables + -- mentioned in the instance's type patterns (pat_fvs) + ; let improperly_scoped cls_tkv = + cls_tkv `elemNameSet` rhs_fvs + -- Mentioned on the RHS... + && not (cls_tkv `elemNameSet` pat_fvs) + -- ...but not bound on the LHS. + bad_tvs = filter improperly_scoped inst_head_tvs + ; for_ (nonEmpty bad_tvs) $ \ ne_bad_tvs -> + addErr $ + TcRnIllegalInstance $ IllegalFamilyInstance $ + FamInstRHSOutOfScopeTyVars Nothing ne_bad_tvs + + ; let eqn_fvs = rhs_fvs `plusFV` pat_fvs + -- See Note [Type family equations and occurrences] + all_fvs = case atfi of + NonAssocTyFamEqn ClosedTyFam + -> eqn_fvs + _ -> eqn_fvs `addOneFV` unLoc tycon' + + ; return (FamEqn { feqn_ext = noAnn + , feqn_tycon = tycon' + -- Note [Wildcards in family instances] + , feqn_bndrs = rn_outer_bndrs' + , feqn_pats = pats' + , feqn_fixity = fixity + , feqn_rhs = payload' }, + all_fvs) } } + where + -- The parent class, if we are dealing with an associated type family + -- instance. + mb_cls = case atfi of + NonAssocTyFamEqn _ -> Nothing + AssocTyFamDeflt cls -> Just cls + AssocTyFamInst cls _ -> Just cls + + -- The type variables from the instance head, if we are dealing with an + -- associated type family instance. + inst_head_tvs = case atfi of + NonAssocTyFamEqn _ -> [] + AssocTyFamDeflt _ -> [] + AssocTyFamInst _ inst_head_tvs -> inst_head_tvs + + pat_kity_vars = extractHsTyArgRdrKiTyVars pats + -- It is crucial that extractHsTyArgRdrKiTyVars return + -- duplicate occurrences, since they're needed to help + -- determine unused binders on the LHS. + + -- The SrcSpan of the LHS of the instance. For example, lhs_loc would be + -- the highlighted part in the example below: + -- + -- type instance F a b c = Either a b + -- ^^^^^ + lhs_loc = case map lhsTypeArgSrcSpan pats of + [] -> panic "rnFamEqn.lhs_loc" + [loc] -> loc + (loc:locs) -> loc `combineSrcSpans` last locs + +rnTyFamInstDecl :: AssocTyFamInfo + -> TyFamInstDecl GhcPs + -> RnM (TyFamInstDecl GhcRn, FreeVars) +rnTyFamInstDecl atfi (TyFamInstDecl { tfid_xtn = x, tfid_eqn = eqn }) + = do { (eqn', fvs) <- rnTyFamInstEqn atfi eqn + ; return (TyFamInstDecl { tfid_xtn = x, tfid_eqn = eqn' }, fvs) } + +-- | Tracks whether we are renaming: +-- +-- 1. A type family equation that is not associated +-- with a parent type class ('NonAssocTyFamEqn'). Examples: +-- +-- @ +-- type family F a +-- type instance F Int = Bool -- NonAssocTyFamEqn NotClosed +-- +-- type family G a where +-- G Int = Bool -- NonAssocTyFamEqn Closed +-- @ +-- +-- 2. An associated type family default declaration ('AssocTyFamDeflt'). +-- Example: +-- +-- @ +-- class C a where +-- type A a +-- type instance A a = a -> a -- AssocTyFamDeflt C +-- @ +-- +-- 3. An associated type family instance declaration ('AssocTyFamInst'). +-- Example: +-- +-- @ +-- instance C a => C [a] where +-- type A [a] = Bool -- AssocTyFamInst C [a] +-- @ +data AssocTyFamInfo + = NonAssocTyFamEqn + ClosedTyFamInfo -- Is this a closed type family? + | AssocTyFamDeflt + Name -- Name of the parent class + | AssocTyFamInst + Name -- Name of the parent class + [Name] -- Names of the tyvars of the parent instance decl + +-- | Tracks whether we are renaming an equation in a closed type family +-- equation ('ClosedTyFam') or not ('NotClosedTyFam'). +data ClosedTyFamInfo + = NotClosedTyFam + | ClosedTyFam + +rnTyFamInstEqn :: AssocTyFamInfo + -> TyFamInstEqn GhcPs + -> RnM (TyFamInstEqn GhcRn, FreeVars) +rnTyFamInstEqn atfi eqn@(FamEqn { feqn_tycon = tycon }) + = rnFamEqn (TySynCtx tycon) atfi eqn rnTySyn + + +rnTyFamDefltDecl :: Name + -> TyFamDefltDecl GhcPs + -> RnM (TyFamDefltDecl GhcRn, FreeVars) +rnTyFamDefltDecl cls = rnTyFamInstDecl (AssocTyFamDeflt cls) + +rnDataFamInstDecl :: AssocTyFamInfo + -> DataFamInstDecl GhcPs + -> RnM (DataFamInstDecl GhcRn, FreeVars) +rnDataFamInstDecl atfi (DataFamInstDecl { dfid_eqn = + eqn@(FamEqn { feqn_tycon = tycon })}) + = do { (eqn', fvs) <- + rnFamEqn (TyDataCtx tycon) atfi eqn rnDataDefn + ; return (DataFamInstDecl { dfid_eqn = eqn' }, fvs) } + +-- Renaming of the associated types in instances. + +-- 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 cls_tvs at_decls + = rnList (rnFamDecl (Just (cls, cls_tvs))) at_decls + +rnATInstDecls :: (AssocTyFamInfo -> -- The function that renames + decl GhcPs -> -- an instance. rnTyFamInstDecl + RnM (decl GhcRn, FreeVars)) -- or rnDataFamInstDecl + -> Name -- Class + -> [Name] + -> [LocatedA (decl GhcPs)] + -> RnM ([LocatedA (decl GhcRn)], FreeVars) +-- Used for data and type family defaults in a class decl +-- and the family instance declarations in an instance +-- +-- NB: We allow duplicate associated-type decls; +-- See Note [Associated type instances] in GHC.Tc.TyCl.Instance +rnATInstDecls rnFun cls tv_ns at_insts + = rnList (rnFun (AssocTyFamInst cls tv_ns)) at_insts + -- See Note [Renaming associated types] + +{- Note [Wildcards in family instances] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Wild cards can be used in type/data family instance declarations to indicate +that the name of a type variable doesn't matter. Each wild card will be +replaced with a new unique type variable. For instance: + + type family F a b :: * + type instance F Int _ = Int + +is the same as + + type family F a b :: * + type instance F Int b = Int + +This is implemented as follows: Unnamed wildcards remain unchanged after +the renamer, and then given fresh meta-variables during typechecking, and +it is handled pretty much the same way as the ones in partial type signatures. +We however don't want to emit hole constraints on wildcards in family +instances, so we turn on PartialTypeSignatures and turn off warning flag to +let typechecker know this. +See related Note [Wildcards in visible kind application] in GHC.Tc.Gen.HsType + +Note [Unused type variables in family instances] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When the flag -fwarn-unused-type-patterns is on, the compiler reports +warnings about unused type variables in type-family instances. A +tpye variable is considered used (i.e. cannot be turned into a wildcard) +when + + * it occurs on the RHS of the family instance + e.g. type instance F a b = a -- a is used on the RHS + + * it occurs multiple times in the patterns on the LHS + e.g. type instance F a a = Int -- a appears more than once on LHS + + * it is one of the instance-decl variables, for associated types + e.g. instance C (a,b) where + type T (a,b) = a + Here the type pattern in the type instance must be the same as that + for the class instance, so + type T (a,_) = a + would be rejected. So we should not complain about an unused variable b + +As usual, the warnings are not reported for type variables with names +beginning with an underscore. + +Extra-constraints wild cards are not supported in type/data family +instance declarations. + +Relevant tickets: #3699, #10586, #10982 and #11451. + +Note [Renaming associated types] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When renaming a type/data family instance, be it top-level or associated with +a class, we must check that all of the type variables mentioned on the RHS are +properly scoped. Specifically, the rule is this: + + Every variable mentioned on the RHS of a type instance declaration + (whether associated or not) must be mentioned on the LHS + +Here is a simple example of something we should reject: + + class C a b where + type F a x + instance C Int Bool where + type F Int x = z + +Here, `z` is mentioned on the RHS of the associated instance without being +mentioned on the LHS. The renamer will reject `z` as being out of scope without much fuss. + +Things get slightly trickier when the instance header itself binds type +variables. Consider this example (adapted from #5515): + + instance C (p,q) z where + type F (p,q) x = (x, z) + +According to the rule above, this instance is improperly scoped. However, due +to the way GHC's renamer works, `z` is /technically/ in scope, as GHC will +always bring type variables from an instance header into scope over the +associated type family instances. As a result, the renamer won't simply reject +the `z` as being out of scope (like it would for the `type F Int x = z` +example) unless further action is taken. It is important to reject this sort of +thing in the renamer, because if it is allowed to make it through to the +typechecker, unexpected shenanigans can occur (see #18021 for examples). + +To prevent these sorts of shenanigans, we reject programs like the one above +with an extra validity check in rnFamEqn. For each type variable bound in the +parent instance head, we check if it is mentioned on the RHS of the associated +family instance but not bound on the LHS. If any of the instance-head-bound +variables meet these criteria, we throw an error. +(See rnFamEqn.improperly_scoped for how this is implemented.) + +Some additional wrinkles: + +* This Note only applies to *instance* declarations. In *class* declarations + there is no RHS to worry about, and the class variables can all be in scope + (#5862): + + class Category (x :: k -> k -> *) where + type Ob x :: k -> Constraint + id :: Ob x a => x a a + (.) :: (Ob x a, Ob x b, Ob x c) => x b c -> x a b -> x a c + + Here 'k' is in scope in the kind signature, just like 'x'. + +* Although type family equations can bind type variables with explicit foralls, + it need not be the case that all variables that appear on the RHS must be + bound by a forall. For instance, the following is acceptable: + + class C4 a where + type T4 a b + instance C4 (Maybe a) where + type forall b. T4 (Maybe a) b = Either a b + + Even though `a` is not bound by the forall, this is still accepted because `a` + was previously bound by the `instance C4 (Maybe a)` part. (see #16116). + +* In addition to the validity check in rnFamEqn.improperly_scoped, there is an + additional check in GHC.Tc.Validity.checkFamPatBinders that checks each family + instance equation for type variables used on the RHS but not bound on the + LHS. This is not made redundant by rmFamEqn.improperly_scoped, as there are + programs that each check will reject that the other check will not catch: + + - checkValidFamPats is used on all forms of family instances, whereas + rmFamEqn.improperly_scoped only checks associated family instances. Since + checkFamPatBinders occurs after typechecking, it can catch programs that + introduce dodgy scoping by way of type synonyms (see #7536), which is + impractical to accomplish in the renamer. + - rnFamEqn.improperly_scoped catches some programs that, if allowed to escape + the renamer, would accidentally be accepted by the typechecker. Here is one + such program (#18021): + + class C5 a where + data family D a + + instance forall a. C5 Int where + data instance D Int = MkD a + + If this is not rejected in the renamer, the typechecker would treat this + program as though the `a` were existentially quantified, like so: + + data instance D Int = forall a. MkD a + + This is likely not what the user intended! + + Here is another such program (#9574): + + class Funct f where + type Codomain f + instance Funct ('KProxy :: KProxy o) where + type Codomain 'KProxy = NatTr (Proxy :: o -> Type) + + Where: + + data Proxy (a :: k) = Proxy + data KProxy (t :: Type) = KProxy + data NatTr (c :: o -> Type) + + Note that the `o` in the `Codomain 'KProxy` instance should be considered + improperly scoped. It does not meet the criteria for being explicitly + quantified, as it is not mentioned by name on the LHS. + However, `o` /is/ bound by the instance header, so if this + program is not rejected by the renamer, the typechecker would treat it as + though you had written this: + + instance Funct ('KProxy :: KProxy o) where + type Codomain ('KProxy @o) = NatTr (Proxy :: o -> Type) + + Although this is a valid program, it's probably a stretch too far to turn + `type Codomain 'KProxy = ...` into `type Codomain ('KProxy @o) = ...` here. + If the user really wants the latter, it is simple enough to communicate + their intent by mentioning `o` on the LHS by name. + +* Historical note: Previously we had to add type variables from the outermost + kind signature on the RHS to the scope of associated type family instance, + i.e. GHC did implicit quantification over them. But now that we implement + GHC Proposal #425 "Invisible binders in type declarations" + we don't need to do this anymore. + +Note [Type family equations and occurrences] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In most data/type family equations, the type family name used in the equation +is treated as an occurrence. For example: + + module A where + type family F a + + module B () where + import B (F) + type instance F Int = Bool + +We do not want to warn about `F` being unused in the module `B`, as the +instance constitutes a use site for `F`. The exception to this rule is closed +type families, whose equations constitute a definition, not occurrences. For +example: + + module C () where + type family CF a where + CF Char = Float + +Here, we /do/ want to warn that `CF` is unused in the module `C`, as it is +defined but not used (#18470). + +GHC accomplishes this in rnFamEqn when determining the set of free +variables to return at the end. If renaming a data family or open type family +equation, we add the name of the type family constructor to the set of returned +free variables to ensure that the name is marked as an occurrence. If renaming +a closed type family equation, we avoid adding the type family constructor name +to the free variables. This is quite simple, but it is not a perfect solution. +Consider this example: + + module X () where + type family F a where + F Int = Bool + F Double = F Int + +At present, GHC will treat any use of a type family constructor on the RHS of a +type family equation as an occurrence. Since `F` is used on the RHS of the +second equation of `F`, it is treated as an occurrence, causing `F` not to be +warned about. This is not ideal, since `F` isn't exported—it really /should/ +cause a warning to be emitted. There is some discussion in #10089/#12920 about +how this limitation might be overcome, but until then, we stick to the +simplistic solution above, as it fixes the egregious bug in #18470. +-} + + +{- +********************************************************* +* * +\subsection{Stand-alone deriving declarations} +* * +********************************************************* +-} + +rnSrcDerivDecl :: DerivDecl GhcPs -> RnM (DerivDecl GhcRn, FreeVars) +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 + ; (mds', ty', fvs) <- rnLDerivStrategy ctxt mds $ rnHsSigWcType ctxt 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). + ; addNoNestedForallsContextsErr ctxt + NFC_StandaloneDerivedInstanceHead + (getLHsInstDeclHead $ dropWildCards ty') + ; inst_warn_rn <- mapM rnLWarningTxt inst_warn_ps + ; return (DerivDecl (inst_warn_rn, ann) ty' mds' overlap, fvs) } + where + ctxt = DerivDeclCtx + nowc_ty = dropWildCards ty + +{- +********************************************************* +* * +\subsection{Rules} +* * +********************************************************* +-} + +rnHsRuleDecls :: RuleDecls GhcPs -> RnM (RuleDecls GhcRn, FreeVars) +rnHsRuleDecls (HsRules { rds_ext = (_, src) + , rds_rules = rules }) + = do { (rn_rules,fvs) <- rnList rnHsRuleDecl rules + ; return (HsRules { rds_ext = src + , rds_rules = rn_rules }, fvs) } + +rnHsRuleDecl :: RuleDecl GhcPs -> RnM (RuleDecl GhcRn, FreeVars) +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 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] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Check the shape of a rewrite rule LHS. Currently we only allow +LHSs of the form @(f e1 .. en)@, where @f@ is not one of the +@forall@'d variables. + +We used restrict the form of the 'ei' to prevent you writing rules +with LHSs with a complicated desugaring (and hence unlikely to match); +(e.g. a case expression is not allowed: too elaborate.) + +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 :: 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 + Nothing -> return () + Just bad -> failWithTc (badRuleLhsErr rule_name lhs' bad) + + -- Check that LHS vars are all bound + ; let bad_vars = [var | var <- ids, not (var `elemNameSet` fv_lhs')] + ; mapM_ (addErr . TcRnUnusedVariableInRuleDecl rule_name) bad_vars } + +validRuleLhs :: [Name] -> LHsExpr GhcRn -> Maybe (HsExpr GhcRn) +-- Nothing => OK +-- Just e => Not ok, and e is the offending sub-expression +validRuleLhs foralls lhs + = checkl lhs + where + checkl = check . unLoc + + 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 (HsVar _ lv) + | 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 + checkl_e _ = Nothing + -- Was (check_e e); see Note [Rule LHS validity checking] + +{- Commented out; see Note [Rule LHS validity checking] above + check_e (HsVar v) = Nothing + check_e (HsPar e) = checkl_e e + check_e (HsLit e) = Nothing + check_e (HsOverLit e) = Nothing + + check_e (OpApp e1 op _ e2) = checkl_e e1 `mplus` checkl_e op `mplus` checkl_e e2 + check_e (HsApp e1 e2) = checkl_e e1 `mplus` checkl_e e2 + check_e (NegApp e _) = checkl_e e + check_e (ExplicitList _ es) = checkl_es es + check_e other = Just other -- Fails + + checkl_es es = foldr (mplus . checkl_e) Nothing es +-} + + +badRuleLhsErr :: FastString -> LHsExpr GhcRn -> HsExpr GhcRn -> TcRnMessage +badRuleLhsErr name lhs bad_e + = TcRnIllegalRuleLhs errReason name lhs bad_e + where + errReason = case bad_e of + HsHole (HoleVar (L _ uv)) -> + UnboundVariable uv $ notInScopeErr WL_Global uv + _ -> IllegalExpression + +{- ************************************************************** + * * + Renaming type, class, instance and role declarations +* * +***************************************************************** + +@rnTyDecl@ uses the `global name function' to create a new type +declaration in which local names have been replaced by their original +names, reporting any unknown names. + +Renaming type variables is a pain. Because they now contain uniques, +it is necessary to pass in an association list which maps a parsed +tyvar to its @Name@ representation. +In some cases (type signatures of values), +it is even necessary to go over the type first +in order to get the set of tyvars used by it, make an assoc list, +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 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 + + data T f a = MkT f a + data S f a = MkS f (T f a) + + This has a kind error, but the error message is better if you + check T first, (fixing its kind) and *then* S. If you do kind + 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] + +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. + +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. + +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 + +------------------------------------ +So much for why we want SCCs. What about how and when we construct them? + +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 + +And now the deep dive: + +(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: + + tyClGroupTyClDecls = Data.List.concatMap group_tyclds + tyClGroupInstDecls = Data.List.concatMap group_instds + tyClGroupRoleDecls = Data.List.concatMap group_roles + tyClGroupKindSigs = Data.List.concatMap group_kisigs + + In practice, the parser just puts all declarations in a single `TyClGroup`, + so the `concatMap` is a no-op. + +(TCDEP2) Rename each declaration separately, yielding the following lists + in `rnTyClDecls`: + + tycls_w_fvs :: [(LTyClDecl GhcRn, FreeVars)] + instds_w_fvs :: [(LInstDecl GhcRn, FreeVars)] + kisigs_w_fvs :: [(LStandaloneKindSig GhcRn, FreeVars)] + role_annots :: [LRoleAnnotDecl GhcRn] + + The `FreeVars` are the free type/data constructors of the decl. 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} + +(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: + + 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} + + The `FreeVars` are not used "as is" to create the edges. They first undergo a + few transformations. + + (TCDEP3.fvs_kisig) If a standalone kind signature is present, add its free + variables to those of the declaration. Consider: + + data A = MkA + data B = MkB + + type P :: A -> Type -- sig FVs: {A, Type} + data P x = MkP (Proxy MkB) -- decl FVs: {Proxy, MkB} + + By adding the sig and decl FVs together, we get {A, Type, Proxy, MkB}. + Then proceed to the next step. + + (TCDEP3.fvs_parent) Replace any mention of a (promoted) data constructor + with its parent TyCon. Consider the FVs from the previous step: + + the name set {A, Type, Proxy, MkB} + turns into {A, Type, Proxy, B} + + MkB does not get its own node in the graph, so an edge to it must actually + point to B. + + (TCDEP3.fvs_nogbl) Filter out references to type constructors outside this + `HsGroup`. They just clutter things up: + + the name set {A, Type, Proxy, B} + turns into {A, B} + + Note [Prepare TyClGroup FVs] describes these transformations in more detail. + Back to our `P` example, the final nodes and edges are as follows: + + 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 + data family D a + data instance D Int = D1 + data S = MkS (Proxy 'D1) + +Here the declaration of S depends on the /data instance/ declaration +for 'D Int'. That makes things a lot more complicated, especially +if the data instance is an associated type of an enclosing class instance. +(And the class instance might have several associated type instances +with different dependency structure!) + +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. +-} + + +rnTyClDecls :: [TyClGroup GhcPs] + -> RnM ([TyClGroup GhcRn], FreeVars) +-- Rename the declarations and do dependency analysis on them +rnTyClDecls tycl_ds + = 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" $ + vcat [ text "tyClGroupTyClDecls:" <+> ppr tycls_w_fvs + , text "tc_names:" <+> ppr tc_names ] + ; kisigs_w_fvs <- rnStandaloneKindSignatures tc_names (tyClGroupKindSigs tycl_ds) + ; instds_w_fvs <- mapM (wrapLocFstMA rnSrcInstDecl) (tyClGroupInstDecls tycl_ds) + ; role_annots <- rnRoleAnnots tc_names (tyClGroupRoleDecls tycl_ds) + + -- 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 tc_names kisig_fv_env tycls_w_fvs + (kisig_env, kisig_fv_env) = mkKindSig_fv_env kisigs_w_fvs + role_annot_env = mkRoleAnnotEnv role_annots + + -- 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 + + ; traceRn "rnTycl dependency analysis made groups" (ppr all_groups) + + ; 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 + + ; 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 + -> SCC (LTyClDecl GhcRn, NameSet) + -> TyClGroup GhcRn + mk_group role_env kisig_env scc = group + where + (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 = 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) + +lookupKindSig_FV_Env :: KindSig_FV_Env -> Name -> FreeVars +lookupKindSig_FV_Env (KindSig_FV_Env e) name + = fromMaybe emptyFVs (lookupNameEnv e name) + +-- | Standalone kind signatures. +type KindSigEnv = NameEnv (LStandaloneKindSig GhcRn) + +mkKindSig_fv_env :: [(LStandaloneKindSig GhcRn, FreeVars)] -> (KindSigEnv, KindSig_FV_Env) +mkKindSig_fv_env kisigs_w_fvs = (kisig_env, kisig_fv_env) + where + kisig_env = mapNameEnv fst compound_env + kisig_fv_env = KindSig_FV_Env (mapNameEnv snd compound_env) + compound_env :: NameEnv (LStandaloneKindSig GhcRn, FreeVars) + = mkNameEnvWith (standaloneKindSigName . unLoc . fst) kisigs_w_fvs + +getKindSigs :: [Name] -> KindSigEnv -> [LStandaloneKindSig GhcRn] +getKindSigs bndrs kisig_env = mapMaybe (lookupNameEnv kisig_env) bndrs + +rnStandaloneKindSignatures + :: NameSet -- names of types and classes in the current TyClGroup + -> [LStandaloneKindSig GhcPs] + -> RnM [(LStandaloneKindSig GhcRn, FreeVars)] +rnStandaloneKindSignatures tc_names kisigs + = do { let (no_dups, dup_kisigs) = removeDupsOn get_name kisigs + get_name = standaloneKindSigName . unLoc + ; mapM_ dupKindSig_Err dup_kisigs + ; mapM (wrapLocFstMA (rnStandaloneKindSignature tc_names)) no_dups + } + +rnStandaloneKindSignature + :: NameSet -- names of types and classes in the current TyClGroup + -> StandaloneKindSig GhcPs + -> RnM (StandaloneKindSig GhcRn, FreeVars) +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) 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 + -> NameSet -- Names in the current HsGroup + -> KindSig_FV_Env -- FVs of standalone kind signatures + -> [(LTyClDecl GhcRn, FreeVars)] + -> [SCC (LTyClDecl GhcRn, NameSet)] +depAnalTyClDecls rdr_env tc_names kisig_fv_env ds_w_fvs + = stronglyConnCompFromEdgedVerticesUniq edges + where + -- 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 + ; 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] + } + ] + +toParents :: GlobalRdrEnv -> NameSet -> NameSet +toParents rdr_env ns + = nonDetStrictFoldUniqSet add emptyNameSet ns + -- It's OK to use a non-deterministic fold because we immediately forget the + -- ordering by creating a set + where + add n s = extendNameSet s (getParent rdr_env n) + +getParent :: GlobalRdrEnv -> Name -> Name +getParent rdr_env n + = case lookupGRE_Name rdr_env n of + Just gre -> case greParent gre of + ParentIs { par_is = p } -> p + _ -> 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 +* * +****************************************************** -} + +-- | Renames role annotations, returning them as the values in a NameEnv +-- and checks for duplicate role annotations. +-- It is quite convenient to do both of these in the same place. +-- See also Note [Role annotations in the renamer] +rnRoleAnnots :: NameSet + -> [LRoleAnnotDecl GhcPs] + -> RnM [LRoleAnnotDecl GhcRn] +rnRoleAnnots tc_names role_annots + = do { -- Check for duplicates *before* renaming, to avoid + -- lumping together all the unboundNames + let (no_dups, dup_annots) = removeDupsOn get_name role_annots + get_name = roleAnnotDeclName . unLoc + ; mapM_ dupRoleAnnotErr dup_annots + ; mapM (wrapLocMA rn_role_annot1) no_dups } + where + rn_role_annot1 (RoleAnnotDecl _ tycon roles) + = 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) + SigLikeRoleAnnotation + tycon + ; return $ RoleAnnotDecl noExtField tycon' roles } + +dupRoleAnnotErr :: NonEmpty (LRoleAnnotDecl GhcPs) -> RnM () +dupRoleAnnotErr list@(L loc _ :| _) + = addErrAt (locA loc) (TcRnDuplicateRoleAnnot list) + +dupKindSig_Err :: NonEmpty (LStandaloneKindSig GhcPs) -> RnM () +dupKindSig_Err list@(L loc _ :| _) + = addErrAt (locA loc) (TcRnDuplicateKindSig list) + +{- Note [Role annotations in the renamer] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We must ensure that a type's role annotation is put in the same group as the +proper type declaration. This is because role annotations are needed during +type-checking when creating the type's TyCon. So, rnRoleAnnots builds a +NameEnv (LRoleAnnotDecl Name) that maps a name to a role annotation for that +type, if any. Then, this map can be used to add the role annotations to the +groups after dependency analysis. + +This process checks for duplicate role annotations, where we must be careful +to do the check *before* renaming to avoid calling all unbound names duplicates +of one another. + +The renaming process, as usual, might identify and report errors for unbound +names. This is done by using lookupSigCtxtOccRn in rnRoleAnnots (using +lookupGlobalOccRn led to #8485). +-} + + +{- ****************************************************** +* * + Dependency info for instances +* * +****************************************************** -} + +---------------------------------------------------------- +-- | 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 + 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] } + +{- ****************************************************** +* * + Renaming a type or class declaration +* * +****************************************************** -} + +rnTyClDecl :: TyClDecl GhcPs + -> RnM (TyClDecl GhcRn, FreeVars) + +-- All flavours of top-level type family declarations ("type family", "newtype +-- family", and "data family") +rnTyClDecl (FamDecl { tcdFam = fam }) + = do { (fam', fvs) <- rnFamDecl Nothing fam + ; return (FamDecl noExtField fam', fvs) } + +rnTyClDecl (SynDecl { tcdLName = tycon, tcdTyVars = tyvars, + tcdFixity = fixity, tcdRhs = rhs }) + = do { tycon' <- lookupLocatedTopBndrRnN WL_TyCon tycon + ; let kvs = extractHsTyRdrTyVarsKindVars rhs + doc = TySynCtx tycon + ; traceRn "rntycl-ty" (ppr tycon <+> ppr kvs) + ; bindHsQTyVars doc Nothing kvs tyvars $ \ tyvars' free_rhs_kvs -> + do { mapM_ warn_implicit_kvs (nubL free_rhs_kvs) + ; (rhs', fvs) <- rnTySyn doc rhs + ; return (SynDecl { tcdLName = tycon', tcdTyVars = tyvars' + , tcdFixity = fixity + , tcdRhs = rhs', tcdSExt = fvs }, fvs) } } + where + warn_implicit_kvs :: LocatedN RdrName -> RnM () + warn_implicit_kvs kv = + addDiagnosticAt (getLocA kv) (TcRnImplicitRhsQuantification kv) + +-- "data", "newtype" declarations +rnTyClDecl (DataDecl + { tcdLName = tycon, tcdTyVars = tyvars, + tcdFixity = fixity, + tcdDataDefn = defn@HsDataDefn{ dd_cons = cons, dd_kindSig = kind_sig} }) + = do { tycon' <- lookupLocatedTopBndrRnN WL_TyCon tycon + ; let kvs = extractDataDefnKindVars defn + doc = TyDataCtx tycon + new_or_data = dataDefnConsNewOrData cons + ; traceRn "rntycl-data" (ppr tycon <+> ppr kvs) + ; bindHsQTyVars doc Nothing kvs tyvars $ \ tyvars' free_rhs_kvs -> + do { (defn', fvs) <- rnDataDefn doc defn + ; cusk <- data_decl_has_cusk tyvars' new_or_data (null free_rhs_kvs) kind_sig + ; let rn_info = DataDeclRn { tcdDataCusk = cusk + , tcdFVs = fvs } + ; traceRn "rndata" (ppr tycon <+> ppr cusk <+> ppr free_rhs_kvs) + ; return (DataDecl { tcdLName = tycon' + , tcdTyVars = tyvars' + , tcdFixity = fixity + , tcdDataDefn = defn' + , tcdDExt = rn_info }, fvs) } } + +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' <- lookupLocatedTopBndrRnN WL_TyCon lcls + ; let cls' = unLoc lcls' + kvs = [] -- No scoped kind vars except those in + -- kind signatures on the tyvars + + -- Tyvars scope over superclass context and method signatures + ; ((tyvars', context', fds', ats'), stuff_fvs) + <- bindHsQTyVars cls_doc Nothing kvs tyvars $ \ tyvars' _ -> do + -- Checks for distinct tyvars + { (context', cxt_fvs) <- rnMaybeContext cls_doc context + ; fds' <- rnFds fds + -- The fundeps have no free variables + ; (ats', fv_ats) <- rnATDecls cls' (hsAllLTyVarNames tyvars') ats + ; let fvs = cxt_fvs `plusFV` + fv_ats + ; return ((tyvars', context', fds', ats'), fvs) } + + ; (at_defs', fv_at_defs) <- rnList (rnTyFamDefltDecl cls') at_defs + + -- No need to check for duplicate associated type decls + -- since that is done by GHC.Rename.Names.extendGlobalRdrEnvRn + + -- Check the signatures + -- First process the class op sigs (op_sigs), then the fixity sigs (non_op_sigs). + ; let sig_rdr_names_w_locs = + [op | L _ (ClassOpSig _ False ops _) <- sigs + , op <- ops] + ; checkDupRdrNames sig_rdr_names_w_locs + -- Typechecker is responsible for checking that we only + -- give default-method bindings for things in this class. + -- The renamer *could* check this for class decls, but can't + -- for instance decls. + + -- The newLocals call is tiresome: given a generic class decl + -- class C a where + -- op :: a -> a + -- op {| x+y |} (Inl a) = ... + -- op {| x+y |} (Inr b) = ... + -- op {| a*b |} (a*b) = ... + -- we want to name both "x" tyvars with the same unique, so that they are + -- easy to group together in the typechecker. + ; (mbinds', sigs', meth_fvs) + <- rnMethodBinds True cls' (hsAllLTyVarNames tyvars') mbinds sigs + -- No need to check for duplicate method signatures + -- since that is done by GHC.Rename.Names.extendGlobalRdrEnvRn + -- and the methods are already in scope + + ; let all_fvs = meth_fvs `plusFV` stuff_fvs `plusFV` fv_at_defs + ; docs' <- traverse rnLDocDecl docs + ; return (ClassDecl { tcdCtxt = context', tcdLName = lcls', + tcdTyVars = tyvars', tcdFixity = fixity, + tcdFDs = fds', tcdSigs = sigs', + tcdMeths = mbinds', tcdATs = ats', tcdATDefs = at_defs', + tcdDocs = docs', tcdCExt = all_fvs }, + all_fvs ) } + where + cls_doc = ClassDeclCtx lcls + +-- 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 + { -- See Note [Unlifted Newtypes and CUSKs], and for a broader + -- picture, see Note [Implementation of UnliftedNewtypes]. + ; unlifted_newtypes <- xoptM LangExt.UnliftedNewtypes + ; let non_cusk_newtype + | NewType <- new_or_data = + unlifted_newtypes && isNothing kind_sig + | otherwise = False + -- See Note [CUSKs: complete user-supplied kind signatures] in GHC.Hs.Decls + ; return $ hsTvbAllKinded tyvars && no_rhs_kvs && not non_cusk_newtype + } + +{- Note [Unlifted Newtypes and CUSKs] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When unlifted newtypes are enabled, a newtype must have a kind signature +in order to be considered have a CUSK. This is because the flow of +kind inference works differently. Consider: + + newtype Foo = FooC Int + +When UnliftedNewtypes is disabled, we decide that Foo has kind +`TYPE 'LiftedRep` without looking inside the data constructor. So, we +can say that Foo has a CUSK. However, when UnliftedNewtypes is enabled, +we fill in the kind of Foo as a metavar that gets solved by unification +with the kind of the field inside FooC (that is, Int, whose kind is +`TYPE 'LiftedRep`). But since we have to look inside the data constructors +to figure out the kind signature of Foo, it does not have a CUSK. + +See Note [Implementation of UnliftedNewtypes] for where this fits in to +the broader picture of UnliftedNewtypes. +-} + +-- "type" and "type instance" declarations +rnTySyn :: HsDocContext -> LHsType GhcPs -> RnM (LHsType GhcRn, FreeVars) +rnTySyn doc rhs = rnLHsType doc rhs + +rnDataDefn :: HsDocContext -> HsDataDefn GhcPs + -> RnM (HsDataDefn GhcRn, FreeVars) +rnDataDefn doc (HsDataDefn { dd_cType = cType, dd_ctxt = context, dd_cons = condecls + , dd_kindSig = m_sig, dd_derivs = derivs }) + = do { -- DatatypeContexts (i.e., stupid contexts) can't be combined with + -- GADT syntax. See Note [The stupid context] in GHC.Core.DataCon. + checkTc (h98_style || null (fromMaybeContext context)) + (TcRnStupidThetaInGadt doc) + + -- Check restrictions on "type data" declarations. + -- See Note [Type data declarations]. + ; when (isTypeDataDefnCons condecls) check_type_data + + ; (m_sig', sig_fvs) <- case m_sig of + Just sig -> first Just <$> rnLHsKind doc sig + Nothing -> return (Nothing, emptyFVs) + ; (context', fvs1) <- rnMaybeContext doc context + ; (derivs', fvs3) <- rn_derivs derivs + + -- For the constructor declarations, drop the LocalRdrEnv + -- in the GADT case, where the type variables in the declaration + -- do not scope over the constructor signatures + -- data T a where { T1 :: forall b. b-> b } + ; let { zap_lcl_env | h98_style = \ thing -> thing + | otherwise = setLocalRdrEnv emptyLocalRdrEnv } + ; (condecls', con_fvs) <- zap_lcl_env $ rnConDecls condecls + -- No need to check for duplicate constructor decls + -- since that is done by GHC.Rename.Names.extendGlobalRdrEnvRn + + ; let all_fvs = fvs1 `plusFV` fvs3 `plusFV` + con_fvs `plusFV` sig_fvs + ; return ( HsDataDefn { dd_ext = noAnn, dd_cType = cType + , dd_ctxt = context', dd_kindSig = m_sig' + , dd_cons = condecls' + , dd_derivs = derivs' } + , all_fvs ) + } + where + h98_style = not $ anyLConIsGadt condecls -- Note [Stupid theta] + + rn_derivs ds + = do { deriv_strats_ok <- xoptM LangExt.DerivingStrategies + ; failIfTc (lengthExceeds ds 1 && not deriv_strats_ok) + TcRnIllegalMultipleDerivClauses + ; (ds', fvs) <- mapFvRn (rnLHsDerivingClause doc) ds + ; return (ds', fvs) } + + -- Given a "type data" declaration, check that the TypeData extension + -- is enabled and check restrictions (R1), (R2), (R3) and (R5) + -- on the declaration. See Note [Type data declarations]. + check_type_data + = do { unlessXOptM LangExt.TypeData $ failWith TcRnIllegalTypeData + ; unless (null (fromMaybeContext context)) $ + failWith $ TcRnTypeDataForbids TypeDataForbidsDatatypeContexts + ; mapM_ (addLocM check_type_data_condecl) condecls + ; unless (null derivs) $ + failWith $ TcRnTypeDataForbids TypeDataForbidsDerivingClauses + } + + -- Check restrictions (R2) and (R3) on a "type data" constructor. + -- See Note [Type data declarations]. + check_type_data_condecl :: ConDecl GhcPs -> RnM () + check_type_data_condecl condecl + = do { + ; when (has_labelled_fields condecl) $ + failWith $ TcRnTypeDataForbids TypeDataForbidsLabelledFields + ; when (has_strictness_flags condecl) $ + failWith $ TcRnTypeDataForbids TypeDataForbidsStrictnessAnnotations + } + + has_labelled_fields (ConDeclGADT { con_g_args = RecConGADT _ _ }) = True + has_labelled_fields (ConDeclH98 { con_args = RecCon flds }) + = not (null (unLoc flds)) + has_labelled_fields _ = False + + has_strictness_flags condecl + = any isSrcStrict (con_arg_bangs condecl) + + 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] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +With the TypeData extension (GHC proposal #106), one can write `type data` +declarations, like + + type data Nat = Zero | Succ Nat + +or equivalently in GADT style: + + type data Nat where + Zero :: Nat + Succ :: Nat -> Nat + +This defines the constructors `Zero` and `Succ` in the TcCls namespace +(type constructors and classes) instead of the Data namespace (data +constructors). This contrasts with the DataKinds extension, which +allows constructors defined in the Data namespace to be promoted to the +TcCls namespace at the point of use in a type. + +Type data declarations have the syntax of `data` declarations (but not +`newtype` declarations), either ordinary algebraic data types or GADTs, +preceded by `type`, with the following restrictions: + +(R0) 'data' decls only, not 'newtype' decls. This is checked by + the parser. + +(R1) There are no data type contexts (even with the DatatypeContexts + extension). + +(R2) There are no labelled fields. Perhaps these could be supported + using type families, but they are omitted for now. + +(R3) There are no strictness flags, because they don't make sense at + the type level. + +(R4) The types of the constructors contain no constraints. + +(R5) There are no deriving clauses. + +The data constructors of a `type data` declaration obey the following +Core invariant: + +(I1) The data constructors of a `type data` declaration may be mentioned in + /types/, but never in /terms/ or the /pattern of a case alternative/. + +Wrinkles: + +(W0) Wrappers. The data constructor of a `type data` declaration has a worker + (like every data constructor) but does /not/ have a wrapper. Wrappers + only make sense for value-level data constructors. Indeed, the worker Id + is never used (invariant (I1)), so it barely makes sense to talk about + the worker. A `type data` constructor only shows up in types, where it + appears as a TyCon, specifically a PromotedDataCon -- no Id in sight. + See #24620 for an example of what happens if you accidentally include + a wrapper. + + See `wrapped_reqd` in GHC.Types.Id.Make.mkDataConRep` for the place where + this check is implemented. + + This specifically includes `type data` declarations implemented as GADTs, + such as this example from #22948: + + type data T a where + A :: T Int + B :: T a + + If `T` were an ordinary `data` declaration, then `A` would have a wrapper + to account for the GADT-like equality in its return type. Because `T` is + declared as a `type data` declaration, however, the wrapper is omitted. + +(W1) To prevent users from conjuring up `type data` values at the term level, + we disallow using the tagToEnum# function on a type headed by a `type + data` type. For instance, GHC will reject this code: + + type data Letter = A | B | C + + f :: Letter + f = tagToEnum# 0# + + See `GHC.Tc.Gen.App.checkTagToEnum`, specifically `check_enumeration`. + +(W2) Although `type data` data constructors do not exist at the value level, + it is still possible to match on a value whose type is headed by a `type data` + type constructor, such as this example from #22964: + + type data T a where + A :: T Int + B :: T a + + f :: T a -> () + f x = case x of {} + + And yet we must guarantee invariant (I1). This has three consequences: + + (W2a) During checking the coverage of `f`'s pattern matches, we treat `T` + as if it were an empty data type so that GHC does not warn the user + to match against `A` or `B`. (Otherwise, you end up with the bug + reported in #22964.) See GHC.HsToCore.Pmc.Solver.vanillaCompleteMatchTC. + + (W2b) In `GHC.Core.Utils.refineDataAlt`, do /not/ fill in the DEFAULT case + 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`, 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 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: + +* The parser recognizes `type data` (but not `type newtype`); this ensures (R0). + +* During the initial construction of the AST, + GHC.Parser.PostProcess.checkNewOrData sets the `Bool` argument of the + `DataTypeCons` inside a `HsDataDefn` to mark a `type data` declaration. + It also puts the the constructor names (`Zero` and `Succ` in our + example) in the TcCls namespace. + +* GHC.Rename.Module.rnDataDefn calls `check_type_data` on these + declarations, which checks that the TypeData extension is enabled and + checks restrictions (R1), (R2), (R3) and (R5). They could equally + well be checked in the typechecker, but we err on the side of catching + imposters early. + +* GHC.Tc.TyCl.checkValidDataCon checks restriction (R4) on these declarations. + +* When beginning to type check a mutually recursive group of declarations, + the `type data` constructors (`Zero` and `Succ` in our example) are + added to the type-checker environment as `APromotionErr TyConPE` by + GHC.Tc.TyCl.mkPromotionErrorEnv, so they cannot be used within the + recursive group. This mirrors the DataKinds behaviour described + at Note [Recursion and promoting data constructors] in GHC.Tc.TyCl. + For example, this is rejected: + + type data T f = K (f (K Int)) -- illegal: tycon K is recursively defined + +* The `type data` data type, such as `Nat` in our example, is represented + by a `TyCon` that is an `AlgTyCon`, but its `AlgTyConRhs` has the + `is_type_data` field set. + +* The constructors of the data type, `Zero` and `Succ` in our example, + are each represented by a `DataCon` as usual. That `DataCon`'s + `dcPromotedField` is a `TyCon` (for `Zero`, say) that you can use + in a type. + +* After a `type data` declaration has been type-checked, the + type-checker environment entry (a `TyThing`) for each constructor + (`Zero` and `Succ` in our example) is + - just an `ATyCon` for the promoted type constructor, + - not the bundle (`ADataCon` for the data con, `AnId` for the work id, + wrap id) required for a normal data constructor + See GHC.Types.TyThing.implicitTyConThings. + +* GHC.Core.TyCon.isDataKindsPromotedDataCon ignores promoted constructors + from `type data`, which do not use the distinguishing quote mark added + to constructors promoted by DataKinds. + +* 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. + +* The `is_type_data` field is copied into a Boolean argument + of the `IfDataTyCon` constructor of `IfaceConDecls` by + GHC.Iface.Make.tyConToIfaceDecl. + +* The Template Haskell `Dec` type has an constructor `TypeDataD` for + `type data` declarations. When these are converted back to Hs types + in a splice, the constructors are placed in the TcCls namespace. + +-} + +rnLHsDerivingClause :: HsDocContext -> LHsDerivingClause GhcPs + -> RnM (LHsDerivingClause GhcRn, FreeVars) +rnLHsDerivingClause doc + (L loc (HsDerivingClause + { deriv_clause_ext = noExtField + , deriv_clause_strategy = dcs + , deriv_clause_tys = dct })) + = do { (dcs', dct', fvs) + <- rnLDerivStrategy doc dcs $ rn_deriv_clause_tys dct + ; pure ( L loc (HsDerivingClause { deriv_clause_ext = noExtField + , deriv_clause_strategy = dcs' + , deriv_clause_tys = dct' }) + , fvs ) } + where + rn_deriv_clause_tys :: LDerivClauseTys GhcPs + -> RnM (LDerivClauseTys GhcRn, FreeVars) + rn_deriv_clause_tys (L l dct) = case dct of + DctSingle x ty -> do + (ty', fvs) <- rn_clause_pred ty + pure (L l (DctSingle x ty'), fvs) + DctMulti x tys -> do + (tys', fvs) <- mapFvRn rn_clause_pred tys + pure (L l (DctMulti x tys'), fvs) + + rn_clause_pred :: LHsSigType GhcPs -> RnM (LHsSigType GhcRn, FreeVars) + rn_clause_pred pred_ty = do + checkInferredVars doc pred_ty + ret@(pred_ty', _) <- rnHsSigType doc TypeLevel pred_ty + -- Check if there are any nested `forall`s, which are illegal in a + -- `deriving` clause. + -- See Note [No nested foralls or contexts in instance types] + -- (Wrinkle: Derived instances) in GHC.Hs.Type. + addNoNestedForallsContextsErr doc NFC_DerivedClassType + (getLHsInstDeclHead pred_ty') + pure ret + +rnLDerivStrategy :: forall a. + HsDocContext + -> Maybe (LDerivStrategy GhcPs) + -> RnM (a, FreeVars) + -> RnM (Maybe (LDerivStrategy GhcRn), a, FreeVars) +rnLDerivStrategy doc mds thing_inside + = case mds of + Nothing -> boring_case Nothing + Just (L loc ds) -> + setSrcSpanA loc $ do + (ds', thing, fvs) <- rn_deriv_strat ds + pure (Just (L loc ds'), thing, fvs) + where + rn_deriv_strat :: DerivStrategy GhcPs + -> RnM (DerivStrategy GhcRn, a, FreeVars) + rn_deriv_strat ds = do + let extNeeded :: LangExt.Extension + extNeeded + | ViaStrategy{} <- ds + = LangExt.DerivingVia + | otherwise + = LangExt.DerivingStrategies + + unlessXOptM extNeeded $ + failWith $ TcRnIllegalDerivStrategy ds + + case ds of + StockStrategy _ -> boring_case (StockStrategy noExtField) + AnyclassStrategy _ -> boring_case (AnyclassStrategy noExtField) + NewtypeStrategy _ -> boring_case (NewtypeStrategy noExtField) + ViaStrategy (XViaStrategyPs _ via_ty) -> + do checkInferredVars doc via_ty + (via_ty', fvs1) <- rnHsSigType doc TypeLevel via_ty + let HsSig { sig_bndrs = via_outer_bndrs + , sig_body = via_body } = unLoc via_ty' + via_tvs = hsOuterTyVarNames via_outer_bndrs + -- Check if there are any nested `forall`s, which are illegal in a + -- `via` type. + -- See Note [No nested foralls or contexts in instance types] + -- (Wrinkle: Derived instances) in GHC.Hs.Type. + addNoNestedForallsContextsErr doc + NFC_ViaType via_body + (thing, fvs2) <- bindLocalNamesFV via_tvs thing_inside + pure (ViaStrategy via_ty', thing, fvs1 `plusFV` fvs2) + + boring_case :: ds -> RnM (ds, a, FreeVars) + boring_case ds = do + (thing, fvs) <- thing_inside + pure (ds, thing, fvs) + +rnFamDecl :: Maybe (Name, [Name]) + -- Just (cls, cls_tvs) => this FamilyDecl is nested + -- inside an *class decl* for cls + -- used for associated types + -> FamilyDecl GhcPs + -> RnM (FamilyDecl GhcRn, FreeVars) +rnFamDecl mb_cls (FamilyDecl { fdLName = tycon, fdTyVars = tyvars + , fdTopLevel = toplevel + , fdFixity = fixity + , fdInfo = info, fdResultSig = res_sig + , fdInjectivityAnn = injectivity }) + = do { tycon' <- lookupLocatedTopBndrRnN WL_TyCon tycon + ; ((tyvars', res_sig', injectivity'), fv1) <- + bindHsQTyVars doc mb_cls kvs tyvars $ \ tyvars' _ -> + do { let rn_sig = rnFamResultSig doc + ; (res_sig', fv_kind) <- wrapLocFstMA rn_sig res_sig + ; injectivity' <- traverse (rnInjectivityAnn tyvars' res_sig') + injectivity + ; return ( (tyvars', res_sig', injectivity') , fv_kind ) } + ; (info', fv2) <- rn_info info + ; return (FamilyDecl { fdExt = noAnn + , fdLName = tycon', fdTyVars = tyvars' + , fdTopLevel = toplevel + , fdFixity = fixity + , fdInfo = info', fdResultSig = res_sig' + , fdInjectivityAnn = injectivity' } + , fv1 `plusFV` fv2) } + where + doc = TyFamilyCtx tycon + kvs = extractRdrKindSigVars res_sig + + ---------------------- + rn_info :: FamilyInfo GhcPs -> RnM (FamilyInfo GhcRn, FreeVars) + rn_info (ClosedTypeFamily (Just eqns)) + = do { (eqns', fvs) + <- rnList (rnTyFamInstEqn (NonAssocTyFamEqn ClosedTyFam)) eqns + -- no class context + ; return (ClosedTypeFamily (Just eqns'), fvs) } + rn_info (ClosedTypeFamily Nothing) + = return (ClosedTypeFamily Nothing, emptyFVs) + rn_info OpenTypeFamily = return (OpenTypeFamily, emptyFVs) + rn_info DataFamily = return (DataFamily, emptyFVs) + +rnFamResultSig :: HsDocContext + -> FamilyResultSig GhcPs + -> RnM (FamilyResultSig GhcRn, FreeVars) +rnFamResultSig _ (NoSig _) + = return (NoSig noExtField, emptyFVs) +rnFamResultSig doc (KindSig _ kind) + = do { (rndKind, ftvs) <- rnLHsKind doc kind + ; return (KindSig noExtField rndKind, ftvs) } +rnFamResultSig doc (TyVarSig _ tvbndr) + = do { -- `TyVarSig` tells us that user named the result of a type family by + -- writing `= tyvar` or `= (tyvar :: kind)`. In such case we want to + -- be sure that the supplied result name is not identical to an + -- already in-scope type variable from an enclosing class. + -- + -- Example of disallowed declaration: + -- class C a b where + -- type F b = a | a -> b + rdr_env <- getLocalRdrEnv + + ; 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', maybe emptyFVs unitFV (hsLTyVarName tvbndr')) } + +-- Note [Renaming injectivity annotation] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- +-- During renaming of injectivity annotation we have to make several checks to +-- make sure that it is well-formed. At the moment injectivity annotation +-- consists of a single injectivity condition, so the terms "injectivity +-- annotation" and "injectivity condition" might be used interchangeably. See +-- Note [Injectivity annotation] for a detailed discussion of currently allowed +-- injectivity annotations. +-- +-- Checking LHS is simple because the only type variable allowed on the LHS of +-- injectivity condition is the variable naming the result in type family head. +-- Example of disallowed annotation: +-- +-- type family Foo a b = r | b -> a +-- +-- Verifying RHS of injectivity consists of checking that: +-- +-- 1. only variables defined in type family head appear on the RHS (kind +-- variables are also allowed). Example of disallowed annotation: +-- +-- type family Foo a = r | r -> b +-- +-- 2. for associated types the result variable does not shadow any of type +-- class variables. Example of disallowed annotation: +-- +-- class Foo a b where +-- type F a = b | b -> a +-- +-- Breaking any of these assumptions results in an error. + +-- | Rename injectivity annotation. Note that injectivity annotation is just the +-- part after the "|". Everything that appears before it is renamed in +-- rnFamDecl. +rnInjectivityAnn :: LHsQTyVars GhcRn -- ^ Type variables declared in + -- type family head + -> LFamilyResultSig GhcRn -- ^ Result signature + -> LInjectivityAnn GhcPs -- ^ Injectivity annotation + -> RnM (LInjectivityAnn GhcRn) +rnInjectivityAnn tvBndrs (L _ (TyVarSig _ resTv)) + (L srcSpan (InjectivityAnn x injFrom injTo)) + = do + { (injDecl'@(L _ (InjectivityAnn _ injFrom' injTo')), noRnErrors) + <- askNoErrs $ + 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 + ; injTo' <- mapM rnLTyVar injTo + -- Note: srcSpan is unchanged, but typechecker gets + -- confused, l2l call makes it happy + ; return $ L (l2l srcSpan) (InjectivityAnn x injFrom' injTo') } + + ; let tvNames = Set.fromList $ hsAllLTyVarNames tvBndrs + + ; 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 + + -- if renaming of type variables ended with errors (eg. there were + -- not-in-scope variables) don't check the validity of injectivity + -- annotation. This gives better error messages. + ; when (noRnErrors && not lhsValid) $ + addErrAt (getLocA injFrom) $ + TcRnIncorrectTyVarOnLhsOfInjCond resName injFrom + + ; when (noRnErrors && not (Set.null rhsValid)) $ + do { let errorVars = Set.toList rhsValid + ; addErrAt (locA srcSpan) $ + TcRnUnknownTyVarsOnRhsOfInjCond errorVars } } } + + ; return injDecl' } + +-- We can only hit this case when the user writes injectivity annotation without +-- naming the result: +-- +-- type family F a | result -> a +-- type family F a :: * | result -> a +-- +-- So we rename injectivity annotation like we normally would except that +-- this time we expect "result" to be reported not in scope by rnLTyVar. +rnInjectivityAnn _ _ (L srcSpan (InjectivityAnn x injFrom injTo)) = + setSrcSpanA srcSpan $ do + (injDecl', _) <- askNoErrs $ do + injFrom' <- rnLTyVar injFrom + injTo' <- mapM rnLTyVar injTo + return $ L srcSpan (InjectivityAnn x injFrom' injTo') + return $ injDecl' + +{- +Note [Stupid theta] +~~~~~~~~~~~~~~~~~~~ +#3850 complains about a regression wrt 6.10 for + data Show a => T a +There is no reason not to allow the stupid theta if there are no data +constructors. It's still stupid, but does no harm, and I don't want +to cause programs to break unnecessarily (notably HList). So if there +are no data constructors we allow h98_style = True +-} + + +{- ***************************************************** +* * + Support code for type/data declarations +* * +***************************************************** -} + +----------------- +rnConDecls :: DataDefnCons (LConDecl GhcPs) -> RnM (DataDefnCons (LConDecl GhcRn), FreeVars) +rnConDecls = mapFvRn (wrapLocFstMA rnConDecl) + +rnConDecl :: ConDecl GhcPs -> RnM (ConDecl GhcRn, FreeVars) +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 { _ <- 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 + -- data T a = forall (b::k). MkT (...) + -- The 'k' will already be in scope from the bindHsQTyVars + -- for the data decl itself. So we'll get + -- data T {k} a = ... + -- And indeed we may later discover (a::k). But that's the + -- scoping we get. So no implicit binders at the existential forall + + ; let ctxt = ConDeclCtx [new_name] + ; bindLHsTyVarBndrs ctxt WarnUnusedForalls + Nothing ex_tvs $ \ new_ex_tvs -> + do { (new_context, fvs1) <- rnMbContext ctxt mcxt + ; (new_args, fvs2) <- rnConDeclH98Details (unLoc new_name) ctxt args + ; let all_fvs = fvs1 `plusFV` fvs2 + ; traceRn "rnConDecl (ConDeclH98)" (ppr name <+> vcat + [ text "ex_tvs:" <+> ppr ex_tvs + , text "new_ex_dqtvs':" <+> ppr new_ex_tvs ]) + + ; mb_doc' <- traverse rnLHsDoc mb_doc + ; 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' + , con_forall = forall_ }, -- Remove when #18311 is fixed + all_fvs) }} + +rnConDecl (ConDeclGADT { 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 = mb_doc }) + = 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. + -- That order governs the order the implicitly-quantified type + -- variable, and hence the order needed for visible type application + -- See #14808. + implicit_bndrs = + extractHsOuterTvBndrs outer_bndrs $ + extractHsForAllTelescopes inner_bndrs $ + extractHsTysRdrTyVars (hsConDeclTheta mcxt) $ + extractConDeclGADTDetailsTyVars args $ + extractHsTysRdrTyVars [res_ty] [] + + ; 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 + + -- Ensure that there are no nested `forall`s or contexts, per + -- Note [GADT abstract syntax] (Wrinkle: No nested foralls or contexts) + -- in GHC.Hs.Type. + ; addNoNestedForallsContextsErr ctxt + NFC_GadtConSig new_res_ty + + ; let all_fvs = fvs1 `plusFV` fvs2 `plusFV` fvs3 + + ; traceRn "rnConDecl (ConDeclGADT)" + (ppr names $$ ppr outer_bndrs' $$ ppr inner_bndrs') + ; new_mb_doc <- traverse rnLHsDoc mb_doc + ; return (ConDeclGADT { con_g_ext = noExtField, con_names = new_names + , con_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) } } + +rnMbContext :: HsDocContext -> Maybe (LHsContext GhcPs) + -> RnM (Maybe (LHsContext GhcRn), FreeVars) +rnMbContext _ Nothing = return (Nothing, emptyFVs) +rnMbContext doc cxt = do { (ctx',fvs) <- rnMaybeContext doc cxt + ; return (ctx',fvs) } + +rnConDeclH98Details :: + Name + -> HsDocContext + -> HsConDeclH98Details GhcPs + -> RnM (HsConDeclH98Details GhcRn, FreeVars) +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) <- 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) <- rnRecHsConDeclRecFields con doc flds + ; return (RecCon new_flds, fvs) } + +rnConDeclGADTDetails :: + Name + -> HsDocContext + -> HsConDeclGADTDetails GhcPs + -> RnM (HsConDeclGADTDetails GhcRn, FreeVars) +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) } + +rnRecHsConDeclRecFields :: + Name + -> HsDocContext + -> 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) } + +------------------------------------------------- + +-- | Brings pattern synonym names and also pattern synonym selectors +-- from record pattern synonyms into scope. +extendPatSynEnv :: DuplicateRecordFields -> FieldSelectors -> HsValBinds GhcPs -> MiniFixityEnv + -> ([Name] -> TcRnIf TcGblEnv TcLclEnv a) -> TcM a +extendPatSynEnv dup_fields_ok has_sel val_decls local_fix_env thing = do { + names_with_fls <- new_ps val_decls + ; let pat_syn_bndrs = concat [ conLikeName_Name name : map flSelector flds + | (name, con_info) <- names_with_fls + , let flds = conInfoFields con_info ] + ; let gres = map (mkLocalConLikeGRE NoParent) names_with_fls + ++ mkLocalFieldGREs NoParent names_with_fls + -- Recall Note [Parents] in GHC.Types.Name.Reader: + -- + -- pattern synonym constructors and their record fields have no parent + -- in the module in which they are defined. + ; (gbl_env, lcl_env) <- extendGlobalRdrEnvRn gres local_fix_env + ; restoreEnvs (gbl_env, lcl_env) (thing pat_syn_bndrs) } + where + + new_ps :: HsValBinds GhcPs -> TcM [(ConLikeName, ConInfo)] + new_ps (ValBinds _ binds _) = foldrM new_ps' [] binds + new_ps _ = panic "new_ps" + + new_ps' :: LHsBindLR GhcPs GhcPs + -> [(ConLikeName, ConInfo)] + -> TcM [(ConLikeName, ConInfo)] + new_ps' bind names + | (L bind_loc (PatSynBind _ (PSB { psb_id = L _ n + , psb_args = RecCon as }))) <- bind + = do + bnd_name <- newTopSrcBinder (L (l2l bind_loc) n) + let field_occs = map ((\ f -> L (noAnnSrcSpan $ getLocA (foLabel f)) f) . recordPatSynField) as + flds <- mapM (newRecordFieldLabel dup_fields_ok has_sel [bnd_name]) field_occs + let con_info = mkConInfo ConIsPatSyn (conDetailsVisArity (RecCon as)) flds + return ((PatSynName bnd_name, con_info) : names) + | L bind_loc (PatSynBind _ (PSB { psb_id = L _ n, psb_args = as })) <- bind + = do + bnd_name <- newTopSrcBinder (L (l2l bind_loc) n) + let con_info = mkConInfo ConIsPatSyn (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 + +{- +********************************************************* +* * +\subsection{Support code to rename types} +* * +********************************************************* +-} + +rnFds :: [LHsFunDep GhcPs] -> RnM [LHsFunDep GhcRn] +rnFds fds + = mapM (wrapLocMA rn_fds) fds + where + rn_fds :: FunDep GhcPs -> RnM (FunDep GhcRn) + rn_fds (FunDep x tys1 tys2) + = do { tys1' <- rnHsTyVars tys1 + ; tys2' <- rnHsTyVars tys2 + ; return (FunDep x tys1' tys2') } + +rnHsTyVars :: [LocatedN RdrName] -> RnM [LocatedN Name] +rnHsTyVars tvs = mapM rnHsTyVar tvs + +rnHsTyVar :: LocatedN RdrName -> RnM (LocatedN Name) +rnHsTyVar (L l tyvar) = do + tyvar' <- lookupOccRn WL_TyVar tyvar + return (L l tyvar') + +{- +********************************************************* +* * + findSplice +* * +********************************************************* + +This code marches down the declarations, looking for the first +Template Haskell splice. As it does so it + a) groups the declarations into a HsGroup + b) runs any top-level quasi-quotes +-} + +findSplice :: [LHsDecl GhcPs] + -> RnM (HsGroup GhcPs, Maybe (SpliceDecl GhcPs, [LHsDecl GhcPs])) +findSplice ds = addl emptyRdrGroup ds + +addl :: HsGroup GhcPs -> [LHsDecl GhcPs] + -> RnM (HsGroup GhcPs, Maybe (SpliceDecl GhcPs, [LHsDecl GhcPs])) +-- This stuff reverses the declarations (again) but it doesn't matter +addl gp [] = return (gp, Nothing) +addl gp (L l d : ds) = add gp l d ds + + +add :: HsGroup GhcPs -> SrcSpanAnnA -> HsDecl GhcPs -> [LHsDecl GhcPs] + -> RnM (HsGroup GhcPs, Maybe (SpliceDecl GhcPs, [LHsDecl GhcPs])) + +-- #10047: Declaration QuasiQuoters are expanded immediately, without +-- causing a group split +add gp _ (SpliceD _ (SpliceDecl _ (L _ qq@HsQuasiQuote{}) _)) ds + = do { (ds', _) <- rnTopSpliceDecls qq + ; addl gp (ds' ++ ds) + } + +add gp loc (SpliceD _ splice@(SpliceDecl _ _ flag)) ds + = do { -- We've found a top-level splice. If it is an *implicit* one + -- (i.e. a naked top level expression), throw an error if + -- TemplateHaskell is not enabled. + case flag of + DollarSplice -> return () + BareSplice -> do { unlessXOptM LangExt.TemplateHaskell + $ setSrcSpan (locA loc) + $ failWith badImplicitSplice } + + ; return (gp, Just (splice, ds)) } + where + badImplicitSplice :: TcRnMessage + badImplicitSplice = TcRnTHError (THSyntaxError BadImplicitSplice) + +-- Class declarations: added to the TyClGroup +add gp@(HsGroup {hs_tyclds = ts}) l (TyClD _ d) ds + = addl (gp { hs_tyclds = add_tycld (L l d) ts }) ds + +-- Signatures: fixity sigs go a different place than all others +add gp@(HsGroup {hs_fixds = ts}) l (SigD _ (FixSig _ f)) ds + = addl (gp {hs_fixds = L l f : ts}) ds + +-- Standalone kind signatures: added to the TyClGroup +add gp@(HsGroup {hs_tyclds = ts}) l (KindSigD _ s) ds + = addl (gp {hs_tyclds = add_kisig (L l s) ts}) ds + +add gp@(HsGroup {hs_valds = ts}) l (SigD _ d) ds + = addl (gp {hs_valds = add_sig (L l d) ts}) ds + +-- Value declarations: use add_bind +add gp@(HsGroup {hs_valds = ts}) l (ValD _ d) ds + = addl (gp { hs_valds = add_bind (L l d) ts }) ds + +-- Role annotations: added to the TyClGroup +add gp@(HsGroup {hs_tyclds = ts}) l (RoleAnnotD _ d) ds + = addl (gp { hs_tyclds = add_role_annot (L l d) ts }) ds + +-- NB instance declarations go into TyClGroups. We throw them into the first +-- group, just as we do for the TyClD case. The renamer will go on to group +-- and order them later. +add gp@(HsGroup {hs_tyclds = ts}) l (InstD _ d) ds + = addl (gp { hs_tyclds = add_instd (L l d) ts }) ds + +-- The rest are routine +add gp@(HsGroup {hs_derivds = ts}) l (DerivD _ d) ds + = addl (gp { hs_derivds = L l d : ts }) ds +add gp@(HsGroup {hs_defds = ts}) l (DefD _ d) ds + = addl (gp { hs_defds = L l d : ts }) ds +add gp@(HsGroup {hs_fords = ts}) l (ForD _ d) ds + = addl (gp { hs_fords = L l d : ts }) ds +add gp@(HsGroup {hs_warnds = ts}) l (WarningD _ d) ds + = addl (gp { hs_warnds = L l d : ts }) ds +add gp@(HsGroup {hs_annds = ts}) l (AnnD _ d) ds + = addl (gp { hs_annds = L l d : ts }) ds +add gp@(HsGroup {hs_ruleds = ts}) l (RuleD _ d) ds + = addl (gp { hs_ruleds = L l d : ts }) ds +add gp l (DocD _ d) ds + = addl (gp { hs_docs = (L l d) : (hs_docs gp) }) ds + +add_tycld :: LTyClDecl GhcPs -> [TyClGroup GhcPs] + -> [TyClGroup GhcPs] +add_tycld d [] = [TyClGroup { group_ext = noExtField + , group_tyclds = [d] + , group_kisigs = [] + , group_roles = [] + , group_instds = [] + } + ] +add_tycld d (ds@(TyClGroup { group_tyclds = tyclds }):dss) + = ds { group_tyclds = d : tyclds } : dss + +add_instd :: LInstDecl GhcPs -> [TyClGroup GhcPs] + -> [TyClGroup GhcPs] +add_instd d [] = [TyClGroup { group_ext = noExtField + , group_tyclds = [] + , group_kisigs = [] + , group_roles = [] + , group_instds = [d] + } + ] +add_instd d (ds@(TyClGroup { group_instds = instds }):dss) + = ds { group_instds = d : instds } : dss + +add_role_annot :: LRoleAnnotDecl GhcPs -> [TyClGroup GhcPs] + -> [TyClGroup GhcPs] +add_role_annot d [] = [TyClGroup { group_ext = noExtField + , group_tyclds = [] + , group_kisigs = [] + , group_roles = [d] + , group_instds = [] + } + ] +add_role_annot d (tycls@(TyClGroup { group_roles = roles }) : rest) + = tycls { group_roles = d : roles } : rest + +add_kisig :: LStandaloneKindSig GhcPs + -> [TyClGroup GhcPs] -> [TyClGroup GhcPs] +add_kisig d [] = [TyClGroup { group_ext = noExtField + , group_tyclds = [] + , group_kisigs = [d] + , group_roles = [] + , group_instds = [] + } + ] +add_kisig d (tycls@(TyClGroup { group_kisigs = kisigs }) : rest) + = tycls { group_kisigs = d : kisigs } : rest + +add_bind :: LHsBind a -> HsValBinds a -> HsValBinds a +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 @@ -8,2201 +8,2494 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE LambdaCase #-} - -module GHC.Rename.Names ( - rnImports, getLocalNonValBinders, newRecordSelector, - extendGlobalRdrEnvRn, - gresFromAvails, - calculateAvails, - reportUnusedNames, - checkConName, - mkChildEnv, - findChildren, - findImportUsage, - getMinimalImports, - printMinimalImports, - renamePkgQual, renameRawPkgQual, - ImportDeclUsage - ) where - -import GHC.Prelude hiding ( head, init, last, tail ) - -import GHC.Driver.Env -import GHC.Driver.Session -import GHC.Driver.Ppr - -import GHC.Rename.Env -import GHC.Rename.Fixity -import GHC.Rename.Utils ( warnUnusedTopBinds, mkFieldEnv ) - -import GHC.Tc.Errors.Types -import GHC.Tc.Utils.Env -import GHC.Tc.Utils.Monad - -import GHC.Hs -import GHC.Iface.Load ( loadSrcInterface ) -import GHC.Builtin.Names -import GHC.Parser.PostProcess ( setRdrNameSpace ) -import GHC.Core.Type -import GHC.Core.PatSyn -import GHC.Core.TyCon ( TyCon, tyConName ) -import qualified GHC.LanguageExtensions as LangExt - -import GHC.Utils.Outputable as Outputable -import GHC.Utils.Misc as Utils -import GHC.Utils.Panic - -import GHC.Types.Fixity.Env -import GHC.Types.SafeHaskell -import GHC.Types.Name -import GHC.Types.Name.Env -import GHC.Types.Name.Set -import GHC.Types.Name.Reader -import GHC.Types.Avail -import GHC.Types.FieldLabel -import GHC.Types.SourceFile -import GHC.Types.SrcLoc as SrcLoc -import GHC.Types.Basic ( TopLevelFlag(..) ) -import GHC.Types.SourceText -import GHC.Types.Id -import GHC.Types.HpcInfo -import GHC.Types.Error -import GHC.Types.PkgQual - -import GHC.Unit -import GHC.Unit.Module.Warnings -import GHC.Unit.Module.ModIface -import GHC.Unit.Module.Imported -import GHC.Unit.Module.Deps -import GHC.Unit.Env - -import GHC.Data.Maybe -import GHC.Data.FastString -import GHC.Data.FastString.Env - -import Language.Haskell.Syntax.Basic (FieldLabelString(..)) - -import Control.Monad -import Data.Either ( partitionEithers ) -import Data.Map ( Map ) -import qualified Data.Map as Map -import Data.Ord ( comparing ) -import Data.List ( partition, (\\), find, sortBy ) -import Data.List.NonEmpty (NonEmpty(..)) -import qualified Data.List.NonEmpty as NE -import Data.Function ( on ) -import qualified Data.Set as S -import Data.Foldable ( toList ) -import System.FilePath (()) - -import System.IO -import GHC.Data.Bag - -{- -************************************************************************ -* * -\subsection{rnImports} -* * -************************************************************************ - -Note [Tracking Trust Transitively] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When we import a package as well as checking that the direct imports are safe -according to the rules outlined in the Note [Safe Haskell Trust Check] in GHC.Driver.Main -we must also check that these rules hold transitively for all dependent modules -and packages. Doing this without caching any trust information would be very -slow as we would need to touch all packages and interface files a module depends -on. To avoid this we make use of the property that if a modules Safe Haskell -mode changes, this triggers a recompilation from that module in the dependency -graph. So we can just worry mostly about direct imports. - -There is one trust property that can change for a package though without -recompilation being triggered: package trust. So we must check that all -packages a module transitively depends on to be trusted are still trusted when -we are compiling this module (as due to recompilation avoidance some modules -below may not be considered trusted any more without recompilation being -triggered). - -We handle this by augmenting the existing transitive list of packages a module M -depends on with a bool for each package that says if it must be trusted when the -module M is being checked for trust. This list of trust required packages for a -single import is gathered in the rnImportDecl function and stored in an -ImportAvails data structure. The union of these trust required packages for all -imports is done by the rnImports function using the combine function which calls -the plusImportAvails function that is a union operation for the ImportAvails -type. This gives us in an ImportAvails structure all packages required to be -trusted for the module we are currently compiling. Checking that these packages -are still trusted (and that direct imports are trusted) is done in -GHC.Driver.Main.checkSafeImports. - -See the note below, [Trust Own Package] for a corner case in this method and -how its handled. - - -Note [Trust Own Package] -~~~~~~~~~~~~~~~~~~~~~~~~ -There is a corner case of package trust checking that the usual transitive check -doesn't cover. (For how the usual check operates see the Note [Tracking Trust -Transitively] below). The case is when you import a -XSafe module M and M -imports a -XTrustworthy module N. If N resides in a different package than M, -then the usual check works as M will record a package dependency on N's package -and mark it as required to be trusted. If N resides in the same package as M -though, then importing M should require its own package be trusted due to N -(since M is -XSafe so doesn't create this requirement by itself). The usual -check fails as a module doesn't record a package dependency of its own package. -So instead we now have a bool field in a modules interface file that simply -states if the module requires its own package to be trusted. This field avoids -us having to load all interface files that the module depends on to see if one -is trustworthy. - - -Note [Trust Transitive Property] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -So there is an interesting design question in regards to transitive trust -checking. Say I have a module B compiled with -XSafe. B is dependent on a bunch -of modules and packages, some packages it requires to be trusted as its using --XTrustworthy modules from them. Now if I have a module A that doesn't use safe -haskell at all and simply imports B, should A inherit all the trust -requirements from B? Should A now also require that a package p is trusted since -B required it? - -We currently say no but saying yes also makes sense. The difference is, if a -module M that doesn't use Safe Haskell imports a module N that does, should all -the trusted package requirements be dropped since M didn't declare that it cares -about Safe Haskell (so -XSafe is more strongly associated with the module doing -the importing) or should it be done still since the author of the module N that -uses Safe Haskell said they cared (so -XSafe is more strongly associated with -the module that was compiled that used it). - -Going with yes is a simpler semantics we think and harder for the user to stuff -up but it does mean that Safe Haskell will affect users who don't care about -Safe Haskell as they might grab a package from Cabal which uses safe haskell (say -network) and that packages imports -XTrustworthy modules from another package -(say bytestring), so requires that package is trusted. The user may now get -compilation errors in code that doesn't do anything with Safe Haskell simply -because they are using the network package. They will have to call 'ghc-pkg -trust network' to get everything working. Due to this invasive nature of going -with yes we have gone with no for now. --} - --- | Process Import Decls. See 'rnImportDecl' for a description of what --- the return types represent. --- 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) -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 - 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) - -- 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) - - where - clobberSourceImports imp_avails = - imp_avails { imp_boot_mods = imp_boot_mods' } - where - imp_boot_mods' = mergeInstalledModuleEnv combJ id (const emptyInstalledModuleEnv) - (imp_boot_mods imp_avails) - (imp_direct_dep_mods imp_avails) - - combJ (GWIB _ IsBoot) x = Just x - combJ r _ = Just r - -- See Note [Combining ImportAvails] - combine :: [(LImportDecl GhcRn, GlobalRdrEnv, ImportAvails, AnyHpcUsage)] - -> ([LImportDecl GhcRn], GlobalRdrEnv, ImportAvails, AnyHpcUsage) - combine ss = - let (decls, rdr_env, imp_avails, hpc_usage, finsts) = foldr - plus - ([], emptyGlobalRdrEnv, emptyImportAvails, False, emptyModuleSet) - ss - in (decls, rdr_env, imp_avails { imp_finsts = moduleSetElts finsts }, - hpc_usage) - - plus (decl, gbl_env1, imp_avails1, hpc_usage1) - (decls, gbl_env2, imp_avails2, hpc_usage2, finsts_set) - = ( decl:decls, - 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 = [] } - new_finsts = imp_finsts imp_avails1 - -{- -Note [Combining ImportAvails] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -imp_finsts in ImportAvails is a list of family instance modules -transitively depended on by an import. imp_finsts for a currently -compiled module is a union of all the imp_finsts of imports. -Computing the union of two lists of size N is O(N^2) and if we -do it to M imports we end up with O(M*N^2). That can get very -expensive for bigger module hierarchies. - -Union can be optimized to O(N log N) if we use a Set. -imp_finsts is converted back and forth between dep_finsts, so -changing a type of imp_finsts means either paying for the conversions -or changing the type of dep_finsts as well. - -I've measured that the conversions would cost 20% of allocations on my -test case, so that can be ruled out. - -Changing the type of dep_finsts forces checkFamInsts to -get the module lists in non-deterministic order. If we wanted to restore -the deterministic order, we'd have to sort there, which is an additional -cost. As far as I can tell, using a non-deterministic order is fine there, -but that's a brittle nonlocal property which I'd like to avoid. - -Additionally, dep_finsts is read from an interface file, so its "natural" -type is a list. Which makes it a natural type for imp_finsts. - -Since rnImports.combine is really the only place that would benefit from -it being a Set, it makes sense to optimize the hot loop in rnImports.combine -without changing the representation. - -So here's what we do: instead of naively merging ImportAvails with -plusImportAvails in a loop, we make plusImportAvails merge empty imp_finsts -and compute the union on the side using Sets. When we're done, we can -convert it back to a list. One nice side effect of this approach is that -if there's a lot of overlap in the imp_finsts of imports, the -Set doesn't really need to grow and we don't need to allocate. - -Running generateModules from #14693 with DEPTH=16, WIDTH=30 finishes in -23s before, and 11s after. --} - - - --- | Given a located import declaration @decl@ from @this_mod@, --- calculate the following pieces of information: --- --- 1. An updated 'LImportDecl', where all unresolved 'RdrName' in --- the entity lists have been resolved into 'Name's, --- --- 2. A 'GlobalRdrEnv' representing the new identifiers that were --- brought into scope (taking into account module qualification --- and hiding), --- --- 3. 'ImportAvails' summarizing the identifiers that were imported --- by this declaration, and --- --- 4. A boolean 'AnyHpcUsage' which is true if the imported module --- used HPC. -rnImportDecl :: Module -> (LImportDecl GhcPs, SDoc) - -> RnM (LImportDecl GhcRn, GlobalRdrEnv, ImportAvails, AnyHpcUsage) -rnImportDecl this_mod - (L loc decl@(ImportDecl { ideclName = loc_imp_mod_name - , ideclPkgQual = raw_pkg_qual - , ideclSource = want_boot, ideclSafe = mod_safe - , ideclQualified = qual_style - , ideclExt = XImportDeclPass { ideclImplicit = implicit } - , ideclAs = as_mod, ideclImportList = imp_details }), import_reason) - = setSrcSpanA loc $ do - - case raw_pkg_qual of - NoRawPkgQual -> pure () - RawPkgQual _ -> do - pkg_imports <- xoptM LangExt.PackageImports - when (not pkg_imports) $ addErr packageImportErr - - let qual_only = isImportDeclQualified qual_style - - -- If there's an error in loadInterface, (e.g. interface - -- file not found) we get lots of spurious errors from 'filterImports' - let imp_mod_name = unLoc loc_imp_mod_name - doc = ppr imp_mod_name <+> import_reason - - hsc_env <- getTopEnv - unit_env <- hsc_unit_env <$> getTopEnv - let pkg_qual = renameRawPkgQual unit_env imp_mod_name raw_pkg_qual - - -- Check for self-import, which confuses the typechecker (#9032) - -- ghc --make rejects self-import cycles already, but batch-mode may not - -- at least not until GHC.IfaceToCore.tcHiBootIface, which is too late to avoid - -- typechecker crashes. (Indirect self imports are not caught until - -- GHC.IfaceToCore, see #10337 tracking how to make this error better.) - -- - -- Originally, we also allowed 'import {-# SOURCE #-} M', but this - -- caused bug #10182: in one-shot mode, we should never load an hs-boot - -- file for the module we are compiling into the EPS. In principle, - -- it should be possible to support this mode of use, but we would have to - -- extend Provenance to support a local definition in a qualified location. - -- For now, we don't support it, but see #10336 - when (imp_mod_name == moduleName this_mod && - (case pkg_qual of -- If we have import "" M, then we should - -- check that "" is "this" (which is magic) - -- or the name of this_mod's package. Yurgh! - -- c.f. GHC.findModule, and #9997 - NoPkgQual -> True - ThisPkg uid -> uid == homeUnitId_ (hsc_dflags hsc_env) - OtherPkg _ -> False)) - (addErr $ mkTcRnUnknownMessage $ mkPlainError noHints $ - (text "A module cannot import itself:" <+> ppr imp_mod_name)) - - -- Check for a missing import list (Opt_WarnMissingImportList also - -- checks for T(..) items but that is done in checkDodgyImport below) - case imp_details of - Just (Exactly, _) -> return () -- Explicit import list - _ | implicit -> return () -- Do not bleat for implicit imports - | qual_only -> return () - | otherwise -> whenWOptM Opt_WarnMissingImportList $ do - let msg = mkTcRnUnknownMessage $ - mkPlainDiagnostic (WarningWithFlag Opt_WarnMissingImportList) - noHints - (missingImportListWarn imp_mod_name) - addDiagnostic msg - - - iface <- loadSrcInterface doc imp_mod_name want_boot pkg_qual - - -- Compiler sanity check: if the import didn't say - -- {-# SOURCE #-} we should not get a hi-boot file - warnPprTrace ((want_boot == NotBoot) && (mi_boot iface == IsBoot)) "rnImportDecl" (ppr imp_mod_name) $ do - - -- Issue a user warning for a redundant {- SOURCE -} import - -- NB that we arrange to read all the ordinary imports before - -- any of the {- SOURCE -} imports. - -- - -- in --make and GHCi, the compilation manager checks for this, - -- and indeed we shouldn't do it here because the existence of - -- the non-boot module depends on the compilation order, which - -- is not deterministic. The hs-boot test can show this up. - dflags <- getDynFlags - warnIf ((want_boot == IsBoot) && (mi_boot iface == NotBoot) && isOneShot (ghcMode dflags)) - (warnRedundantSourceImport imp_mod_name) - when (mod_safe && not (safeImportsOn dflags)) $ - addErr $ mkTcRnUnknownMessage $ mkPlainError noHints $ - (text "safe import can't be used as Safe Haskell isn't on!" - $+$ text ("please enable Safe Haskell through either Safe, Trustworthy or Unsafe")) - - let - qual_mod_name = fmap unLoc as_mod `orElse` imp_mod_name - imp_spec = ImpDeclSpec { is_mod = imp_mod_name, is_qual = qual_only, - is_dloc = locA loc, is_as = qual_mod_name } - - -- filter the imports according to the import declaration - (new_imp_details, gres) <- filterImports 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 iface imp_spec Nothing - - let gbl_env = mkGlobalRdrEnv gres - - is_hiding | Just (EverythingBut,_) <- imp_details = True - | otherwise = False - - -- should the import be safe? - mod_safe' = mod_safe - || (not implicit && safeDirectImpsReq dflags) - || (implicit && safeImplicitImpsReq dflags) - - hsc_env <- getTopEnv - 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_span = locA loc - , imv_is_safe = mod_safe' - , imv_is_hiding = is_hiding - , imv_all_exports = potential_gres - , imv_qualified = qual_only - } - imports = calculateAvails home_unit other_home_units iface mod_safe' want_boot (ImportedByUser imv) - - -- Complain if we import a deprecated module - case mi_warns iface of - WarnAll txt -> do - let msg = mkTcRnUnknownMessage $ - mkPlainDiagnostic (WarningWithFlag Opt_WarnWarningsDeprecations) - noHints - (moduleWarn imp_mod_name txt) - addDiagnostic msg - _ -> return () - - -- Complain about -Wcompat-unqualified-imports violations. - warnUnqualifiedImport decl iface - - let new_imp_decl = ImportDecl - { ideclExt = ideclExt decl - , ideclName = ideclName decl - , ideclPkgQual = pkg_qual - , ideclSource = ideclSource decl - , ideclSafe = mod_safe' - , ideclQualified = ideclQualified decl - , ideclAs = ideclAs decl - , ideclImportList = new_imp_details - } - - return (L loc new_imp_decl, gbl_env, imports, mi_hpc iface) - - --- | Rename raw package imports -renameRawPkgQual :: UnitEnv -> ModuleName -> RawPkgQual -> PkgQual -renameRawPkgQual unit_env mn = \case - NoRawPkgQual -> NoPkgQual - RawPkgQual p -> renamePkgQual unit_env mn (Just (sl_fs p)) - --- | Rename raw package imports -renamePkgQual :: UnitEnv -> ModuleName -> Maybe FastString -> PkgQual -renamePkgQual unit_env mn mb_pkg = case mb_pkg of - Nothing -> NoPkgQual - Just pkg_fs - | Just uid <- homeUnitId <$> ue_homeUnit unit_env - , pkg_fs == fsLit "this" - -> ThisPkg uid - - | Just (uid, _) <- find (fromMaybe False . fmap (== pkg_fs) . snd) home_names - -> ThisPkg uid - - | Just uid <- resolvePackageImport (ue_units unit_env) mn (PackageName pkg_fs) - -> OtherPkg uid - - | otherwise - -> OtherPkg (UnitId pkg_fs) - -- not really correct as pkg_fs is unlikely to be a valid unit-id but - -- we will report the failure later... - where - home_names = map (\uid -> (uid, mkFastString <$> thisPackageName (homeUnitEnv_dflags (ue_findHomeUnitEnv uid unit_env)))) hpt_deps - - units = ue_units unit_env - - hpt_deps :: [UnitId] - hpt_deps = homeUnitDepends units - - --- | Calculate the 'ImportAvails' induced by an import of a particular --- interface, but without 'imp_mods'. -calculateAvails :: HomeUnit - -> S.Set UnitId - -> ModIface - -> IsSafeImport - -> IsBootInterface - -> ImportedBy - -> ImportAvails -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) - deps = mi_deps iface - trust = getSafeMode $ mi_trust iface - trust_pkg = mi_trust_pkg iface - is_sig = mi_hsc_src iface == HsigFile - - -- If the module exports anything defined in this module, just - -- ignore it. Reason: otherwise it looks as if there are two - -- local definition sites for the thing, and an error gets - -- reported. Easiest thing is just to filter them out up - -- front. This situation only arises if a module imports - -- itself, or another module that imported it. (Necessarily, - -- this involves a loop.) - -- - -- We do this *after* filterImports, so that if you say - -- module A where - -- import B( AType ) - -- type AType = ... - -- - -- module B( AType ) where - -- import {-# SOURCE #-} A( AType ) - -- - -- then you won't get a 'B does not export AType' message. - - - -- Compute new transitive dependencies - -- - -- 'dep_orphs' and 'dep_finsts' do NOT include the imported module - -- itself, but we DO need to include this module in 'imp_orphs' and - -- 'imp_finsts' if it defines an orphan or instance family; thus the - -- orph_iface/has_iface tests. - - deporphs = dep_orphs deps - depfinsts = dep_finsts deps - - orphans | orph_iface = assertPpr (not (imp_sem_mod `elem` deporphs)) (ppr imp_sem_mod <+> ppr deporphs) $ - imp_sem_mod : deporphs - | otherwise = deporphs - - finsts | has_finsts = assertPpr (not (imp_sem_mod `elem` depfinsts)) (ppr imp_sem_mod <+> ppr depfinsts) $ - imp_sem_mod : depfinsts - | otherwise = depfinsts - - -- Trusted packages are a lot like orphans. - trusted_pkgs | mod_safe' = dep_trusted_pkgs deps - | otherwise = S.empty - - - pkg = moduleUnit (mi_module iface) - ipkg = toUnitId pkg - - -- Does this import mean we now require our own pkg - -- to be trusted? See Note [Trust Own Package] - ptrust = trust == Sf_Trustworthy || trust_pkg - pkg_trust_req - | isHomeUnit home_unit pkg = ptrust - | otherwise = False - - dependent_pkgs = if toUnitId pkg `S.member` other_home_units - then S.empty - else S.singleton 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 - - 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) - -- Now we are importing A properly, so don't go looking for - -- A.hs-boot - | isHomeUnit home_unit pkg = dep_boot_mods_map - -- There's no boot files to find in external imports - | otherwise = emptyInstalledModuleEnv - - sig_mods = - if is_sig - then moduleName imp_mod : dep_sig_mods deps - else dep_sig_mods deps - - - in ImportAvails { - imp_mods = unitModuleEnv (mi_module iface) [imported_by], - imp_orphs = orphans, - imp_finsts = finsts, - imp_sig_mods = sig_mods, - imp_direct_dep_mods = direct_mods, - imp_dep_direct_pkgs = dependent_pkgs, - imp_boot_mods = boot_mods, - - -- Add in the imported modules trusted package - -- requirements. ONLY do this though if we import the - -- module as a safe import. - -- See Note [Tracking Trust Transitively] - -- and Note [Trust Transitive Property] - imp_trust_pkgs = trusted_pkgs, - -- Do we require our own pkg to be trusted? - -- See Note [Trust Own Package] - 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 - let msg = mkTcRnUnknownMessage $ - mkPlainDiagnostic (WarningWithFlag Opt_WarnCompatUnqualifiedImports) - noHints - warning - addDiagnosticAt loc msg - 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 - - warning = 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." - ] - - -- Modules for which we warn if we see unqualified imports - qualifiedMods = mkModuleSet [ dATA_LIST ] - - -warnRedundantSourceImport :: ModuleName -> TcRnMessage -warnRedundantSourceImport mod_name - = mkTcRnUnknownMessage $ mkPlainDiagnostic WarningWithoutFlag noHints $ - text "Unnecessary {-# SOURCE #-} in the import of module" <+> quotes (ppr mod_name) - -{- -************************************************************************ -* * -\subsection{importsFromLocalDecls} -* * -************************************************************************ - -From the top-level declarations of this module produce - * the lexical environment - * the ImportAvails -created by its bindings. - -Note [Top-level Names in Template Haskell decl quotes] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -See also: Note [Interactively-bound Ids in GHCi] in GHC.Driver.Env - Note [Looking up Exact RdrNames] in GHC.Rename.Env - -Consider a Template Haskell declaration quotation like this: - module M where - f x = h [d| f = 3 |] -When renaming the declarations inside [d| ...|], we treat the -top level binders specially in two ways - -1. We give them an Internal Name, not (as usual) an External one. - This is done by GHC.Rename.Env.newTopSrcBinder. - -2. We make them *shadow* the outer bindings. - 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 - meant for the type checker, and here we are not interested in the - fields of Brack, hence the error thunks in thRnBrack. --} - -extendGlobalRdrEnvRn :: [AvailInfo] - -> MiniFixityEnv - -> RnM (TcGblEnv, TcLclEnv) --- Updates both the GlobalRdrEnv and the FixityEnv --- We return a new TcLclEnv only because we might have to --- delete some bindings from it; --- see Note [Top-level Names in Template Haskell decl quotes] - -extendGlobalRdrEnvRn avails new_fixities - = checkNoErrs $ -- See Note [Fail fast on duplicate definitions] - do { (gbl_env, lcl_env) <- getEnvs - ; stage <- getStage - ; isGHCi <- getIsGHCi - ; let rdr_env = tcg_rdr_env gbl_env - fix_env = tcg_fix_env gbl_env - th_bndrs = tcl_th_bndrs lcl_env - th_lvl = thLevel stage - - -- 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 - - lcl_env_TH = lcl_env { tcl_rdr = minusLocalRdrEnv (tcl_rdr lcl_env) new_occs } - -- See Note [GlobalRdrEnv shadowing] - - lcl_env2 | inBracket = lcl_env_TH - | otherwise = lcl_env - - -- Deal with shadowing: see Note [GlobalRdrEnv shadowing] - want_shadowing = isGHCi || inBracket - rdr_env1 | want_shadowing = shadowNames rdr_env new_occs - | otherwise = rdr_env - - lcl_env3 = lcl_env2 { tcl_th_bndrs = extendNameEnvList th_bndrs - [ ( greNameMangledName n - , (TopLevel, th_lvl) ) - | n <- new_names ] } - - ; rdr_env2 <- foldlM add_gre rdr_env1 new_gres - - ; let fix_env' = foldl' extend_fix_env fix_env new_gres - gbl_env' = gbl_env { tcg_rdr_env = rdr_env2, tcg_fix_env = fix_env' } - - ; traceRn "extendGlobalRdrEnvRn 2" (pprGlobalRdrEnv True rdr_env2) - ; return (gbl_env', lcl_env3) } - where - new_names = concatMap availGreNames avails - new_occs = occSetToEnv (mkOccSet (map occName new_names)) - - -- 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) - = extendNameEnv fix_env name (FixItem occ fi) - | otherwise - = fix_env - where - name = greMangledName gre - occ = greOccName gre - - new_gres :: [GlobalRdrElt] -- New LocalDef GREs, derived from avails - new_gres = concatMap localGREsFromAvail avails - - add_gre :: GlobalRdrEnv -> GlobalRdrElt -> RnM GlobalRdrEnv - -- Extend the GlobalRdrEnv with a LocalDef GRE - -- If there is already a LocalDef GRE with the same OccName, - -- report an error and discard the new GRE - -- This establishes INVARIANT 1 of GlobalRdrEnvs - add_gre env gre - | not (null dups) -- Same OccName defined twice - = do { addDupDeclErr (gre :| dups); return env } - - | otherwise - = return (extendGlobalRdrEnv env gre) - where - -- See Note [Reporting duplicate local declarations] - dups = filter isDupGRE (lookupGlobalRdrEnv env (greOccName gre)) - isDupGRE gre' = isLocalGRE gre' && not (isAllowedDup gre') - isAllowedDup gre' = - case (isRecFldGRE gre, isRecFldGRE gre') of - (True, True) -> gre_name gre /= gre_name gre' - && isDuplicateRecFldGRE gre' - (True, False) -> isNoFieldSelectorGRE gre - (False, True) -> isNoFieldSelectorGRE gre' - (False, False) -> False - -{- Note [Fail fast on duplicate definitions] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -If there are duplicate bindings for the same thing, we want to fail -fast. Having two bindings for the same thing can cause follow-on errors. -Example (test T9975a): - data Test = Test { x :: Int } - pattern Test wat = Test { x = wat } -This defines 'Test' twice. The second defn has no field-names; and then -we get an error from Test { x=wat }, saying "Test has no field 'x'". - -Easiest thing is to bale out fast on duplicate definitions, which -we do via `checkNoErrs` on `extendGlobalRdrEnvRn`. - -Note [Reporting duplicate local declarations] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In general, a single module may not define the same OccName multiple times. This -is checked in extendGlobalRdrEnvRn: when adding a new locally-defined GRE to the -GlobalRdrEnv we report an error if there are already duplicates in the -environment. This establishes INVARIANT 1 (see comments on GlobalRdrEnv in -GHC.Types.Name.Reader), which says that for a given OccName, all the -GlobalRdrElts to which it maps must have distinct 'gre_name's. - -For example, the following will be rejected: - - f x = x - g x = x - f x = x -- Duplicate! - -Two GREs with the same OccName are OK iff: -------------------------------------------------------------------- - Existing GRE | Newly-defined GRE - | NormalGre FieldGre -------------------------------------------------------------------- - Imported | Always Always - | - Local NormalGre | Never NoFieldSelectors - | - Local FieldGre | NoFieldSelectors DuplicateRecordFields - | and not in same record -------------------------------------------------------------------- - -In this table "NoFieldSelectors" means "NoFieldSelectors was enabled at the -definition site of the fields; ditto "DuplicateRecordFields". These facts are -recorded in the 'FieldLabel' (but where both GREs are local, both will -necessarily have the same extensions enabled). - -More precisely: - -* The programmer is allowed to make a new local definition that clashes with an - imported one (although attempting to refer to either may lead to ambiguity - errors at use sites). For example, the following definition is allowed: - - import M (f) - f x = x - - Thus isDupGRE reports errors only if the existing GRE is a LocalDef. - -* When DuplicateRecordFields is enabled, the same field label may be defined in - multiple records. For example, this is allowed: - - {-# LANGUAGE DuplicateRecordFields #-} - data S1 = MkS1 { f :: Int } - data S2 = MkS2 { f :: Int } - - Even though both fields have the same OccName, this does not violate INVARIANT - 1 of the GlobalRdrEnv, because the fields have distinct selector names, which - form part of the gre_name (see Note [GreNames] in GHC.Types.Name.Reader). - -* However, we must be careful to reject the following (#9156): - - {-# LANGUAGE DuplicateRecordFields #-} - data T = MkT { f :: Int, f :: Int } -- Duplicate! - - In this case, both 'gre_name's are the same (because the fields belong to the - same type), and adding them both to the environment would be a violation of - INVARIANT 1. Thus isAllowedDup checks both GREs have distinct 'gre_name's - if they are both record fields. - -* With DuplicateRecordFields, we reject attempts to define a field and a - non-field with the same OccName (#17965): - - {-# LANGUAGE DuplicateRecordFields #-} - f x = x - data T = MkT { f :: Int} - - In principle this could be supported, but the current "specification" of - DuplicateRecordFields does not allow it. Thus isAllowedDup checks for - DuplicateRecordFields only if *both* GREs being compared are record fields. - -* However, with NoFieldSelectors, it is possible by design to define a field and - a non-field with the same OccName: - - {-# LANGUAGE NoFieldSelectors #-} - f x = x - data T = MkT { f :: Int} - - Thus isAllowedDup checks for NoFieldSelectors if either the existing or the - new GRE are record fields. See Note [NoFieldSelectors] in GHC.Rename.Env. - -See also Note [Skipping ambiguity errors at use sites of local declarations] in -GHC.Rename.Utils. --} - - -{- ********************************************************************* -* * - getLocalDeclBindersd@ returns the names for an HsDecl - It's used for source code. - - *** See Note [The Naming story] in GHC.Hs.Decls **** -* * -********************************************************************* -} - -getLocalNonValBinders :: MiniFixityEnv -> HsGroup GhcPs - -> RnM ((TcGblEnv, TcLclEnv), NameSet) --- Get all the top-level binders bound the group *except* --- for value bindings, which are treated separately --- Specifically we return AvailInfo for --- * type decls (incl constructors and record selectors) --- * class decls (including class ops) --- * associated types --- * foreign imports --- * value signatures (in hs-boot files only) - -getLocalNonValBinders fixity_env - (HsGroup { hs_valds = binds, - hs_tyclds = tycl_decls, - hs_fords = foreign_decls }) - = do { -- Process all type/class decls *except* family instances - ; let inst_decls = tycl_decls >>= group_instds - ; dup_fields_ok <- xopt_DuplicateRecordFields <$> getDynFlags - ; has_sel <- xopt_FieldSelectors <$> getDynFlags - ; (tc_avails, tc_fldss) - <- fmap unzip $ mapM (new_tc dup_fields_ok has_sel) - (tyClGroupTyClDecls tycl_decls) - ; traceRn "getLocalNonValBinders 1" (ppr tc_avails) - ; envs <- extendGlobalRdrEnvRn tc_avails fixity_env - ; restoreEnvs envs $ do { - -- Bring these things into scope first - -- See Note [Looking up family names in family instances] - - -- Process all family instances - -- to bring new data constructors into scope - ; (nti_availss, nti_fldss) <- mapAndUnzipM (new_assoc dup_fields_ok has_sel) - inst_decls - - -- Finish off with value binders: - -- foreign decls and pattern synonyms for an ordinary module - -- type sigs in case of a hs-boot file only - ; is_boot <- tcIsHsBootOrSig - ; let val_bndrs - | is_boot = case binds of - ValBinds _ _val_binds val_sigs -> - -- In a hs-boot file, the value binders come from the - -- *signatures*, and there should be no foreign binders - [ L (l2l decl_loc) (unLoc n) - | L decl_loc (TypeSig _ ns _) <- val_sigs, n <- ns] - _ -> panic "Non-ValBinds in hs-boot group" - | otherwise = for_hs_bndrs - ; val_avails <- mapM new_simple val_bndrs - - ; let avails = concat nti_availss ++ val_avails - new_bndrs = availsToNameSetWithSelectors avails `unionNameSet` - availsToNameSetWithSelectors tc_avails - flds = concat nti_fldss ++ concat tc_fldss - ; traceRn "getLocalNonValBinders 2" (ppr avails) - ; (tcg_env, tcl_env) <- extendGlobalRdrEnvRn avails fixity_env - - -- Force the field access so that tcg_env is not retained. The - -- selector thunk optimisation doesn't kick-in, see #20139 - ; let !old_field_env = tcg_field_env tcg_env - -- Extend tcg_field_env with new fields (this used to be the - -- work of extendRecordFieldEnv) - field_env = extendNameEnvList old_field_env flds - envs = (tcg_env { tcg_field_env = field_env }, tcl_env) - - ; traceRn "getLocalNonValBinders 3" (vcat [ppr flds, ppr field_env]) - ; return (envs, new_bndrs) } } - where - for_hs_bndrs :: [LocatedN RdrName] - for_hs_bndrs = hsForeignDeclsBinders foreign_decls - - -- the SrcSpan attached to the input should be the span of the - -- declaration, not just the name - new_simple :: LocatedN RdrName -> RnM AvailInfo - new_simple rdr_name = do{ nm <- newTopSrcBinder rdr_name - ; return (avail nm) } - - new_tc :: DuplicateRecordFields -> FieldSelectors -> LTyClDecl GhcPs - -> RnM (AvailInfo, [(Name, [FieldLabel])]) - new_tc dup_fields_ok has_sel tc_decl -- NOT for type/data instances - = do { let (bndrs, flds) = hsLTyClDeclBinders tc_decl - ; names@(main_name : sub_names) <- mapM (newTopSrcBinder . l2n) bndrs - ; flds' <- mapM (newRecordSelector dup_fields_ok has_sel sub_names) flds - ; let fld_env = case unLoc tc_decl of - DataDecl { tcdDataDefn = d } -> mk_fld_env d names flds' - _ -> [] - ; return (availTC main_name names flds', fld_env) } - - - -- Calculate the mapping from constructor names to fields, which - -- will go in tcg_field_env. It's convenient to do this here where - -- we are working with a single datatype definition. - mk_fld_env :: HsDataDefn GhcPs -> [Name] -> [FieldLabel] - -> [(Name, [FieldLabel])] - mk_fld_env d names flds = concatMap find_con_flds (dd_cons d) - where - find_con_flds (L _ (ConDeclH98 { con_name = L _ rdr - , con_args = RecCon cdflds })) - = [( find_con_name rdr - , concatMap find_con_decl_flds (unLoc cdflds) )] - find_con_flds (L _ (ConDeclGADT { con_names = rdrs - , con_g_args = RecConGADT flds _ })) - = [ ( find_con_name rdr - , concatMap find_con_decl_flds (unLoc flds)) - | L _ rdr <- toList rdrs ] - - find_con_flds _ = [] - - find_con_name rdr - = expectJust "getLocalNonValBinders/find_con_name" $ - find (\ n -> nameOccName n == rdrNameOcc rdr) names - find_con_decl_flds (L _ x) - = map find_con_decl_fld (cd_fld_names x) - - find_con_decl_fld (L _ (FieldOcc _ (L _ rdr))) - = expectJust "getLocalNonValBinders/find_con_decl_fld" $ - find (\ fl -> flLabel fl == lbl) flds - where lbl = FieldLabelString $ occNameFS (rdrNameOcc rdr) - - new_assoc :: DuplicateRecordFields -> FieldSelectors -> LInstDecl GhcPs - -> RnM ([AvailInfo], [(Name, [FieldLabel])]) - new_assoc _ _ (L _ (TyFamInstD {})) = return ([], []) - -- type instances don't bind new names - - new_assoc dup_fields_ok has_sel (L _ (DataFamInstD _ d)) - = do { (avail, flds) <- new_di dup_fields_ok has_sel Nothing d - ; return ([avail], flds) } - new_assoc dup_fields_ok has_sel (L _ (ClsInstD _ (ClsInstDecl { cid_poly_ty = inst_ty - , cid_datafam_insts = adts }))) - = do -- First, attempt to grab the name of the class from the instance. - -- This step could fail if the instance is not headed by a class, - -- such as in the following examples: - -- - -- (1) The class is headed by a bang pattern, such as in - -- `instance !Show Int` (#3811c) - -- (2) The class is headed by a type variable, such as in - -- `instance c` (#16385) - -- - -- If looking up the class name fails, then mb_cls_nm will - -- be Nothing. - mb_cls_nm <- runMaybeT $ do - -- See (1) above - L loc cls_rdr <- MaybeT $ pure $ getLHsInstDeclClass_maybe inst_ty - -- See (2) above - MaybeT $ setSrcSpan (locA loc) $ lookupGlobalOccRn_maybe cls_rdr - -- Assuming the previous step succeeded, process any associated data - -- family instances. If the previous step failed, bail out. - case mb_cls_nm of - Nothing -> pure ([], []) - Just cls_nm -> do - (avails, fldss) - <- mapAndUnzipM (new_loc_di dup_fields_ok has_sel (Just cls_nm)) adts - pure (avails, concat fldss) - - new_di :: DuplicateRecordFields -> FieldSelectors -> Maybe Name -> DataFamInstDecl GhcPs - -> RnM (AvailInfo, [(Name, [FieldLabel])]) - new_di dup_fields_ok has_sel mb_cls dfid@(DataFamInstDecl { dfid_eqn = ti_decl }) - = do { main_name <- lookupFamInstName mb_cls (feqn_tycon ti_decl) - ; let (bndrs, flds) = hsDataFamInstBinders dfid - ; sub_names <- mapM (newTopSrcBinder .l2n) bndrs - ; flds' <- mapM (newRecordSelector dup_fields_ok has_sel sub_names) flds - ; let avail = availTC (unLoc main_name) sub_names flds' - -- main_name is not bound here! - fld_env = mk_fld_env (feqn_rhs ti_decl) sub_names flds' - ; return (avail, fld_env) } - - new_loc_di :: DuplicateRecordFields -> FieldSelectors -> Maybe Name -> LDataFamInstDecl GhcPs - -> RnM (AvailInfo, [(Name, [FieldLabel])]) - new_loc_di dup_fields_ok has_sel mb_cls (L _ d) = new_di dup_fields_ok has_sel mb_cls d - -newRecordSelector :: DuplicateRecordFields -> FieldSelectors -> [Name] -> LFieldOcc GhcPs -> RnM FieldLabel -newRecordSelector _ _ [] _ = error "newRecordSelector: datatype has no constructors!" -newRecordSelector dup_fields_ok has_sel (dc:_) (L loc (FieldOcc _ (L _ fld))) - = do { selName <- newTopSrcBinder $ L (l2l loc) $ field - ; return $ FieldLabel { flLabel = fieldLabelString - , flHasDuplicateRecordFields = dup_fields_ok - , flHasFieldSelector = has_sel - , flSelector = selName } } - where - fieldLabelString = FieldLabelString $ occNameFS $ rdrNameOcc fld - selOccName = fieldSelectorOccName fieldLabelString (nameOccName dc) dup_fields_ok has_sel - field | isExact fld = fld - -- use an Exact RdrName as is to preserve the bindings - -- of an already renamer-resolved field and its use - -- sites. This is needed to correctly support record - -- selectors in Template Haskell. See Note [Binders in - -- Template Haskell] in "GHC.ThToHs" and Note [Looking up - -- Exact RdrNames] in "GHC.Rename.Env". - | otherwise = mkRdrUnqual selOccName - -{- -Note [Looking up family names in family instances] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - - module M where - type family T a :: * - type instance M.T Int = Bool - -We might think that we can simply use 'lookupOccRn' when processing the type -instance to look up 'M.T'. Alas, we can't! The type family declaration is in -the *same* HsGroup as the type instance declaration. Hence, as we are -currently collecting the binders declared in that HsGroup, these binders will -not have been added to the global environment yet. - -Solution is simple: process the type family declarations first, extend -the environment, and then process the type instances. - - -************************************************************************ -* * -\subsection{Filtering imports} -* * -************************************************************************ - -@filterImports@ takes the @ExportEnv@ telling what the imported module makes -available, and filters it through the import spec (if any). - -Note [Dealing with imports] -~~~~~~~~~~~~~~~~~~~~~~~~~~~ -For import M( ies ), we take the mi_exports of M, and make - imp_occ_env :: OccEnv (NameEnv (GreName, AvailInfo, Maybe Name)) -One entry for each OccName that M exports, mapping each corresponding Name to -its GreName, the AvailInfo exported from M that exports that Name, and -optionally a Name for an associated type's parent class. (Typically there will -be a single Name in the NameEnv, but see Note [Importing DuplicateRecordFields] -for why we may need more than one.) - -The situation is made more complicated by associated types. E.g. - module M where - class C a where { data T a } - instance C Int where { data T Int = T1 | T2 } - instance C Bool where { data T Int = T3 } -Then M's export_avails are (recall the AvailTC invariant from Avails.hs) - C(C,T), T(T,T1,T2,T3) -Notice that T appears *twice*, once as a child and once as a parent. From -this list we construct a raw list including - T -> (T, T( T1, T2, T3 ), Nothing) - T -> (T, C( C, T ), Nothing) -and we combine these (in function 'combine' in 'imp_occ_env' in -'filterImports') to get - T -> (T, T(T,T1,T2,T3), Just C) - -So the overall imp_occ_env is - C -> (C, C(C,T), Nothing) - T -> (T, T(T,T1,T2,T3), Just C) - T1 -> (T1, T(T,T1,T2,T3), Nothing) -- similarly T2,T3 - -If we say - import M( T(T1,T2) ) -then we get *two* Avails: C(T), T(T1,T2) - -Note that the imp_occ_env will have entries for data constructors too, -although we never look up data constructors. - -Note [Importing PatternSynonyms] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -As described in Note [Dealing with imports], associated types can lead to the -same Name appearing twice, both as a child and once as a parent, when -constructing the imp_occ_env. The same thing can happen with pattern synonyms -if they are exported bundled with a type. - -A simplified example, based on #11959: - - {-# LANGUAGE PatternSynonyms #-} - module M (T(P), pattern P) where -- Duplicate export warning, but allowed - data T = MkT - pattern P = MkT - -Here we have T(P) and P in export_avails, and construct both - P -> (P, P, Nothing) - P -> (P, T(P), Nothing) -which are 'combine'd to leave - P -> (P, T(P), Nothing) -i.e. we simply discard the non-bundled Avail. - -Note [Importing DuplicateRecordFields] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In filterImports, another complicating factor is DuplicateRecordFields. -Suppose we have: - - {-# LANGUAGE DuplicateRecordFields #-} - module M (S(foo), T(foo)) where - data S = MkS { foo :: Int } - data T = mkT { foo :: Int } - - module N where - import M (foo) -- this is allowed (A) - import M (S(foo)) -- this is allowed (B) - -Here M exports the OccName 'foo' twice, so we get an imp_occ_env where 'foo' -maps to a NameEnv containing an entry for each of the two mangled field selector -names (see Note [FieldLabel] in GHC.Types.FieldLabel). - - foo -> [ $sel:foo:MkS -> (foo, S(foo), Nothing) - , $sel:foo:MKT -> (foo, T(foo), Nothing) - ] - -Then when we look up 'foo' in lookup_names for case (A) we get both entries and -hence two Avails. Whereas in case (B) we reach the lookup_ie -case for IEThingWith, which looks up 'S' and then finds the unique 'foo' amongst -its children. - -See T16745 for a test of this. - --} - -filterImports - :: ModIface - -> ImpDeclSpec -- The span for the entire import decl - -> Maybe (ImportListInterpretation, LocatedL [LIE GhcPs]) -- Import spec; True => hiding - -> RnM (Maybe (ImportListInterpretation, LocatedL [LIE GhcRn]), -- Import spec w/ Names - [GlobalRdrElt]) -- Same again, but in GRE form -filterImports iface decl_spec Nothing - = return (Nothing, gresFromAvails (Just imp_spec) (mi_exports iface)) - where - imp_spec = ImpSpec { is_decl = decl_spec, is_item = ImpAll } - - -filterImports iface decl_spec (Just (want_hiding, L l import_items)) - = do -- check for errors, convert RdrNames to Names - items1 <- mapM lookup_lie import_items - - let items2 :: [(LIE GhcRn, AvailInfo)] - items2 = concat items1 - -- NB the AvailInfo may have duplicates, and several items - -- for the same parent; e.g N(x) and N(y) - - names = availsToNameSetWithSelectors (map snd items2) - keep n = not (n `elemNameSet` names) - pruned_avails = filterAvails keep all_avails - hiding_spec = ImpSpec { is_decl = decl_spec, is_item = ImpAll } - - gres | want_hiding == EverythingBut = gresFromAvails (Just hiding_spec) pruned_avails - | otherwise = concatMap (gresFromIE decl_spec) items2 - - return (Just (want_hiding, L l (map fst items2)), gres) - where - all_avails = mi_exports iface - - -- See Note [Dealing with imports] - imp_occ_env :: OccEnv (NameEnv (GreName, -- the name or field - AvailInfo, -- the export item providing it - Maybe Name)) -- the parent of associated types - imp_occ_env = mkOccEnv_C (plusNameEnv_C combine) - [ (occName c, mkNameEnv [(greNameMangledName c, (c, a, Nothing))]) - | a <- all_avails - , c <- availGreNames a] - -- See Note [Dealing with imports] - -- 'combine' may be called for associated data types which appear - -- twice in the all_avails. In the example, we combine - -- T(T,T1,T2,T3) and C(C,T) to give (T, T(T,T1,T2,T3), Just C) - -- NB: the AvailTC can have fields as well as data constructors (#12127) - combine :: (GreName, AvailInfo, Maybe Name) - -> (GreName, AvailInfo, Maybe Name) - -> (GreName, AvailInfo, Maybe Name) - combine (NormalGreName name1, a1@(AvailTC p1 _), mb1) - (NormalGreName name2, a2@(AvailTC p2 _), mb2) - = assertPpr (name1 == name2 && isNothing mb1 && isNothing mb2) - (ppr name1 <+> ppr name2 <+> ppr mb1 <+> ppr mb2) $ - if p1 == name1 then (NormalGreName name1, a1, Just p2) - else (NormalGreName name1, a2, Just p1) - -- 'combine' may also be called for pattern synonyms which appear both - -- unassociated and associated (see Note [Importing PatternSynonyms]). - combine (c1, a1, mb1) (c2, a2, mb2) - = assertPpr (c1 == c2 && isNothing mb1 && isNothing mb2 - && (isAvailTC a1 || isAvailTC a2)) - (ppr c1 <+> ppr c2 <+> ppr a1 <+> ppr a2 <+> ppr mb1 <+> ppr mb2) $ - if isAvailTC a1 then (c1, a1, Nothing) - else (c1, a2, Nothing) - - isAvailTC AvailTC{} = True - isAvailTC _ = False - - -- Look up a RdrName used in an import, failing if it is ambiguous - -- (e.g. because it refers to multiple record fields) - lookup_name :: IE GhcPs -> RdrName -> IELookupM (Name, AvailInfo, Maybe Name) - lookup_name ie rdr = do - xs <- lookup_names ie rdr - case xs of - [cax] -> return cax - _ -> failLookupWith (AmbiguousImport rdr (map sndOf3 xs)) - - -- Look up a RdrName used in an import, returning multiple values if there - -- are several fields with the same name exposed by the module - lookup_names :: IE GhcPs -> RdrName -> IELookupM [(Name, AvailInfo, Maybe Name)] - lookup_names ie rdr - | isQual rdr = failLookupWith (QualImportError rdr) - | Just succ <- mb_success = return $ map (\ (c,a,x) -> (greNameMangledName c, a, x)) (nonDetNameEnvElts succ) - | otherwise = failLookupWith (BadImport ie) - where - mb_success = lookupOccEnv imp_occ_env (rdrNameOcc rdr) - - lookup_lie :: LIE GhcPs -> TcRn [(LIE GhcRn, AvailInfo)] - lookup_lie (L loc ieRdr) - = do (stuff, warns) <- setSrcSpanA loc $ - liftM (fromMaybe ([],[])) $ - run_lookup (lookup_ie ieRdr) - mapM_ emit_warning warns - return [ (L loc ie, avail) | (ie,avail) <- stuff ] - where - -- Warn when importing T(..) if T was exported abstractly - emit_warning (DodgyImport n) = whenWOptM Opt_WarnDodgyImports $ - addTcRnDiagnostic (TcRnDodgyImports n) - emit_warning MissingImportList = whenWOptM Opt_WarnMissingImportList $ - addTcRnDiagnostic (TcRnMissingImportList ieRdr) - emit_warning (BadImportW ie) = whenWOptM Opt_WarnDodgyImports $ do - let msg = mkTcRnUnknownMessage $ - mkPlainDiagnostic (WarningWithFlag Opt_WarnDodgyImports) - noHints - (lookup_err_msg (BadImport ie)) - addDiagnostic msg - - run_lookup :: IELookupM a -> TcRn (Maybe a) - run_lookup m = case m of - Failed err -> do - addErr $ mkTcRnUnknownMessage $ mkPlainError noHints (lookup_err_msg err) - return Nothing - Succeeded a -> return (Just a) - - lookup_err_msg err = case err of - BadImport ie -> badImportItemErr iface decl_spec ie all_avails - IllegalImport -> illegalImportItemErr - QualImportError rdr -> qualImportItemErr rdr - AmbiguousImport rdr xs -> ambiguousImportItemErr rdr xs - - -- For each import item, we convert its RdrNames to Names, - -- and at the same time construct an AvailInfo corresponding - -- to what is actually imported by this item. - -- Returns Nothing on error. - -- We return a list here, because in the case of an import - -- item like C, if we are hiding, then C refers to *both* a - -- type/class and a data constructor. Moreover, when we import - -- data constructors of an associated family, we need separate - -- AvailInfos for the data constructors and the family (as they have - -- different parents). See Note [Dealing with imports] - lookup_ie :: IE GhcPs - -> IELookupM ([(IE GhcRn, AvailInfo)], [IELookupWarning]) - lookup_ie ie = handle_bad_import $ - case ie of - IEVar _ (L l n) -> do - -- See Note [Importing DuplicateRecordFields] - xs <- lookup_names ie (ieWrappedName n) - return ([(IEVar noExtField (L l (replaceWrappedName n name)), - trimAvail avail name) - | (name, avail, _) <- xs ], []) - - IEThingAll _ (L l tc) -> do - (name, avail, mb_parent) <- lookup_name ie $ ieWrappedName tc - let warns = case avail of - Avail {} -- e.g. f(..) - -> [DodgyImport $ ieWrappedName tc] - - AvailTC _ subs - | null (drop 1 subs) -- e.g. T(..) where T is a synonym - -> [DodgyImport $ ieWrappedName tc] - - | not (is_qual decl_spec) -- e.g. import M( T(..) ) - -> [MissingImportList] - - | otherwise - -> [] - - renamed_ie = IEThingAll noAnn (L l (replaceWrappedName tc name)) - sub_avails = case avail of - Avail {} -> [] - AvailTC name2 subs -> [(renamed_ie, AvailTC name2 (subs \\ [NormalGreName name]))] - case mb_parent of - Nothing -> return ([(renamed_ie, avail)], warns) - -- non-associated ty/cls - Just parent -> return ((renamed_ie, AvailTC parent [NormalGreName name]) : sub_avails, warns) - -- associated type - - IEThingAbs _ (L l tc') - | want_hiding == EverythingBut -- hiding ( C ) - -- Here the 'C' can be a data constructor - -- *or* a type/class, or even both - -> let tc = ieWrappedName tc' - tc_name = lookup_name ie tc - dc_name = lookup_name ie (setRdrNameSpace tc srcDataName) - in - case catIELookupM [ tc_name, dc_name ] of - [] -> failLookupWith (BadImport ie) - names -> return ([mkIEThingAbs tc' l name | name <- names], []) - | otherwise - -> do nameAvail <- lookup_name ie (ieWrappedName tc') - return ([mkIEThingAbs tc' l nameAvail] - , []) - - IEThingWith xt ltc@(L l rdr_tc) wc rdr_ns -> do - (name, avail, mb_parent) - <- lookup_name (IEThingAbs noAnn ltc) (ieWrappedName rdr_tc) - - -- Look up the children in the sub-names of the parent - -- See Note [Importing DuplicateRecordFields] - let subnames = availSubordinateGreNames avail - case lookupChildren subnames rdr_ns of - - Failed rdrs -> failLookupWith (BadImport (IEThingWith xt ltc wc rdrs)) - -- 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 - - Succeeded (childnames, childflds) -> - case mb_parent of - -- non-associated ty/cls - Nothing - -> return ([(IEThingWith childflds (L l name') wc childnames', - availTC name (name:map unLoc childnames) (map unLoc childflds))], - []) - where name' = replaceWrappedName rdr_tc name - childnames' = map to_ie_post_rn childnames - -- childnames' = postrn_ies childnames - -- associated ty - Just parent - -> return ([(IEThingWith childflds (L l name') wc childnames', - availTC name (map unLoc childnames) (map unLoc childflds)), - (IEThingWith childflds (L l name') wc childnames', - availTC parent [name] [])], - []) - where name' = replaceWrappedName rdr_tc name - childnames' = map to_ie_post_rn childnames - - _other -> failLookupWith IllegalImport - -- could be IEModuleContents, IEGroup, IEDoc, IEDocNamed - -- all errors. - - where - mkIEThingAbs tc l (n, av, Nothing ) - = (IEThingAbs noAnn (L l (replaceWrappedName tc n)), trimAvail av n) - mkIEThingAbs tc l (n, _, Just parent) - = (IEThingAbs noAnn (L l (replaceWrappedName tc n)) - , availTC parent [n] []) - - handle_bad_import m = catchIELookup m $ \err -> case err of - BadImport ie | want_hiding == EverythingBut -> return ([], [BadImportW ie]) - _ -> failLookupWith err - -type IELookupM = MaybeErr IELookupError - -data IELookupWarning - = BadImportW (IE GhcPs) - | MissingImportList - | DodgyImport RdrName - -- NB. use the RdrName for reporting a "dodgy" import - -data IELookupError - = QualImportError RdrName - | BadImport (IE GhcPs) - | IllegalImport - | AmbiguousImport RdrName [AvailInfo] -- e.g. a duplicated field name as a top-level import - -failLookupWith :: IELookupError -> IELookupM a -failLookupWith err = Failed err - -catchIELookup :: IELookupM a -> (IELookupError -> IELookupM a) -> IELookupM a -catchIELookup m h = case m of - Succeeded r -> return r - Failed err -> h err - -catIELookupM :: [IELookupM a] -> [a] -catIELookupM ms = [ a | Succeeded a <- ms ] - -{- -************************************************************************ -* * -\subsection{Import/Export Utils} -* * -************************************************************************ --} - --- | Given an import\/export spec, construct the appropriate 'GlobalRdrElt's. -gresFromIE :: ImpDeclSpec -> (LIE GhcRn, AvailInfo) -> [GlobalRdrElt] -gresFromIE decl_spec (L loc ie, avail) - = gresFromAvail prov_fn avail - where - is_explicit = case ie of - IEThingAll _ name -> \n -> n == lieWrappedName name - _ -> \_ -> True - prov_fn name - = Just (ImpSpec { is_decl = decl_spec, is_item = item_spec }) - where - item_spec = ImpSome { is_explicit = is_explicit name - , is_iloc = locA loc } - - -{- -Note [Children for duplicate record fields] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider the module - - {-# LANGUAGE DuplicateRecordFields #-} - module M (F(foo, MkFInt, MkFBool)) where - data family F a - data instance F Int = MkFInt { foo :: Int } - data instance F Bool = MkFBool { foo :: Bool } - -The `foo` in the export list refers to *both* selectors! For this -reason, lookupChildren builds an environment that maps the FastString -to a list of items, rather than a single item. --} - -mkChildEnv :: [GlobalRdrElt] -> NameEnv [GlobalRdrElt] -mkChildEnv gres = foldr add emptyNameEnv gres - where - add gre env = case gre_par gre of - ParentIs p -> extendNameEnv_Acc (:) Utils.singleton env p gre - NoParent -> env - -findChildren :: NameEnv [a] -> Name -> [a] -findChildren env n = lookupNameEnv env n `orElse` [] - -lookupChildren :: [GreName] -> [LIEWrappedName GhcPs] - -> MaybeErr [LIEWrappedName GhcPs] -- The ones for which the lookup failed - ([LocatedA Name], [Located FieldLabel]) --- (lookupChildren all_kids rdr_items) maps each rdr_item to its --- corresponding Name 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 (fmap concat (partitionEithers oks)) - -- This 'fmap concat' trickily applies concat to the /second/ component - -- of the pair, whose type is ([LocatedA Name], [[Located FieldLabel]]) - | otherwise - = Failed fails - where - mb_xs = map doOne rdr_items - fails = [ bad_rdr | Failed bad_rdr <- mb_xs ] - oks = [ ok | Succeeded ok <- mb_xs ] - oks :: [Either (LocatedA Name) [Located FieldLabel]] - - doOne item@(L l r) - = case (lookupFsEnv kid_env . occNameFS . rdrNameOcc . ieWrappedName) r of - Just [NormalGreName n] -> Succeeded (Left (L l n)) - Just rs | Just fs <- traverse greNameFieldLabel rs -> Succeeded (Right (map (L (locA l)) fs)) - _ -> Failed item - - -- See Note [Children for duplicate record fields] - kid_env = extendFsEnvList_C (++) emptyFsEnv - [(occNameFS (occName x), [x]) | x <- all_kids] - - - -------------------------------- - -{- -********************************************************* -* * -\subsection{Unused names} -* * -********************************************************* --} - -reportUnusedNames :: TcGblEnv -> HscSource -> RnM () -reportUnusedNames gbl_env hsc_src - = do { keep <- readTcRef (tcg_keep gbl_env) - ; traceRn "RUN" (ppr (tcg_dus gbl_env)) - ; warnUnusedImportDecls gbl_env hsc_src - ; warnUnusedTopBinds $ unused_locals keep - ; warnMissingSignatures gbl_env - ; warnMissingKindSignatures gbl_env } - where - used_names :: NameSet -> NameSet - used_names keep = findUses (tcg_dus gbl_env) emptyNameSet `unionNameSet` keep - -- NB: currently, if f x = g, we only treat 'g' as used if 'f' is used - -- Hence findUses - - -- Collect the defined names from the in-scope environment - defined_names :: [GlobalRdrElt] - defined_names = globalRdrEnvElts (tcg_rdr_env gbl_env) - - kids_env = mkChildEnv defined_names - -- This is done in mkExports too; duplicated work - - gre_is_used :: NameSet -> GlobalRdrElt -> Bool - gre_is_used used_names gre0 - = name `elemNameSet` used_names - || any (\ gre -> greMangledName gre `elemNameSet` used_names) (findChildren kids_env name) - -- A use of C implies a use of T, - -- if C was brought into scope by T(..) or T(C) - where - name = greMangledName gre0 - - -- Filter out the ones that are - -- (a) defined in this module, and - -- (b) not defined by a 'deriving' clause - -- The latter have an Internal Name, so we can filter them out easily - unused_locals :: NameSet -> [GlobalRdrElt] - unused_locals keep = - let -- Note that defined_and_used, defined_but_not_used - -- are both [GRE]; that's why we need defined_and_used - -- rather than just used_names - _defined_and_used, defined_but_not_used :: [GlobalRdrElt] - (_defined_and_used, defined_but_not_used) - = partition (gre_is_used (used_names keep)) defined_names - - in filter is_unused_local defined_but_not_used - is_unused_local :: GlobalRdrElt -> Bool - is_unused_local gre = isLocalGRE gre && isExternalName (greMangledName gre) - -{- ********************************************************************* -* * - Missing signatures -* * -********************************************************************* -} - -{- -Note [Missing signatures] -~~~~~~~~~~~~~~~~~~~~~~~~~ -There are four warning flags in play: - - * -Wmissing-exported-signatures - Warn about any exported top-level function/value without a type signature. - Does not include pattern synonyms. - - * -Wmissing-signatures - Warn about any top-level function/value without a type signature. Does not - include pattern synonyms. Takes priority over -Wmissing-exported-signatures. - - * -Wmissing-exported-pattern-synonym-signatures - Warn about any exported pattern synonym without a type signature. - - * -Wmissing-pattern-synonym-signatures - Warn about any pattern synonym without a type signature. Takes priority over - -Wmissing-exported-pattern-synonym-signatures. - --} - --- | Warn the user about top level binders that lack type signatures. --- Called /after/ type inference, so that we can report the --- inferred type of the function -warnMissingSignatures :: TcGblEnv -> RnM () -warnMissingSignatures gbl_env - = do { warn_binds <- woptM Opt_WarnMissingSignatures - ; warn_pat_syns <- woptM Opt_WarnMissingPatternSynonymSignatures - ; let exports = availsToNameSet (tcg_exports gbl_env) - sig_ns = tcg_sigs gbl_env - -- We use sig_ns to exclude top-level bindings that are generated by GHC - binds = collectHsBindsBinders CollNoDictBinders $ tcg_binds gbl_env - pat_syns = tcg_patsyns gbl_env - - not_ghc_generated :: Name -> Bool - not_ghc_generated name = name `elemNameSet` sig_ns - - add_binding_warn :: Id -> RnM () - add_binding_warn id = - when (not_ghc_generated name) $ - do { env <- tcInitTidyEnv -- Why not use emptyTidyEnv? - ; let (_, ty) = tidyOpenType env (idType id) - missing = MissingTopLevelBindingSig name ty - diag = TcRnMissingSignature missing exported warn_binds - ; addDiagnosticAt (getSrcSpan name) diag } - where - name = idName id - exported = if name `elemNameSet` exports - then IsExported - else IsNotExported - - add_patsyn_warn :: PatSyn -> RnM () - add_patsyn_warn ps = - when (not_ghc_generated name) $ - addDiagnosticAt (getSrcSpan name) - (TcRnMissingSignature missing exported warn_pat_syns) - where - name = patSynName ps - missing = MissingPatSynSig ps - exported = if name `elemNameSet` exports - then IsExported - else IsNotExported - - -- Warn about missing signatures - -- Do this only when we have a type to offer - -- See Note [Missing signatures] - ; mapM_ add_binding_warn binds - ; mapM_ add_patsyn_warn pat_syns - } - --- | Warn the user about tycons that lack kind signatures. --- Called /after/ type (and kind) inference, so that we can report the --- inferred kinds. -warnMissingKindSignatures :: TcGblEnv -> RnM () -warnMissingKindSignatures gbl_env - = do { cusks_enabled <- xoptM LangExt.CUSKs - ; mapM_ (add_ty_warn cusks_enabled) tcs - } - where - tcs = tcg_tcs gbl_env - ksig_ns = tcg_ksigs gbl_env - exports = availsToNameSet (tcg_exports gbl_env) - not_ghc_generated :: Name -> Bool - not_ghc_generated name = name `elemNameSet` ksig_ns - - add_ty_warn :: Bool -> TyCon -> RnM () - add_ty_warn cusks_enabled tyCon = - when (not_ghc_generated name) $ - addDiagnosticAt (getSrcSpan name) diag - where - name = tyConName tyCon - diag = TcRnMissingSignature missing exported False - missing = MissingTyConKindSig tyCon cusks_enabled - exported = if name `elemNameSet` exports - then IsExported - else IsNotExported - -{- -********************************************************* -* * -\subsection{Unused imports} -* * -********************************************************* - -This code finds which import declarations are unused. The -specification and implementation notes are here: - https://gitlab.haskell.org/ghc/ghc/wikis/commentary/compiler/unused-imports - -See also Note [Choosing the best import declaration] in GHC.Types.Name.Reader --} - -type ImportDeclUsage - = ( LImportDecl GhcRn -- The import declaration - , [GlobalRdrElt] -- What *is* used (normalised) - , [Name] ) -- What is imported but *not* used - -warnUnusedImportDecls :: TcGblEnv -> HscSource -> RnM () -warnUnusedImportDecls gbl_env hsc_src - = do { uses <- readMutVar (tcg_used_gres gbl_env) - ; let user_imports = filterOut - (ideclImplicit . ideclExt . unLoc) - (tcg_rn_imports gbl_env) - -- This whole function deals only with *user* imports - -- both for warning about unnecessary ones, and for - -- deciding the minimal ones - rdr_env = tcg_rdr_env gbl_env - fld_env = mkFieldEnv rdr_env - - ; let usage :: [ImportDeclUsage] - usage = findImportUsage user_imports uses - - ; traceRn "warnUnusedImportDecls" $ - (vcat [ text "Uses:" <+> ppr uses - , text "Import usage" <+> ppr usage]) - - ; whenWOptM Opt_WarnUnusedImports $ - mapM_ (warnUnusedImport Opt_WarnUnusedImports fld_env) usage - - ; whenGOptM Opt_D_dump_minimal_imports $ - printMinimalImports hsc_src usage } - -findImportUsage :: [LImportDecl GhcRn] - -> [GlobalRdrElt] - -> [ImportDeclUsage] - -findImportUsage imports used_gres - = map unused_decl imports - where - import_usage :: ImportMap - import_usage = mkImportMap used_gres - - unused_decl :: LImportDecl GhcRn -> (LImportDecl GhcRn, [GlobalRdrElt], [Name]) - unused_decl decl@(L loc (ImportDecl { ideclImportList = imps })) - = (decl, used_gres, nameSetElemsStable unused_imps) - where - used_gres = lookupSrcLoc (srcSpanEnd $ locA loc) import_usage - -- srcSpanEnd: see Note [The ImportMap] - `orElse` [] - - used_names = mkNameSet (map greMangledName 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 - _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 fs p wc ns) acc = - add_wc_all (add_unused_with pn xs acc) - where pn = lieWrappedName p - xs = map lieWrappedName ns ++ map (flSelector . unLoc) fs - add_wc_all = case wc of - NoIEWildcard -> id - 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_with p ns acc - | all (`elemNameSet` acc1) ns = add_unused_name p 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. - - -{- Note [The ImportMap] -~~~~~~~~~~~~~~~~~~~~~~~ -The ImportMap is a short-lived intermediate data structure records, for -each import declaration, what stuff brought into scope by that -declaration is actually used in the module. - -The SrcLoc is the location of the END of a particular 'import' -declaration. Why *END*? Because we don't want to get confused -by the implicit Prelude import. Consider (#7476) the module - import Foo( foo ) - main = print foo -There is an implicit 'import Prelude(print)', and it gets a SrcSpan -of line 1:1 (just the point, not a span). If we use the *START* of -the SrcSpan to identify the import decl, we'll confuse the implicit -import Prelude with the explicit 'import Foo'. So we use the END. -It's just a cheap hack; we could equally well use the Span too. - -The [GlobalRdrElt] are the things imported from that decl. --} - -type ImportMap = Map RealSrcLoc [GlobalRdrElt] -- See [The ImportMap] - -- If loc :-> gres, then - -- 'loc' = the end loc of the bestImport of each GRE in 'gres' - -mkImportMap :: [GlobalRdrElt] -> ImportMap --- For each of a list of used GREs, find all the import decls that brought --- it into scope; choose one of them (bestImport), and record --- the RdrName in that import decl's entry in the ImportMap -mkImportMap gres - = foldr add_one Map.empty gres - where - add_one gre@(GRE { gre_imp = imp_specs }) imp_map = - case srcSpanEnd (is_dloc (is_decl best_imp_spec)) of - -- For srcSpanEnd see Note [The ImportMap] - RealSrcLoc decl_loc _ -> Map.insertWith add decl_loc [gre] imp_map - UnhelpfulLoc _ -> imp_map - where - best_imp_spec = bestImport (bagToList imp_specs) - add _ gres = gre : gres - -warnUnusedImport :: WarningFlag -> NameEnv (FieldLabelString, Parent) - -> ImportDeclUsage -> RnM () -warnUnusedImport flag fld_env (L loc decl, used, unused) - - -- Do not warn for 'import M()' - | Just (Exactly, L _ []) <- ideclImportList decl - = return () - - -- Note [Do not warn about Prelude hiding] - | Just (EverythingBut, L _ hides) <- ideclImportList decl - , not (null hides) - , pRELUDE_NAME == unLoc (ideclName decl) - = return () - - -- Nothing used; drop entire declaration - | null used - = let dia = mkTcRnUnknownMessage $ - mkPlainDiagnostic (WarningWithFlag flag) noHints msg1 - in addDiagnosticAt (locA loc) dia - - -- Everything imported is used; nop - | null unused - = return () - - -- Only one import is unused, with `SrcSpan` covering only the unused item 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 - = let dia = mkTcRnUnknownMessage $ mkPlainDiagnostic (WarningWithFlag flag) noHints msg2 - in addDiagnosticAt (locA loc) dia - - -- Some imports are unused - | otherwise - = let dia = mkTcRnUnknownMessage $ mkPlainDiagnostic (WarningWithFlag flag) noHints msg2 - in addDiagnosticAt (locA loc) dia - - where - msg1 = vcat [ pp_herald <+> quotes pp_mod <+> 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 Outputable.empty ] - msg2 = sep [ pp_herald <+> quotes sort_unused - , text "from module" <+> quotes pp_mod <+> is_redundant] - pp_herald = text "The" <+> pp_qual <+> text "import of" - pp_qual - | isImportDeclQualified (ideclQualified decl)= text "qualified" - | otherwise = Outputable.empty - pp_mod = ppr (unLoc (ideclName decl)) - is_redundant = text "is redundant" - - -- In warning message, pretty-print identifiers unqualified unconditionally - -- to improve the consistent for ambiguous/unambiguous identifiers. - -- See trac#14881. - ppr_possible_field n = case lookupNameEnv fld_env n of - Just (fld, ParentIs p) -> pprNameUnqualified p <> parens (ppr fld) - Just (fld, NoParent) -> ppr fld - Nothing -> pprNameUnqualified n - - -- Print unused names in a deterministic (lexicographic) order - sort_unused :: SDoc - sort_unused = pprWithCommas ppr_possible_field $ - sortBy (comparing nameOccName) unused - -{- -Note [Do not warn about Prelude hiding] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We do not warn about - import Prelude hiding( x, y ) -because even if nothing else from Prelude is used, it may be essential to hide -x,y to avoid name-shadowing warnings. Example (#9061) - import Prelude hiding( log ) - f x = log where log = () - - - -Note [Printing minimal imports] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -To print the minimal imports we walk over the user-supplied import -decls, and simply trim their import lists. NB that - - * We do *not* change the 'qualified' or 'as' parts! - - * We do not discard a decl altogether; we might need instances - from it. Instead we just trim to an empty import list --} - -getMinimalImports :: [ImportDeclUsage] -> RnM [LImportDecl GhcRn] -getMinimalImports = fmap combine . mapM mk_minimal - where - mk_minimal (L l decl, used_gres, unused) - | null unused - , Just (Exactly, _) <- ideclImportList decl - = return (L l decl) - | otherwise - = do { let ImportDecl { ideclName = L _ mod_name - , ideclSource = is_boot - , ideclPkgQual = pkg_qual } = decl - ; iface <- loadSrcInterface doc mod_name is_boot pkg_qual - ; let used_avails = gresToAvailInfo used_gres - lies = map (L l) (concatMap (to_ie iface) used_avails) - ; return (L l (decl { ideclImportList = Just (Exactly, L (l2l l) lies) })) } - where - doc = text "Compute minimal imports for" <+> ppr decl - - to_ie :: ModIface -> AvailInfo -> [IE GhcRn] - -- The main trick here is that if we're importing all the constructors - -- we want to say "T(..)", but if we're importing only a subset we want - -- to say "T(A,B,C)". So we have to find out what the module exports. - to_ie _ (Avail c) -- Note [Overloaded field import] - = [IEVar noExtField (to_ie_post_rn $ noLocA (greNamePrintableName c))] - to_ie _ avail@(AvailTC n [_]) -- Exporting the main decl and nothing else - | availExportsDecl avail = [IEThingAbs noAnn (to_ie_post_rn $ noLocA n)] - to_ie iface (AvailTC n cs) - = case [xs | avail@(AvailTC x xs) <- mi_exports iface - , x == n - , availExportsDecl avail -- Note [Partial export] - ] of - [xs] | all_used xs -> - [IEThingAll noAnn (to_ie_post_rn $ noLocA n)] - | otherwise -> - [IEThingWith (map noLoc fs) (to_ie_post_rn $ noLocA n) NoIEWildcard - (map (to_ie_post_rn . noLocA) (filter (/= n) ns))] - -- Note [Overloaded field import] - _other | all_non_overloaded fs - -> map (IEVar noExtField . to_ie_post_rn_var . noLocA) $ ns - ++ map flSelector fs - | otherwise -> - [IEThingWith (map noLoc fs) (to_ie_post_rn $ noLocA n) NoIEWildcard - (map (to_ie_post_rn . noLocA) (filter (/= n) ns))] - where - (ns, fs) = partitionGreNames cs - - all_used avail_cs = all (`elem` cs) avail_cs - - all_non_overloaded = all (not . flIsOverloaded) - - combine :: [LImportDecl GhcRn] -> [LImportDecl GhcRn] - combine = map merge . NE.groupAllWith getKey - - getKey :: LImportDecl GhcRn -> (Bool, Maybe ModuleName, ModuleName) - getKey decl = - ( isImportDeclQualified . ideclQualified $ idecl -- is this qualified? (important that this be first) - , unLoc <$> ideclAs idecl -- what is the qualifier (inside Maybe monad) - , unLoc . ideclName $ idecl -- Module Name - ) - where - idecl :: ImportDecl GhcRn - idecl = unLoc decl - - merge :: NonEmpty (LImportDecl GhcRn) -> LImportDecl GhcRn - merge decls@((L l decl) :| _) = L l (decl { ideclImportList = Just (Exactly, L (noAnnSrcSpan (locA l)) lies) }) - where lies = concatMap (unLoc . snd) $ mapMaybe (ideclImportList . unLoc) $ NE.toList decls - - -printMinimalImports :: HscSource -> [ImportDeclUsage] -> RnM () --- See Note [Printing minimal imports] -printMinimalImports hsc_src imports_w_usage - = do { imports' <- getMinimalImports imports_w_usage - ; this_mod <- getModule - ; dflags <- getDynFlags - ; liftIO $ withFile (mkFilename dflags this_mod) WriteMode $ \h -> - printForUser dflags h neverQualify AllTheWay (vcat (map ppr imports')) - -- The neverQualify is important. We are printing Names - -- but they are in the context of an 'import' decl, and - -- we never qualify things inside there - -- E.g. import Blag( f, b ) - -- not import Blag( Blag.f, Blag.g )! - } - where - mkFilename dflags this_mod - | Just d <- dumpDir dflags = d basefn - | otherwise = basefn - where - suffix = case hsc_src of - HsBootFile -> ".imports-boot" - HsSrcFile -> ".imports" - HsigFile -> ".imports" - basefn = moduleNameString (moduleName this_mod) ++ suffix - - -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)) - - -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)) - where occ = occName n - -{- -Note [Partial export] -~~~~~~~~~~~~~~~~~~~~~ -Suppose we have - - module A( op ) where - class C a where - op :: a -> a - - module B where - import A - f = ..op... - -Then the minimal import for module B is - import A( op ) -not - import A( C( op ) ) -which we would usually generate if C was exported from B. Hence -the availExportsDecl test when deciding what to generate. - - -Note [Overloaded field import] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -On the other hand, if we have - - {-# LANGUAGE DuplicateRecordFields #-} - module A where - data T = MkT { foo :: Int } - - module B where - import A - f = ...foo... - -then the minimal import for module B must be - import A ( T(foo) ) -because when DuplicateRecordFields is enabled, field selectors are -not in scope without their enclosing datatype. - -On the third hand, if we have - - {-# LANGUAGE DuplicateRecordFields #-} - module A where - pattern MkT { foo } = Just foo - - module B where - import A - f = ...foo... - -then the minimal import for module B must be - import A ( foo ) -because foo doesn't have a parent. This might actually be ambiguous if A -exports another field called foo, but there is no good answer to return and this -is a very obscure corner, so it seems to be the best we can do. See -DRFPatSynExport for a test of this. - - -************************************************************************ -* * -\subsection{Errors} -* * -************************************************************************ --} - -qualImportItemErr :: RdrName -> SDoc -qualImportItemErr rdr - = hang (text "Illegal qualified name in import item:") - 2 (ppr rdr) - -ambiguousImportItemErr :: RdrName -> [AvailInfo] -> SDoc -ambiguousImportItemErr rdr avails - = hang (text "Ambiguous name" <+> quotes (ppr rdr) <+> text "in import item. It could refer to:") - 2 (vcat (map ppr_avail avails)) - where - ppr_avail (AvailTC parent _) = ppr parent <> parens (ppr rdr) - ppr_avail (Avail name) = ppr name - -pprImpDeclSpec :: ModIface -> ImpDeclSpec -> SDoc -pprImpDeclSpec iface decl_spec = - quotes (ppr (is_mod decl_spec)) <+> case mi_boot iface of - IsBoot -> text "(hi-boot interface)" - NotBoot -> Outputable.empty - -badImportItemErrStd :: ModIface -> ImpDeclSpec -> IE GhcPs -> SDoc -badImportItemErrStd iface decl_spec ie - = sep [text "Module", pprImpDeclSpec iface decl_spec, - text "does not export", quotes (ppr ie)] - -badImportItemErrDataCon :: OccName -> ModIface -> ImpDeclSpec -> IE GhcPs - -> SDoc -badImportItemErrDataCon dataType_occ iface decl_spec ie - = vcat [ text "In module" - <+> pprImpDeclSpec iface decl_spec - <> colon - , nest 2 $ quotes datacon - <+> text "is a data constructor of" - <+> quotes dataType - , text "To import it use" - , nest 2 $ text "import" - <+> ppr (is_mod decl_spec) - <> parens_sp (dataType <> parens_sp datacon) - , text "or" - , nest 2 $ text "import" - <+> ppr (is_mod decl_spec) - <> parens_sp (dataType <> text "(..)") - ] - where - datacon_occ = rdrNameOcc $ ieName ie - datacon = parenSymOcc datacon_occ (ppr datacon_occ) - dataType = parenSymOcc dataType_occ (ppr dataType_occ) - parens_sp d = parens (space <> d <> space) -- T( f,g ) - -badImportItemErr :: ModIface -> ImpDeclSpec -> IE GhcPs -> [AvailInfo] -> SDoc -badImportItemErr iface decl_spec ie avails - = case find checkIfDataCon avails of - Just con -> badImportItemErrDataCon (availOccName con) iface decl_spec ie - Nothing -> badImportItemErrStd iface decl_spec ie - where - checkIfDataCon (AvailTC _ ns) = - case find (\n -> importedFS == occNameFS (occName n)) ns of - Just n -> isDataConName (greNameMangledName n) - Nothing -> False - checkIfDataCon _ = False - availOccName = occName . availGreName - importedFS = occNameFS . rdrNameOcc $ ieName ie - -illegalImportItemErr :: SDoc -illegalImportItemErr = text "Illegal import item" - -addDupDeclErr :: NonEmpty GlobalRdrElt -> TcRn () -addDupDeclErr gres@(gre :| _) - = addErrAt (getSrcSpan (NE.last sorted_names)) $ mkTcRnUnknownMessage $ mkPlainError noHints $ - -- Report the error at the later location - vcat [text "Multiple declarations of" <+> - quotes (ppr (greOccName gre)), - -- 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 (toList $ ppr . nameSrcLoc <$> sorted_names)] - where - sorted_names = - NE.sortBy (SrcLoc.leftmost_smallest `on` nameSrcSpan) - (fmap greMangledName gres) - - - -missingImportListWarn :: ModuleName -> SDoc -missingImportListWarn mod - = text "The module" <+> quotes (ppr mod) <+> text "does not have an explicit import list" - -moduleWarn :: ModuleName -> WarningTxt GhcRn -> SDoc -moduleWarn mod (WarningTxt _ txt) - = sep [ text "Module" <+> quotes (ppr mod) <> colon, - nest 2 (vcat (map (ppr . hsDocString . unLoc) txt)) ] -moduleWarn mod (DeprecatedTxt _ txt) - = sep [ text "Module" <+> quotes (ppr mod) - <+> text "is deprecated:", - nest 2 (vcat (map (ppr . hsDocString . unLoc) txt)) ] - -packageImportErr :: TcRnMessage -packageImportErr - = mkTcRnUnknownMessage $ mkPlainError noHints $ - text "Package-qualified imports are not enabled; use PackageImports" - --- This data decl will parse OK --- data T = a Int --- treating "a" as the constructor. --- It is really hard to make the parser spot this malformation. --- So the renamer has to check that the constructor is legal --- --- We can get an operator as the constructor, even in the prefix form: --- data T = :% Int Int --- from interface files, which always print in prefix form --- --- We also allow type constructor names, which are defined by "type data" --- declarations. See Note [Type data declarations] in GHC.Rename.Module. - -checkConName :: RdrName -> TcRn () -checkConName name - = checkErr (isRdrDataCon name || isRdrTc name) (badDataCon name) - -badDataCon :: RdrName -> TcRnMessage -badDataCon name - = mkTcRnUnknownMessage $ mkPlainError noHints $ - hsep [text "Illegal data constructor name", quotes (ppr name)] +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE LambdaCase #-} + +module GHC.Rename.Names ( + rnImports, getLocalNonValBinders, newRecordFieldLabel, + importsFromIface, + ImportUserSpec(..), + extendGlobalRdrEnvRn, + gresFromAvails, + calculateAvails, + reportUnusedNames, + checkConName, + mkChildEnv, + findChildren, + findImportUsage, + getMinimalImports, + printMinimalImports, + renamePkgQual, renameRawPkgQual, + classifyGREs, + ImportDeclUsage + ) where + +import GHC.Prelude hiding ( head, init, last, tail ) + +import GHC.Driver.Env +import GHC.Driver.Session +import GHC.Driver.Ppr + +import GHC.Rename.Env +import GHC.Rename.Fixity +import GHC.Rename.Utils ( warnUnusedTopBinds ) +import GHC.Rename.Unbound +import qualified GHC.Rename.Unbound as Unbound + +import GHC.Tc.Errors.Types +import GHC.Tc.Utils.Env +import GHC.Tc.Utils.Monad +import GHC.Tc.Types.LclEnv +import GHC.Tc.Zonk.TcType ( tcInitTidyEnv ) + +import GHC.Hs +import GHC.Iface.Load ( loadSrcInterface ) +import GHC.Iface.Syntax ( fromIfaceWarnings ) +import GHC.Builtin.Names +import GHC.Parser.PostProcess ( setRdrNameSpace ) +import GHC.Core.TyCo.Tidy +import GHC.Core.PatSyn +import GHC.Core.TyCon ( TyCon, tyConName ) +import qualified GHC.LanguageExtensions as LangExt + +import GHC.Utils.Outputable as Outputable +import GHC.Utils.Misc as Utils +import GHC.Utils.Panic + +import GHC.Types.Fixity.Env +import GHC.Types.SafeHaskell +import GHC.Types.Name +import GHC.Types.Name.Env +import GHC.Types.Name.Set +import GHC.Types.Name.Reader +import GHC.Types.Avail +import GHC.Types.FieldLabel +import GHC.Types.Hint +import GHC.Types.SourceFile +import GHC.Types.SrcLoc as SrcLoc +import GHC.Types.Basic ( TopLevelFlag(..), TyConFlavour (..), convImportLevel ) +import GHC.Types.SourceText +import GHC.Types.Id +import GHC.Types.PkgQual +import GHC.Types.GREInfo (ConInfo(..), ConFieldInfo (..), ConLikeInfo (ConIsData)) + +import GHC.Unit +import GHC.Unit.Module.Warnings +import GHC.Unit.Module.ModIface +import GHC.Unit.Module.Imported +import GHC.Unit.Module.Deps +import GHC.Unit.Env + +import GHC.Data.Bag +import GHC.Data.FastString +import GHC.Data.FastString.Env +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 ) +import qualified Data.IntMap as IntMap +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 +import Data.Function ( on ) +import qualified Data.Set as S +import System.FilePath (()) +import System.IO + + +{- +************************************************************************ +* * +\subsection{rnImports} +* * +************************************************************************ + +Note [Tracking Trust Transitively] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When we import a package as well as checking that the direct imports are safe +according to the rules outlined in the Note [Safe Haskell Trust Check] in GHC.Driver.Main +we must also check that these rules hold transitively for all dependent modules +and packages. Doing this without caching any trust information would be very +slow as we would need to touch all packages and interface files a module depends +on. To avoid this we make use of the property that if a modules Safe Haskell +mode changes, this triggers a recompilation from that module in the dependency +graph. So we can just worry mostly about direct imports. + +There is one trust property that can change for a package though without +recompilation being triggered: package trust. So we must check that all +packages a module transitively depends on to be trusted are still trusted when +we are compiling this module (as due to recompilation avoidance some modules +below may not be considered trusted any more without recompilation being +triggered). + +We handle this by augmenting the existing transitive list of packages a module M +depends on with a bool for each package that says if it must be trusted when the +module M is being checked for trust. This list of trust required packages for a +single import is gathered in the rnImportDecl function and stored in an +ImportAvails data structure. The union of these trust required packages for all +imports is done by the rnImports function using the combine function which calls +the plusImportAvails function that is a union operation for the ImportAvails +type. This gives us in an ImportAvails structure all packages required to be +trusted for the module we are currently compiling. Checking that these packages +are still trusted (and that direct imports are trusted) is done in +GHC.Driver.Main.checkSafeImports. + +See the note below, [Trust Own Package] for a corner case in this method and +how its handled. + + +Note [Trust Own Package] +~~~~~~~~~~~~~~~~~~~~~~~~ +There is a corner case of package trust checking that the usual transitive check +doesn't cover. (For how the usual check operates see the Note [Tracking Trust +Transitively] below). The case is when you import a -XSafe module M and M +imports a -XTrustworthy module N. If N resides in a different package than M, +then the usual check works as M will record a package dependency on N's package +and mark it as required to be trusted. If N resides in the same package as M +though, then importing M should require its own package be trusted due to N +(since M is -XSafe so doesn't create this requirement by itself). The usual +check fails as a module doesn't record a package dependency of its own package. +So instead we now have a bool field in a modules interface file that simply +states if the module requires its own package to be trusted. This field avoids +us having to load all interface files that the module depends on to see if one +is trustworthy. + + +Note [Trust Transitive Property] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +So there is an interesting design question in regards to transitive trust +checking. Say I have a module B compiled with -XSafe. B is dependent on a bunch +of modules and packages, some packages it requires to be trusted as its using +-XTrustworthy modules from them. Now if I have a module A that doesn't use safe +haskell at all and simply imports B, should A inherit all the trust +requirements from B? Should A now also require that a package p is trusted since +B required it? + +We currently say no but saying yes also makes sense. The difference is, if a +module M that doesn't use Safe Haskell imports a module N that does, should all +the trusted package requirements be dropped since M didn't declare that it cares +about Safe Haskell (so -XSafe is more strongly associated with the module doing +the importing) or should it be done still since the author of the module N that +uses Safe Haskell said they cared (so -XSafe is more strongly associated with +the module that was compiled that used it). + +Going with yes is a simpler semantics we think and harder for the user to stuff +up but it does mean that Safe Haskell will affect users who don't care about +Safe Haskell as they might grab a package from Cabal which uses safe haskell (say +network) and that packages imports -XTrustworthy modules from another package +(say bytestring), so requires that package is trusted. The user may now get +compilation errors in code that doesn't do anything with Safe Haskell simply +because they are using the network package. They will have to call 'ghc-pkg +trust network' to get everything working. Due to this invasive nature of going +with yes we have gone with no for now. +-} + +-- | Process Import Decls. See 'rnImportDecl' for a description of what +-- the return types represent. +-- Note: Do the non SOURCE ones first, so that we get a helpful warning +-- for SOURCE ones that are unnecessary +rnImports :: [(LImportDecl GhcPs, SDoc)] + -> RnM ([LImportDecl GhcRn], [ImportUserSpec], GlobalRdrEnv, ImportAvails) +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::LImportDecl GhcPs) = ideclSource (unLoc d) == IsBoot + stuff1 <- mapAndReportM (rnImportDecl this_mod) ordinary + stuff2 <- mapAndReportM (rnImportDecl this_mod) source + -- Safe Haskell: See Note [Tracking Trust Transitively] + let (decls, imp_user_spec, rdr_env, imp_avails) = combine (stuff1 ++ stuff2) + -- Update imp_boot_mods if imp_direct_mods mentions any of them + let merged_import_avail = clobberSourceImports imp_avails + return (decls, imp_user_spec, rdr_env, merged_import_avail) + + where + clobberSourceImports imp_avails = + imp_avails { imp_boot_mods = imp_boot_mods' } + where + imp_boot_mods' = mergeInstalledModuleEnv combJ id (const emptyInstalledModuleEnv) + (imp_boot_mods imp_avails) + (imp_direct_dep_mods imp_avails) + + combJ (GWIB _ IsBoot) (_, x) = Just x + combJ r _ = Just r + -- See Note [Combining ImportAvails] + combine :: [(LImportDecl GhcRn, ImportUserSpec, GlobalRdrEnv, ImportAvails)] + -> ([LImportDecl GhcRn], [ImportUserSpec], GlobalRdrEnv, ImportAvails) + combine ss = + let (decls, imp_user_spec, rdr_env, imp_avails, finsts) = foldr + plus + ([], [], emptyGlobalRdrEnv, emptyImportAvails, emptyModuleSet) + ss + in (decls, imp_user_spec, rdr_env, imp_avails { imp_finsts = moduleSetElts finsts }) + + 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, + extendModuleSetList finsts_set new_finsts ) + where + imp_avails1' = imp_avails1 { imp_finsts = [] } + new_finsts = imp_finsts imp_avails1 + +{- +Note [Combining ImportAvails] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +imp_finsts in ImportAvails is a list of family instance modules +transitively depended on by an import. imp_finsts for a currently +compiled module is a union of all the imp_finsts of imports. +Computing the union of two lists of size N is O(N^2) and if we +do it to M imports we end up with O(M*N^2). That can get very +expensive for bigger module hierarchies. + +Union can be optimized to O(N log N) if we use a Set. +imp_finsts is converted back and forth between dep_finsts, so +changing a type of imp_finsts means either paying for the conversions +or changing the type of dep_finsts as well. + +I've measured that the conversions would cost 20% of allocations on my +test case, so that can be ruled out. + +Changing the type of dep_finsts forces checkFamInsts to +get the module lists in non-deterministic order. If we wanted to restore +the deterministic order, we'd have to sort there, which is an additional +cost. As far as I can tell, using a non-deterministic order is fine there, +but that's a brittle nonlocal property which I'd like to avoid. + +Additionally, dep_finsts is read from an interface file, so its "natural" +type is a list. Which makes it a natural type for imp_finsts. + +Since rnImports.combine is really the only place that would benefit from +it being a Set, it makes sense to optimize the hot loop in rnImports.combine +without changing the representation. + +So here's what we do: instead of naively merging ImportAvails with +plusImportAvails in a loop, we make plusImportAvails merge empty imp_finsts +and compute the union on the side using Sets. When we're done, we can +convert it back to a list. One nice side effect of this approach is that +if there's a lot of overlap in the imp_finsts of imports, the +Set doesn't really need to grow and we don't need to allocate. + +Running generateModules from #14693 with DEPTH=16, WIDTH=30 finishes in +23s before, and 11s after. +-} + +-- | Given a located import declaration @decl@ from @this_mod@, +-- calculate the following pieces of information: +-- +-- 1. An updated 'LImportDecl', where all unresolved 'RdrName' in +-- the entity lists have been resolved into 'Name's, +-- +-- 2. A 'GlobalRdrEnv' representing the new identifiers that were +-- brought into scope (taking into account module qualification +-- and hiding), +-- +-- 3. 'ImportAvails' summarizing the identifiers that were imported +-- by this declaration, and +-- +-- 4. A boolean 'AnyHpcUsage' which is true if the imported module +-- used HPC. +rnImportDecl :: Module -> (LImportDecl GhcPs, SDoc) + -> 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 + , ideclLevelSpec = import_level + , ideclQualified = qual_style + , ideclExt = XImportDeclPass { ideclImplicit = implicit } + , ideclAs = as_mod, ideclImportList = imp_details }), import_reason) + = setSrcSpanA loc $ do + + case raw_pkg_qual of + NoRawPkgQual -> pure () + RawPkgQual _ -> do + pkg_imports <- xoptM LangExt.PackageImports + when (not pkg_imports) $ addErr TcRnPackageImportsDisabled + + let qual_only = isImportDeclQualified qual_style + + -- If there's an error in loadInterface, (e.g. interface + -- file not found) we get lots of spurious errors from 'filterImports' + let imp_mod_name = unLoc loc_imp_mod_name + doc = ppr imp_mod_name <+> import_reason + + hsc_env <- getTopEnv + unit_env <- hsc_unit_env <$> getTopEnv + let pkg_qual = renameRawPkgQual unit_env imp_mod_name raw_pkg_qual + + -- Check for self-import, which confuses the typechecker (#9032) + -- ghc --make rejects self-import cycles already, but batch-mode may not + -- at least not until GHC.IfaceToCore.tcHiBootIface, which is too late to avoid + -- typechecker crashes. (Indirect self imports are not caught until + -- GHC.IfaceToCore, see #10337 tracking how to make this error better.) + -- + -- Originally, we also allowed 'import {-# SOURCE #-} M', but this + -- caused bug #10182: in one-shot mode, we should never load an hs-boot + -- file for the module we are compiling into the EPS. In principle, + -- it should be possible to support this mode of use, but we would have to + -- extend Provenance to support a local definition in a qualified location. + -- For now, we don't support it, but see #10336 + when (imp_mod_name == moduleName this_mod && + (case pkg_qual of -- If we have import "" M, then we should + -- check that "" is "this" (which is magic) + -- or the name of this_mod's package. Yurgh! + -- c.f. GHC.findModule, and #9997 + NoPkgQual -> True + ThisPkg uid -> uid == homeUnitId_ (hsc_dflags hsc_env) + OtherPkg _ -> False)) + (addErr (TcRnSelfImport imp_mod_name)) + + -- Check for a missing import list (Opt_WarnMissingImportList also + -- checks for T(..) items but that is done in checkDodgyImport below) + case imp_details of + Just (Exactly, _) -> return () -- Explicit import list + _ | implicit -> return () -- Do not bleat for implicit imports + | qual_only -> return () + | otherwise -> addDiagnostic (TcRnNoExplicitImportList imp_mod_name) + + + iface <- loadSrcInterface doc imp_mod_name want_boot pkg_qual + + -- Compiler sanity check: if the import didn't say + -- {-# SOURCE #-} we should not get a hi-boot file + warnPprTrace ((want_boot == NotBoot) && (mi_boot iface == IsBoot)) "rnImportDecl" (ppr imp_mod_name) $ do + + -- Issue a user warning for a redundant {- SOURCE -} import + -- NB that we arrange to read all the ordinary imports before + -- any of the {- SOURCE -} imports. + -- + -- in --make and GHCi, the compilation manager checks for this, + -- and indeed we shouldn't do it here because the existence of + -- the non-boot module depends on the compilation order, which + -- is not deterministic. The hs-boot test can show this up. + dflags <- getDynFlags + warnIf ((want_boot == IsBoot) && (mi_boot iface == NotBoot) && isOneShot (ghcMode dflags)) + (TcRnRedundantSourceImport imp_mod_name) + when (mod_safe && not (safeImportsOn dflags)) $ + addErr (TcRnSafeImportsDisabled imp_mod_name) + + 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_pkg_qual = pkg_qual, is_isboot = want_boot, + is_level = convImportLevel import_level } + + -- filter the imports according to the import declaration + (new_imp_details, imp_user_list, gbl_env) <- filterImports hsc_env iface imp_spec imp_details + + -- for certain error messages, we’d like to know what could be imported + -- here, if everything were imported + potential_gres <- (\(_,_,x) -> x) <$> filterImports hsc_env iface imp_spec Nothing + + let is_hiding | Just (EverythingBut,_) <- imp_details = True + | otherwise = False + + -- should the import be safe? + mod_safe' = mod_safe + || (not implicit && safeDirectImpsReq dflags) + || (implicit && safeImplicitImpsReq dflags) + + hsc_env <- getTopEnv + let home_unit = hsc_home_unit hsc_env + other_home_units = hsc_all_home_unit_ids hsc_env + imv = ImportedModsVal + { 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) + + -- Complain if we import a deprecated module + case fromIfaceWarnings (mi_warns iface) of + WarnAll txt -> addDiagnostic (TcRnDeprecatedModule imp_mod_name txt) + _ -> return () + + let new_imp_decl = ImportDecl + { ideclExt = ideclExt decl + , ideclName = ideclName decl + , ideclPkgQual = pkg_qual + , ideclSource = ideclSource decl + , ideclSafe = mod_safe' + , ideclQualified = ideclQualified decl + , ideclAs = ideclAs decl + , ideclImportList = new_imp_details + , ideclLevelSpec = ideclLevelSpec decl + } + + return (L loc new_imp_decl, ImpUserSpec imp_spec imp_user_list, gbl_env, imports) + + +-- | Rename raw package imports +renameRawPkgQual :: UnitEnv -> ModuleName -> RawPkgQual -> PkgQual +renameRawPkgQual unit_env mn = \case + NoRawPkgQual -> NoPkgQual + RawPkgQual p -> renamePkgQual unit_env mn (Just (sl_fs p)) + +-- | Rename raw package imports +renamePkgQual :: UnitEnv -> ModuleName -> Maybe FastString -> PkgQual +renamePkgQual unit_env mn mb_pkg = case mb_pkg of + Nothing -> NoPkgQual + Just pkg_fs + | Just uid <- homeUnitId <$> ue_homeUnit unit_env + , pkg_fs == fsLit "this" + -> ThisPkg uid + + | Just (uid, _) <- find (fromMaybe False . fmap (== pkg_fs) . snd) home_names + -> ThisPkg uid + + | Just uid <- resolvePackageImport unit_state mn (PackageName pkg_fs) + -> OtherPkg uid + + | otherwise + -> OtherPkg (UnitId pkg_fs) + -- not really correct as pkg_fs is unlikely to be a valid unit-id but + -- we will report the failure later... + where + home_names = map (\uid -> (uid, mkFastString <$> thisPackageName (homeUnitEnv_dflags (ue_findHomeUnitEnv uid unit_env)))) hpt_deps + + unit_state = ue_homeUnitState unit_env + + hpt_deps :: [UnitId] + hpt_deps = homeUnitDepends unit_state + + +-- | Calculate the 'ImportAvails' induced by an import of a particular +-- interface, but without 'imp_mods'. +calculateAvails :: HomeUnit + -> S.Set UnitId + -> ModIface + -> IsSafeImport + -> IsBootInterface + -> ImportedBy + -> ImportAvails +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 iface + has_finsts = mi_finsts iface + deps = mi_deps iface + trust = getSafeMode $ mi_trust iface + trust_pkg = mi_trust_pkg iface + is_sig = mi_hsc_src iface == HsigFile + + -- If the module exports anything defined in this module, just + -- ignore it. Reason: otherwise it looks as if there are two + -- local definition sites for the thing, and an error gets + -- reported. Easiest thing is just to filter them out up + -- front. This situation only arises if a module imports + -- itself, or another module that imported it. (Necessarily, + -- this involves a loop.) + -- + -- We do this *after* filterImports, so that if you say + -- module A where + -- import B( AType ) + -- type AType = ... + -- + -- module B( AType ) where + -- import {-# SOURCE #-} A( AType ) + -- + -- then you won't get a 'B does not export AType' message. + + + -- Compute new transitive dependencies + -- + -- 'dep_orphs' and 'dep_finsts' do NOT include the imported module + -- itself, but we DO need to include this module in 'imp_orphs' and + -- 'imp_finsts' if it defines an orphan or instance family; thus the + -- orph_iface/has_iface tests. + + deporphs = dep_orphs deps + depfinsts = dep_finsts deps + + orphans | orph_iface = assertPpr (not (imp_sem_mod `elem` deporphs)) (ppr imp_sem_mod <+> ppr deporphs) $ + imp_sem_mod : deporphs + | otherwise = deporphs + + finsts | has_finsts = assertPpr (not (imp_sem_mod `elem` depfinsts)) (ppr imp_sem_mod <+> ppr depfinsts) $ + imp_sem_mod : depfinsts + | otherwise = depfinsts + + -- Trusted packages are a lot like orphans. + trusted_pkgs | mod_safe' = dep_trusted_pkgs deps + | otherwise = S.empty + + + pkg = moduleUnit (mi_module iface) + ipkg = toUnitId pkg + + -- Does this import mean we now require our own pkg + -- to be trusted? See Note [Trust Own Package] + ptrust = trust == Sf_Trustworthy || trust_pkg + pkg_trust_req + | isHomeUnit home_unit pkg = ptrust + | otherwise = False + + dependent_pkgs = if toUnitId pkg `S.member` other_home_units + then S.empty + else S.singleton (lvl, ipkg) + + 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) + -- Now we are importing A properly, so don't go looking for + -- A.hs-boot + | isHomeUnit home_unit pkg = dep_boot_mods_map + -- There's no boot files to find in external imports + | otherwise = emptyInstalledModuleEnv + + sig_mods = + if is_sig + then moduleName imp_mod : dep_sig_mods deps + else dep_sig_mods deps + + + in ImportAvails { + imp_mods = Map.singleton (mi_module iface) [imported_by], + imp_orphs = orphans, + imp_finsts = finsts, + imp_sig_mods = sig_mods, + imp_direct_dep_mods = direct_mods, + imp_dep_direct_pkgs = dependent_pkgs, + imp_boot_mods = boot_mods, + + -- Add in the imported modules trusted package + -- requirements. ONLY do this though if we import the + -- module as a safe import. + -- See Note [Tracking Trust Transitively] + -- and Note [Trust Transitive Property] + imp_trust_pkgs = trusted_pkgs, + -- Do we require our own pkg to be trusted? + -- See Note [Trust Own Package] + imp_trust_own_pkg = pkg_trust_req + } + +mkPlusModDeps :: UnitId -> ImportLevel -> ModuleNameWithIsBoot + -> InstalledModuleEnv (S.Set ImportLevel, ModuleNameWithIsBoot) +mkPlusModDeps uid st elt = extendInstalledModuleEnv emptyInstalledModuleEnv (mkModule uid (gwib_mod elt)) (S.singleton st, elt) + +{- +************************************************************************ +* * +\subsection{importsFromLocalDecls} +* * +************************************************************************ + +From the top-level declarations of this module produce + * the lexical environment + * the ImportAvails +created by its bindings. + +Note [Top-level Names in Template Haskell decl quotes] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +See also: Note [Interactively-bound Ids in GHCi] in GHC.Driver.Env + Note [Looking up Exact RdrNames] in GHC.Rename.Env + +Consider a Template Haskell declaration quotation like this: + module M where + f x = h [d| f = 3 |] +When renaming the declarations inside [d| ...|], we treat the +top level binders specially in two ways + +1. We give them an Internal Name, not (as usual) an External one. + This is done by GHC.Rename.Env.newTopSrcBinder. + +2. We make them *shadow* the outer bindings. + See Note [GlobalRdrEnv shadowing] + +3. We find out whether we are inside a [d| ... |] by testing the TH + 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. +-} + +extendGlobalRdrEnvRn :: [GlobalRdrElt] + -> MiniFixityEnv + -> RnM (TcGblEnv, TcLclEnv) +-- Updates both the GlobalRdrEnv and the FixityEnv +-- We return a new TcLclEnv only because we might have to +-- delete some bindings from it; +-- see Note [Top-level Names in Template Haskell decl quotes] + +extendGlobalRdrEnvRn new_gres new_fixities + = checkNoErrs $ -- See Note [Fail fast on duplicate definitions] + do { (gbl_env, lcl_env) <- getEnvs + ; 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 = 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 = 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] + + lcl_env2 | inBracket = lcl_env_TH + | otherwise = lcl_env + + -- Deal with shadowing: see Note [GlobalRdrEnv shadowing] + want_shadowing = isGHCi || inBracket + rdr_env1 | want_shadowing = shadowNames False rdr_env new_gres_env + | otherwise = rdr_env + + lcl_env3 = modifyLclCtxt (\lcl_env -> lcl_env { tcl_th_bndrs = extendNameEnvList th_bndrs + [ ( n, (TopLevel, th_lvl) ) + | n <- new_names ] }) lcl_env2 + + ; rdr_env2 <- foldlM add_gre rdr_env1 new_gres + + ; let fix_env' = foldl' extend_fix_env fix_env new_gres + gbl_env' = gbl_env { tcg_rdr_env = rdr_env2, tcg_fix_env = fix_env' } + + ; traceRn "extendGlobalRdrEnvRn 2" (pprGlobalRdrEnv True rdr_env2) + ; return (gbl_env', lcl_env3) } + where + new_names = map greName new_gres + new_gres_env = mkGlobalRdrEnv new_gres + + -- If there is a fixity decl for the gre, add it to the fixity env + extend_fix_env fix_env gre + | Just (L _ fi) <- lookupMiniFixityEnv new_fixities name + = extendNameEnv fix_env name (FixItem occ fi) + | otherwise + = fix_env + where + name = greName gre + occ = greOccName gre + + add_gre :: GlobalRdrEnv -> GlobalRdrElt -> RnM GlobalRdrEnv + -- Extend the GlobalRdrEnv with a LocalDef GRE + -- If there is already a LocalDef GRE with the same OccName, + -- report an error and discard the new GRE + -- This establishes INVARIANT 1 of GlobalRdrEnvs + add_gre env gre + | not (null dups) -- Same OccName defined twice + = do { addDupDeclErr (gre :| dups); return env } + + | otherwise + = return (extendGlobalRdrEnv env gre) + where + -- See Note [Reporting duplicate local declarations] + dups = filter isBadDupGRE + $ lookupGRE env (LookupOccName (greOccName gre) (RelevantGREsFOS WantBoth)) + isBadDupGRE old_gre = isLocalGRE old_gre && greClashesWith gre old_gre + +{- Note [Fail fast on duplicate definitions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If there are duplicate bindings for the same thing, we want to fail +fast. Having two bindings for the same thing can cause follow-on errors. +Example (test T9975a): + data Test = Test { x :: Int } + pattern Test wat = Test { x = wat } +This defines 'Test' twice. The second defn has no field-names; and then +we get an error from Test { x=wat }, saying "Test has no field 'x'". + +Easiest thing is to bale out fast on duplicate definitions, which +we do via `checkNoErrs` on `extendGlobalRdrEnvRn`. + +Note [Reporting duplicate local declarations] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In general, a single module may not define the same OccName multiple times. This +is checked in extendGlobalRdrEnvRn: when adding a new locally-defined GRE to the +GlobalRdrEnv we report an error if there are already duplicates in the +environment. This establishes INVARIANT 1 (see comments on GlobalRdrEnv in +GHC.Types.Name.Reader), which says that for a given OccName, all the +GlobalRdrElts to which it maps must have distinct 'greName's. + +For example, the following will be rejected: + + f x = x + g x = x + f x = x -- Duplicate! + +Users are allowed to introduce new GREs with the same OccName as an imported GRE, +as disambiguation is possible through the module system, e.g.: + + module M where + import N (f) + f x = x + g x = M.f x + N.f x + +If both GREs are local, the general rule is that two GREs clash if they have +the same OccName, i.e. they share a textual name and live in the same namespace. +However, there are additional clashes due to record fields: + + - a new variable clashes with previously defined record fields + which define field selectors, + + - a new record field shadows: + + - previously defined variables, if it defines a field selector, + - previously defined record fields, unless it is a duplicate record field. + +This logic is implemented in the function 'GHC.Types.Name.Reader.greClashesWith'. + +See also Note [Skipping ambiguity errors at use sites of local declarations] in +GHC.Rename.Utils. +-} + + +{- ********************************************************************* +* * + getLocalDeclBindersd@ returns the names for an HsDecl + It's used for source code. + + *** See Note [The Naming story] in GHC.Hs.Decls **** +* * +********************************************************************* -} + +getLocalNonValBinders :: MiniFixityEnv -> HsGroup GhcPs + -> RnM ((TcGblEnv, TcLclEnv), NameSet) +-- Get all the top-level binders bound the group *except* +-- for value bindings, which are treated separately +-- Specifically we return AvailInfo for +-- * type decls (incl constructors and record selectors) +-- * class decls (including class ops) +-- * associated types +-- * foreign imports +-- * value signatures (in hs-boot files only) + +getLocalNonValBinders fixity_env + (HsGroup { hs_valds = binds, + hs_tyclds = tycl_decls, + hs_fords = foreign_decls }) + = do { -- Process all type/class decls *except* family instances + ; let inst_decls = tycl_decls >>= group_instds + ; dup_fields_ok <- xopt_DuplicateRecordFields <$> getDynFlags + ; has_sel <- xopt_FieldSelectors <$> getDynFlags + ; tc_gres + <- concatMapM + (new_tc dup_fields_ok has_sel) + (tyClGroupTyClDecls tycl_decls) + ; traceRn "getLocalNonValBinders 1" (ppr tc_gres) + ; envs <- extendGlobalRdrEnvRn tc_gres fixity_env + ; restoreEnvs envs $ do { + -- Bring these things into scope first + -- See Note [Looking up family names in family instances] + + -- Process all family instances + -- to bring new data constructors into scope + ; nti_gress <- mapM (new_assoc dup_fields_ok has_sel) inst_decls + + -- Finish off with value binders: + -- foreign decls and pattern synonyms for an ordinary module + -- type sigs in case of a hs-boot file only + ; is_boot <- tcIsHsBootOrSig + ; let val_bndrs + | is_boot = case binds of + ValBinds _ _val_binds val_sigs -> + -- In a hs-boot file, the value binders come from the + -- *signatures*, and there should be no foreign binders + [ L (l2l decl_loc) (unLoc n) + | L decl_loc (TypeSig _ ns _) <- val_sigs, n <- ns] + _ -> panic "Non-ValBinds in hs-boot group" + | otherwise = for_hs_bndrs + ; val_gres <- mapM new_simple val_bndrs + + ; let avails = concat nti_gress ++ val_gres + new_bndrs = gresToNameSet avails `unionNameSet` + gresToNameSet tc_gres + ; traceRn "getLocalNonValBinders 2" (ppr avails) + ; envs <- extendGlobalRdrEnvRn avails fixity_env + ; return (envs, new_bndrs) } } + where + for_hs_bndrs :: [LocatedN RdrName] + for_hs_bndrs = hsForeignDeclsBinders foreign_decls + + -- the SrcSpan attached to the input should be the span of the + -- declaration, not just the name + new_simple :: LocatedN RdrName -> RnM GlobalRdrElt + new_simple rdr_name = do { nm <- newTopSrcBinder rdr_name + ; return (mkLocalVanillaGRE NoParent nm) } + + new_tc :: DuplicateRecordFields -> FieldSelectors -> LTyClDecl GhcPs + -> RnM [GlobalRdrElt] + 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 $ 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 + fld_env = mk_fld_env con_names_with_flds flds' + at_gres = zipWith (\ (_, at_flav) at_nm -> mkLocalTyConGRE (fmap (const tycon_name) at_flav) at_nm) + at_bndrs at_names + sig_gres = map (mkLocalVanillaGRE (ParentIs tycon_name)) sig_names + con_gres = map (mkLocalConLikeGRE (ParentIs tycon_name)) fld_env + fld_gres = mkLocalFieldGREs (ParentIs tycon_name) fld_env + sub_gres = at_gres ++ sig_gres ++ con_gres ++ fld_gres + ; traceRn "getLocalNonValBinders new_tc" $ + vcat [ text "tycon:" <+> ppr tycon_name + , text "tc_gre:" <+> ppr tc_gre + , text "sub_gres:" <+> ppr sub_gres ] + ; return $ tc_gre : sub_gres } + + -- Calculate the record field information, which feeds into the GlobalRdrElts + -- for DataCons and their fields. It's convenient to do this here where + -- we are working with a single datatype definition. + -- + -- The information we needed was all set up for us: + -- see Note [Collecting record fields in data declarations] in GHC.Hs.Utils. + mk_fld_env :: [(Name, Maybe [Located Int])] -> IntMap FieldLabel + -> [(ConLikeName, ConInfo)] + mk_fld_env names flds = + [ (DataConName con, ConInfo (ConIsData (map fst names)) fld_info) + | (con, mb_fl_indxs) <- names + , let fld_info = case fmap (map ((flds IntMap.!) . unLoc)) mb_fl_indxs of + Nothing -> ConHasPositionalArgs + Just [] -> ConIsNullary + Just (fld:flds) -> ConHasRecordFields $ fld NE.:| flds ] + + new_assoc :: DuplicateRecordFields -> FieldSelectors -> LInstDecl GhcPs + -> RnM [GlobalRdrElt] + new_assoc _ _ (L _ (TyFamInstD {})) = return [] + -- type instances don't bind new names + + new_assoc dup_fields_ok has_sel (L _ (DataFamInstD _ d)) + = new_di dup_fields_ok has_sel Nothing d + new_assoc dup_fields_ok has_sel + (L _ (ClsInstD _ (ClsInstDecl { cid_poly_ty = inst_ty + , cid_datafam_insts = adts }))) + = do -- First, attempt to grab the name of the class from the instance. + -- This step could fail if the instance is not headed by a class, + -- such as in the following examples: + -- + -- (1) The class is headed by a bang pattern, such as in + -- `instance !Show Int` (#3811c) + -- (2) The class is headed by a type variable, such as in + -- `instance c` (#16385) + -- + -- If looking up the class name fails, then mb_cls_gre will + -- be Nothing. + mb_cls_gre <- runMaybeT $ do + -- See (1) above + L loc cls_rdr <- MaybeT $ pure $ getLHsInstDeclClass_maybe inst_ty + -- See (2) above + MaybeT $ setSrcSpan (locA loc) $ lookupGlobalOccRn_maybe SameNameSpace cls_rdr + -- Assuming the previous step succeeded, process any associated data + -- family instances. If the previous step failed, bail out. + case mb_cls_gre of + Nothing + -> pure [] + Just cls_gre + -> let cls_nm = greName cls_gre + in concatMapM (new_di dup_fields_ok has_sel (Just cls_nm) . unLoc) adts + + new_di :: DuplicateRecordFields -> FieldSelectors + -> Maybe Name -- class name + -> DataFamInstDecl GhcPs + -> RnM [GlobalRdrElt] + 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 (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' + con_gres = map (mkLocalConLikeGRE (ParentIs main_name)) fld_env + field_gres = mkLocalFieldGREs (ParentIs main_name) fld_env + -- NB: the data family name is not bound here, + -- so we don't return a GlobalRdrElt for it here! + ; return $ con_gres ++ field_gres } + + -- Add errors if a constructor has a duplicate record field. + add_dup_fld_errs :: IntMap FieldLabel + -> (Name, Maybe [Located Int]) + -> IOEnv (Env TcGblEnv TcLclEnv) () + add_dup_fld_errs all_flds (con, mb_con_flds) + | Just con_flds <- mb_con_flds + , let (_, dups) = removeDups (comparing unLoc) con_flds + = for_ dups $ \ dup_flds -> + -- Report the error at the location of the second occurrence + -- of the duplicate field. + let loc = + case dup_flds of + _ :| ( L loc _ : _) -> loc + L loc _ :| _ -> loc + dup_rdrs = fmap (nameRdrName . flSelector . (all_flds IntMap.!) . unLoc) dup_flds + in addErrAt loc $ TcRnDuplicateFieldName (RecordFieldDecl con) dup_rdrs + | otherwise + = return () + +newRecordFieldLabel :: DuplicateRecordFields -> FieldSelectors -> [Name] -> LFieldOcc GhcPs -> RnM FieldLabel +newRecordFieldLabel _ _ [] _ = error "newRecordFieldLabel: datatype has no constructors!" +newRecordFieldLabel dup_fields_ok has_sel (dc:_) (L loc (FieldOcc _ (L _ fld))) + = do { selName <- newTopSrcBinder $ L (l2l loc) $ field + ; return $ FieldLabel { flHasDuplicateRecordFields = dup_fields_ok + , flHasFieldSelector = has_sel + , flSelector = selName } } + where + fld_occ = rdrNameOcc fld + dc_fs = occNameFS $ nameOccName dc + field + -- Use an Exact RdrName as-is, to preserve the bindings + -- of an already renamer-resolved field and its use + -- sites. This is needed to correctly support record + -- selectors in Template Haskell. See Note [Binders in + -- Template Haskell] in "GHC.ThToHs" and Note [Looking up + -- Exact RdrNames] in "GHC.Rename.Env". + | isExact fld + = assertPpr (fieldOcc_maybe fld_occ == Just dc_fs) + (vcat [ text "newRecordFieldLabel: incorrect namespace for exact Name" <+> quotes (ppr fld) + , text "expected namespace:" <+> pprNameSpace (fieldName dc_fs) + , text " actual namespace:" <+> pprNameSpace (occNameSpace fld_occ) ]) + fld + + -- Field names produced by the parser are namespaced with VarName. + -- Here we namespace them according to the first constructor. + -- See Note [Record field namespacing] in GHC.Types.Name.Occurrence. + | otherwise + = mkRdrUnqual $ varToRecFieldOcc dc_fs fld_occ + +{- +Note [Looking up family names in family instances] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + + module M where + type family T a :: * + type instance M.T Int = Bool + +We might think that we can simply use 'lookupOccRn' when processing the type +instance to look up 'M.T'. Alas, we can't! The type family declaration is in +the *same* HsGroup as the type instance declaration. Hence, as we are +currently collecting the binders declared in that HsGroup, these binders will +not have been added to the global environment yet. + +Solution is simple: process the type family declarations first, extend +the environment, and then process the type instances. + + +************************************************************************ +* * +\subsection{Filtering imports} +* * +************************************************************************ + +@filterImports@ takes the @ExportEnv@ telling what the imported module makes +available, and filters it through the import spec (if any). + +Note [Dealing with imports] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +For import M( ies ), we take each AvailInfo from the mi_exports of M, and make + + imp_occ_env :: OccEnv (NameEnv ImpOccItem) + +This map contains one entry for each OccName that M exports, mapping each OccName +to the following information: + + 1. the GlobalRdrElt corresponding to the OccName, + 2. whether this GlobalRdrElt was the parent in the AvailInfo we found + the OccName in. + 3. the GlobalRdrElts that were bundled together in the AvailInfo we found + this OccName in (not including the parent), + +We need (2) and (3) during the construction of the OccEnv because of associated +types and bundled pattern synonyms, respectively. +(3) is explained in Note [Importing PatternSynonyms]. + +To explain (2), consider for example: + + module M where + class C a where { data T a } + instance C Int where { data T Int = T1 | T2 } + instance C Bool where { data T Int = T3 } + +Here, M's exports avails are (recalling the AvailTC invariant from GHC.Types.Avail) + + C(C,T), T(T,T1,T2,T3) + +Notice that T appears *twice*, once as a child and once as a parent. From +these two exports, respectively, during construction of the imp_occ_env, we begin +by associating the following two elements with the key T: + + T -> ImpOccItem { imp_item = gre1, imp_bundled = [C,T] , imp_is_parent = False } + T -> ImpOccItem { imp_item = gre2, imp_bundled = [T1,T2,T3], imp_is_parent = True } + +where `gre1`, `gre2` are two GlobalRdrElts with greName T. +We combine these (in function 'combine' in 'mkImportOccEnv') by discarding the +non-parent item, thusly: + + T -> IE_ITem { imp_item = gre1 `plusGRE` gre2, imp_bundled = [T1,T2,T3], imp_is_parent = True } + +Note the `plusGRE`: this ensures we don't drop parent information; +see Note [Preserve parent information when combining import OccEnvs]. + +So the overall imp_occ_env is: + + C -> ImpOccItem { imp_item = C, imp_bundled = [T ], imp_is_parent = True } + T -> ImpOccItem { imp_item = T , imp_bundled = [T1,T2,T3], imp_is_parent = True } + T1 -> ImpOccItem { imp_item = T1, imp_bundled = [T1,T2,T3], imp_is_parent = False } + -- similarly for T2, T3 + +Note that the imp_occ_env will have entries for data constructors too, +although we never look up data constructors. + +Note [Importing PatternSynonyms] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +As described in Note [Dealing with imports], associated types can lead to the +same Name appearing twice, both as a child and once as a parent, when +constructing the imp_occ_env. The same thing can happen with pattern synonyms +if they are exported bundled with a type. + +A simplified example, based on #11959: + + {-# LANGUAGE PatternSynonyms #-} + module M (T(P), pattern P) where -- Duplicate export warning, but allowed + data T = MkT + pattern P = MkT + +Here we have T(P) and P in export_avails, and respectively construct both + + P -> ImpOccItem { imp_item = P, imp_bundled = [P], imp_is_parent = False } + P -> ImpOccItem { imp_item = P, imp_bundled = [] , imp_is_parent = False } + +We combine these by dropping the one with no siblings, leaving us with: + + P -> ImpOccItem { imp_item = P, imp_bundled = [P], imp_is_parent = False } + +That is, we simply discard the non-bundled Avail. + +Note [Importing DuplicateRecordFields] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In filterImports, another complicating factor is DuplicateRecordFields. +Suppose we have: + + {-# LANGUAGE DuplicateRecordFields #-} + module M (S(foo), T(foo)) where + data S = MkS { foo :: Int } + data T = MkT { foo :: Int } + + module N where + import M (foo) -- this is allowed (A) + import M (S(foo)) -- this is allowed (B) + +Here M exports 'foo' at two different OccNames, with different namespaces for +the two construtors MkS and MkT. Then, when we look up 'foo' in lookup_names +for case (A), we have a variable foo but must look in all the record field +namespaces to find the two fields (and hence two different Avails). +Whereas in case (B) we reach the lookup_ie case for IEThingWith, +which looks up 'S' and then finds the unique 'foo' amongst its children. + +See T16745 for a test of this. + +Note [Preserve parent information when combining import OccEnvs] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When discarding one ImpOccItem in favour of another, as described in +Note [Dealing with imports], we must make sure to combine the GREs so that +we don't lose information. + +Consider for example #24084: + + module M1 where { class C a where { type T a } } + module M2 ( module M1 ) where { import M1 } + module M3 where { import M2 ( C, T ); instance C () where T () = () } + +When processing the import list of `M3`, we will have two `Avail`s attached +to `T`, namely `C(C, T)` and `T(T)`. We combine them in the `combine` function +of `mkImportOccEnv`; as described in Note [Dealing with imports] we discard +`C(C, T)` in favour of `T(T)`. However, in doing so, we **must not** +discard the information want that `C` is the parent of `T`. Indeed, +losing track of this information can cause errors when importing, +as we could get an error of the form + + ‘T’ is not a (visible) associated type of class ‘C’ + +This explains why we use `plusGRE` when combining the two ImpOccItems, even +though we are discarding one in favour of the other. +-} + +-- | All the 'GlobalRdrElt's associated with an 'AvailInfo'. +gresFromAvail :: HasDebugCallStack + => HscEnv -> Maybe ImportSpec -> AvailInfo -> [GlobalRdrElt] +gresFromAvail hsc_env prov avail = + [ mk_gre nm info + | nm <- availNames avail + , let info = lookupGREInfo hsc_env nm ] + where + + mk_gre n info + = case prov of + -- Nothing => bound locally + -- Just is => imported from 'is' + Nothing -> GRE { gre_name = n, gre_par = mkParent n avail + , gre_lcl = True, gre_imp = emptyBag + , gre_info = info } + Just is -> GRE { gre_name = n, gre_par = mkParent n avail + , gre_lcl = False, gre_imp = unitBag is + , gre_info = info } + +-- | All the 'GlobalRdrElt's associated with a collection of 'AvailInfo's. +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, LocatedLI [LIE GhcPs]) + -- ^ Whether this is a "hiding" import list + -> 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, 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 + + let items2 :: [(LIE GhcRn, [GlobalRdrElt])] + items2 = concat items1 + -- NB we may have duplicates, and several items + -- for the same parent; e.g N(x) and N(y) + + (gres, imp_user_list) = case want_hiding of + Exactly -> + let gres = concatMap (gresFromIE decl_spec) items2 + gre_env = mkGlobalRdrEnv gres + implicit_parents = mkNameSet $ mapMaybe parentOfImplicitlyImportedGRE gres + in (gre_env, ImpUserExplicit (gresToAvailInfo $ globalRdrEnvElts $ gre_env) implicit_parents) + EverythingBut -> + let hidden_names = mkNameSet $ concatMap (map greName . snd) items2 + in (importsFromIface hsc_env iface decl_spec (Just hidden_names), ImpUserEverythingBut hidden_names) + + return (Just (want_hiding, L l (map fst items2)), imp_user_list, gres) + where + import_mod = mi_module iface + all_avails = mi_exports iface + imp_occ_env = mkImportOccEnv hsc_env decl_spec all_avails + + -- Look up a parent (type constructor, class or data constructor) + -- in an import. + lookup_parent :: IE GhcPs -> RdrName -> IELookupM ImpOccItem + lookup_parent ie rdr = + assertPpr (not $ isVarNameSpace ns) + (vcat [ text "filterImports lookup_parent: unexpected variable" + , text "rdr:" <+> ppr rdr + , text "namespace:" <+> pprNameSpace ns ]) $ + do { xs <- lookup_names ie rdr + ; case xs of + cax :| [] -> return cax + _ -> pprPanic "filter_imports lookup_parent ambiguous" $ + vcat [ text "rdr:" <+> ppr rdr + , text "lookups:" <+> ppr (fmap imp_item xs) ] } + -- Looking up non-variables is always unambiguous, + -- as there can be at most one corresponding item + -- in the imp_occ_env. + -- See item (1) of Note [Exporting duplicate declarations] + -- in GHC.Tc.Gen.Export. + where + occ = rdrNameOcc rdr + ns = occNameSpace occ + + -- Look up a RdrName used in an import, returning multiple values if there + -- are several fields with the same name exposed by the module + lookup_names :: IE GhcPs -> RdrName -> IELookupM (NonEmpty ImpOccItem) + lookup_names ie rdr + | isQual rdr + = failLookupWith (QualImportError rdr) + | otherwise + = case lookups of + [] -> failLookupWith (BadImport ie IsNotSubordinate) + item:items -> return $ item :| items + where + lookups = concatMap nonDetNameEnvElts + $ lookupImpOccEnv (RelevantGREsFOS WantNormal) imp_occ_env (rdrNameOcc rdr) + + lookup_lie :: LIE GhcPs -> TcRn [(LIE GhcRn, [GlobalRdrElt])] + lookup_lie (L loc ieRdr) + = setSrcSpanA loc $ + do (stuff, warns) <- run_lookup ([],[]) (lookup_ie ieRdr) + mapM_ (addTcRnDiagnostic <=< warning_msg) warns + return [ (L loc ie, gres) | (ie,gres) <- stuff ] + where + + -- Warn when importing T(..) and no children are brought in scope + warning_msg (DodgyImport n) = + pure (TcRnDodgyImports (DodgyImportsEmptyParent n)) + warning_msg MissingImportList = + pure (TcRnMissingImportList ieRdr) + 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 + PragmaWarningExport + { pwarn_occname = occName n + , pwarn_impmod = moduleName import_mod } + w + + run_lookup :: a -> IELookupM a -> TcRn a + run_lookup def m = case m of + Failed err -> do + msgs <- lookup_err_msgs err + forM_ msgs $ \msg -> addErr (TcRnImportLookup msg) + return def + Succeeded a -> return a + + lookup_err_msgs err = case err of + BadImport ie sub -> badImportItemErr iface decl_spec ie sub all_avails + 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 + -- to what is actually imported by this item. + -- Returns Nothing on error. + -- + -- Returns a list because, with DuplicateRecordFields, a naked + -- import/export of a record field can correspond to multiple + -- different GlobalRdrElts. See Note [Importing DuplicateRecordFields]. + lookup_ie :: IE GhcPs + -> IELookupM ([(IE GhcRn, [GlobalRdrElt])], [IELookupWarning]) + lookup_ie ie = handle_bad_import $ + case ie of + IEVar _ (L l n) _ -> do + -- See Note [Importing DuplicateRecordFields] + xs <- lookup_names ie (ieWrappedName n) + let gres = map imp_item $ NE.toList xs + export_depr_warns + | want_hiding == Exactly + = mapMaybe mk_depr_export_warning gres + | otherwise = [] + 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 { 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 + -- e.g. f(..) or T(..) where T is a type synonym + = [DodgyImport gre] + + -- e.g. import M( T(..) ) + | not (is_qual decl_spec) + = [MissingImportList] + + | otherwise + = [] + + renamed_ie = IEThingAll (Nothing, noAnn) (L l (replaceWrappedName tc name)) noDocstring + export_depr_warn + | want_hiding == Exactly + = maybeToList $ mk_depr_export_warning gre + -- We don't want to warn about the children as they + -- are not explicitly mentioned; the warning will + -- be emitted later on if they are used + | otherwise = [] + + return ( [(renamed_ie, gre:child_gres)] + , imp_list_warn ++ export_depr_warn) + + + IEThingAbs _ (L l tc') _ + | want_hiding == EverythingBut -- hiding ( C ) + -- Here the 'C' can be a data constructor + -- *or* a type/class, or even both + -> let tc = ieWrappedName tc' + tc_name = lookup_parent ie tc + dc_name = lookup_parent ie (setRdrNameSpace tc srcDataName) + in + case catIELookupM [ tc_name, dc_name ] of + [] -> failLookupWith (BadImport ie IsNotSubordinate) + names -> return ( [mkIEThingAbs tc' l (imp_item name) | name <- names], []) + | otherwise + -> do ImpOccItem { imp_item = gre } <- lookup_parent ie (ieWrappedName tc') + return ( [mkIEThingAbs tc' l gre] + , maybeToList $ mk_depr_export_warning gre) + + IEThingWith (deprecation, ann) ltc@(L l rdr_tc) wc rdr_ns _ -> do + ImpOccItem { imp_item = gre, imp_bundled = subnames } + <- 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] + let (children_errs, childnames) = lookupChildren subnames rdr_ns + + 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 + + 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... + -- all of those constitute errors. + + where + mkIEThingAbs tc l gre + = (IEThingAbs Nothing (L l (replaceWrappedName tc n)) noDocstring, [gre]) + where n = greName gre + + -- 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 iface name + where + name = greName gre + +type IELookupM = MaybeErr IELookupError + +data IELookupWarning + = BadImportW (IE GhcPs) IsSubordinateError + | MissingImportList + | DodgyImport GlobalRdrElt + | DeprecatedExport Name (WarningTxt GhcRn) + +-- | Is this import/export item a subordinate or not? +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) IsSubordinateError + | IllegalImport + +failLookupWith :: IELookupError -> IELookupM a +failLookupWith err = Failed err + +catchIELookup :: IELookupM a -> (IELookupError -> IELookupM a) -> IELookupM a +catchIELookup m h = case m of + Succeeded r -> return r + Failed err -> h err + +catIELookupM :: [IELookupM a] -> [a] +catIELookupM ms = [ a | Succeeded a <- ms ] + +-- | Information associated to an 'AvailInfo' used in constructing +-- an 'OccEnv' corresponding to imports. +-- +-- See Note [Dealing with imports]. +data ImpOccItem + = ImpOccItem + { imp_item :: GlobalRdrElt + -- ^ The import item + , imp_bundled :: [GlobalRdrElt] + -- ^ Items bundled in the Avail this import item came from, + -- not including the import item itself if it is a parent. + , imp_is_parent :: Bool + -- ^ Is the import item a parent? See Note [Dealing with imports]. + } + +instance Outputable ImpOccItem where + ppr (ImpOccItem { imp_item = item, imp_bundled = bundled, imp_is_parent = is_par }) + = braces $ hsep + [ text "ImpOccItem" + , if is_par then text "[is_par]" else empty + , ppr (greName item) <+> ppr (greParent item) + , braces $ text "bundled:" <+> ppr (map greName bundled) ] + +-- | Make an 'OccEnv' of all the imports. +-- +-- Complicated by the fact that associated data types and pattern synonyms +-- can appear twice. See Note [Dealing with imports]. +mkImportOccEnv :: HscEnv -> ImpDeclSpec -> [IfaceExport] -> OccEnv (NameEnv ImpOccItem) +mkImportOccEnv hsc_env decl_spec all_avails = + mkOccEnv_C (plusNameEnv_C combine) + [ (occ, mkNameEnv [(nm, item)]) + | avail <- all_avails + , 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 _ + | 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 + + hiding_spec = ImpSpec { is_decl = decl_spec, is_item = ImpAll } + + -- See Note [Dealing with imports] + -- 'combine' may be called for associated data types which appear + -- twice in the all_avails. In the example, we have two Avails for T, + -- namely T(T,T1,T2,T3) and C(C,T), and we combine them by dropping the + -- latter, in which T is not the parent. + combine :: ImpOccItem -> ImpOccItem -> ImpOccItem + combine item1@(ImpOccItem { imp_item = gre1, imp_is_parent = is_parent1 }) + item2@(ImpOccItem { imp_item = gre2, imp_is_parent = is_parent2 }) + | is_parent1 || is_parent2 + , not (isRecFldGRE gre1 || isRecFldGRE gre2) -- NB: does not force GREInfo. + , let name1 = greName gre1 + name2 = greName gre2 + gre = gre1 `plusGRE` gre2 + -- See Note [Preserve parent information when combining import OccEnvs] + = assertPpr (name1 == name2) + (ppr name1 <+> ppr name2) $ + if is_parent1 + then item1 { imp_item = gre } + else item2 { imp_item = gre } + -- Discard C(C,T) in favour of T(T, T1, T2, T3). + + -- 'combine' may also be called for pattern synonyms which appear both + -- unassociated and associated (see Note [Importing PatternSynonyms]). + combine item1@(ImpOccItem { imp_item = c1, imp_bundled = kids1 }) + item2@(ImpOccItem { imp_item = c2, imp_bundled = kids2 }) + = assertPpr (greName c1 == greName c2 + && (not (null kids1 && null kids2))) + (ppr c1 <+> ppr c2 <+> ppr kids1 <+> ppr kids2) $ + if null kids1 + then item2 + else item1 + -- Discard standalone pattern P in favour of T(P). + +-- | Essentially like @lookupGRE env (LookupOccName occ which_gres)@, +-- but working with 'ImpOccItem's instead of 'GlobalRdrElt's. +lookupImpOccEnv :: WhichGREs GREInfo + -> OccEnv (NameEnv ImpOccItem) -> OccName -> [NameEnv ImpOccItem] +lookupImpOccEnv which_gres env occ = + mapMaybe relevant_items $ lookupOccEnv_AllNameSpaces env occ + where + is_relevant :: ImpOccItem -> Bool + is_relevant (ImpOccItem { imp_item = gre }) = + greIsRelevant which_gres (occNameSpace occ) gre + relevant_items :: NameEnv ImpOccItem -> Maybe (NameEnv ImpOccItem) + relevant_items nms + | let nms' = filterNameEnv is_relevant nms + = if isEmptyNameEnv nms' + then Nothing + else Just nms' + +{- +************************************************************************ +* * +\subsection{Import/Export Utils} +* * +************************************************************************ +-} + +-- | Given an import\/export spec, appropriately set the @gre_imp@ field +-- for the 'GlobalRdrElt's. +gresFromIE :: ImpDeclSpec -> (LIE GhcRn, [GlobalRdrElt]) -> [GlobalRdrElt] +gresFromIE decl_spec (L loc ie, gres) + = map set_gre_imp gres + where + is_explicit = case ie of + IEThingAll _ name _ -> \n -> n == lieWrappedName name + _ -> \_ -> True + prov_fn name + = ImpSpec { is_decl = decl_spec, is_item = item_spec } + where + item_spec = ImpSome { is_explicit = is_explicit name + , is_iloc = locA loc } + set_gre_imp gre@( GRE { gre_name = nm } ) + = gre { gre_imp = unitBag $ prov_fn nm } + +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 #-} + module M (F(foo, MkFInt, MkFBool)) where + data family F a + data instance F Int = MkFInt { foo :: Int } + data instance F Bool = MkFBool { foo :: Bool } + +The `foo` in the export list refers to *both* selectors! For this +reason, lookupChildren builds an environment that maps the FastString +to a list of items, rather than a single item. +-} + +mkChildEnv :: [GlobalRdrElt] -> NameEnv [GlobalRdrElt] +mkChildEnv gres = foldr add emptyNameEnv gres + where + add gre env = case greParent gre of + ParentIs p -> extendNameEnv_Acc (:) Utils.singleton env p gre + NoParent -> env + +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] + -> ( [LookupChildError] -- The ones for which the lookup failed + , [LocatedA GlobalRdrElt] ) +-- (lookupChildren all_kids rdr_items) maps each rdr_item to its +-- 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 = (fails, successes) + where + mb_xs = map do_one rdr_items + fails = [ err | Failed err <- mb_xs ] + successes = [ ok | Succeeded oks <- mb_xs, ok <- NE.toList oks ] + + 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. +-} + +------------------------------- + +{- +********************************************************* +* * +\subsection{Unused names} +* * +********************************************************* +-} + +reportUnusedNames :: TcGblEnv -> HscSource -> RnM () +reportUnusedNames gbl_env hsc_src + = do { keep <- readTcRef (tcg_keep gbl_env) + ; traceRn "RUN" (ppr (tcg_dus gbl_env)) + ; warnUnusedImportDecls gbl_env hsc_src + ; warnUnusedTopBinds $ unused_locals keep + ; warnMissingSignatures gbl_env + ; warnMissingKindSignatures gbl_env } + where + used_names :: NameSet -> NameSet + used_names keep = findUses (tcg_dus gbl_env) emptyNameSet `unionNameSet` keep + -- NB: currently, if f x = g, we only treat 'g' as used if 'f' is used + -- Hence findUses + + -- Collect the defined names from the in-scope environment + defined_names :: [GlobalRdrElt] + defined_names = globalRdrEnvElts (tcg_rdr_env gbl_env) + + kids_env = mkChildEnv defined_names + -- This is done in mkExports too; duplicated work + + gre_is_used :: NameSet -> GlobalRdrElt -> Bool + gre_is_used used_names gre0 + = name `elemNameSet` used_names + || any (\ gre -> greName gre `elemNameSet` used_names) (findChildren kids_env name) + -- A use of C implies a use of T, + -- if C was brought into scope by T(..) or T(C) + where + name = greName gre0 + + -- Filter out the ones that are + -- (a) defined in this module, and + -- (b) not defined by a 'deriving' clause + -- The latter have an Internal Name, so we can filter them out easily + unused_locals :: NameSet -> [GlobalRdrElt] + unused_locals keep = + let -- Note that defined_and_used, defined_but_not_used + -- are both [GRE]; that's why we need defined_and_used + -- rather than just used_names + _defined_and_used, defined_but_not_used :: [GlobalRdrElt] + (_defined_and_used, defined_but_not_used) + = partition (gre_is_used (used_names keep)) defined_names + + in filter is_unused_local defined_but_not_used + is_unused_local :: GlobalRdrElt -> Bool + is_unused_local gre = isLocalGRE gre + && isExternalName (greName gre) + +{- ********************************************************************* +* * + Missing signatures +* * +********************************************************************* -} + +{- +Note [Missing signatures] +~~~~~~~~~~~~~~~~~~~~~~~~~ +There are four warning flags in play: + + * -Wmissing-exported-signatures + Warn about any exported top-level function/value without a type signature. + Does not include pattern synonyms. + + * -Wmissing-signatures + Warn about any top-level function/value without a type signature. Does not + include pattern synonyms. Takes priority over -Wmissing-exported-signatures. + + * -Wmissing-exported-pattern-synonym-signatures + Warn about any exported pattern synonym without a type signature. + + * -Wmissing-pattern-synonym-signatures + Warn about any pattern synonym without a type signature. Takes priority over + -Wmissing-exported-pattern-synonym-signatures. + +-} + +-- | Warn the user about top level binders that lack type signatures. +-- Called /after/ type inference, so that we can report the +-- inferred type of the function +warnMissingSignatures :: TcGblEnv -> RnM () +warnMissingSignatures gbl_env + = do { let exports = availsToNameSet (tcg_exports gbl_env) + sig_ns = tcg_sigs gbl_env + -- We use sig_ns to exclude top-level bindings that are generated by GHC + binds = collectHsBindsBinders CollNoDictBinders $ tcg_binds gbl_env + pat_syns = tcg_patsyns gbl_env + + not_ghc_generated :: Name -> Bool + not_ghc_generated name = name `elemNameSet` sig_ns + + add_binding_warn :: Id -> RnM () + add_binding_warn id = + when (not_ghc_generated name) $ + do { env <- liftZonkM $ tcInitTidyEnv -- Why not use emptyTidyEnv? + ; let ty = tidyOpenType env (idType id) + missing = MissingTopLevelBindingSig name ty + diag = TcRnMissingSignature missing exported + ; addDiagnosticAt (getSrcSpan name) diag } + where + name = idName id + exported = if name `elemNameSet` exports + then IsExported + else IsNotExported + + add_patsyn_warn :: PatSyn -> RnM () + add_patsyn_warn ps = + when (not_ghc_generated name) $ + addDiagnosticAt (getSrcSpan name) + (TcRnMissingSignature missing exported) + where + name = patSynName ps + missing = MissingPatSynSig ps + exported = if name `elemNameSet` exports + then IsExported + else IsNotExported + + -- Warn about missing signatures + -- Do this only when we have a type to offer + -- See Note [Missing signatures] + ; mapM_ add_binding_warn binds + ; mapM_ add_patsyn_warn pat_syns + } + +-- | Warn the user about tycons that lack kind signatures. +-- Called /after/ type (and kind) inference, so that we can report the +-- inferred kinds. +warnMissingKindSignatures :: TcGblEnv -> RnM () +warnMissingKindSignatures gbl_env + = do { cusks_enabled <- xoptM LangExt.CUSKs + ; mapM_ (add_ty_warn cusks_enabled) tcs + } + where + tcs = tcg_tcs gbl_env + ksig_ns = tcg_ksigs gbl_env + exports = availsToNameSet (tcg_exports gbl_env) + + has_kind_signature :: Name -> Bool + has_kind_signature name = name `elemNameSet` ksig_ns + + add_ty_warn :: Bool -> TyCon -> RnM () + add_ty_warn cusks_enabled tyCon = + when (has_kind_signature name) $ + addDiagnosticAt (getSrcSpan name) diag + where + name = tyConName tyCon + diag = TcRnMissingSignature missing exported + missing = MissingTyConKindSig tyCon cusks_enabled + exported = if name `elemNameSet` exports + then IsExported + else IsNotExported + +{- +********************************************************* +* * +\subsection{Unused imports} +* * +********************************************************* + +This code finds which import declarations are unused. The +specification and implementation notes are here: + https://gitlab.haskell.org/ghc/ghc/wikis/commentary/compiler/unused-imports + +See also Note [Choosing the best import declaration] in GHC.Types.Name.Reader +-} + +type ImportDeclUsage + = ( LImportDecl GhcRn -- The import declaration + , [GlobalRdrElt] -- What *is* used (normalised) + , [Name] ) -- What is imported but *not* used + +warnUnusedImportDecls :: TcGblEnv -> HscSource -> RnM () +warnUnusedImportDecls gbl_env hsc_src + = do { uses <- readMutVar (tcg_used_gres gbl_env) + ; let user_imports = filterOut + (ideclImplicit . ideclExt . unLoc) + (tcg_rn_imports gbl_env) + -- This whole function deals only with *user* imports + -- both for warning about unnecessary ones, and for + -- deciding the minimal ones + rdr_env = tcg_rdr_env gbl_env + + ; let usage :: [ImportDeclUsage] + usage = findImportUsage user_imports uses + + ; traceRn "warnUnusedImportDecls" $ + (vcat [ text "Uses:" <+> ppr uses + , text "Import usage" <+> ppr usage]) + + ; mapM_ (warnUnusedImport rdr_env) usage + + ; whenGOptM Opt_D_dump_minimal_imports $ + printMinimalImports hsc_src usage } + +findImportUsage :: [LImportDecl GhcRn] + -> [GlobalRdrElt] + -> [ImportDeclUsage] + +findImportUsage imports used_gres + = map unused_decl imports + where + import_usage :: ImportMap + import_usage = mkImportMap used_gres + + unused_decl :: LImportDecl GhcRn -> (LImportDecl GhcRn, [GlobalRdrElt], [Name]) + unused_decl decl@(L loc (ImportDecl { ideclImportList = imps })) + = (decl, used_gres, nameSetElemsStable unused_imps) + where + used_gres = lookupSrcLoc (srcSpanEnd $ locA loc) import_usage + -- srcSpanEnd: see Note [The ImportMap] + `orElse` [] + + 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) -> + 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 -> 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 + NoIEWildcard -> id + IEWildcard _ -> add_unused_all pn + add_unused _ acc = acc + + add_unused_name :: Name -> Bool -> UnusedNames -> UnusedNames + add_unused_name n is_ie_var acc@(UnusedNames acc_ns acc_fs) + | is_ie_var + , isFieldName n + -- See Note [Reporting unused imported duplicate record fields] + = let + fs = getOccFS n + (flds, flds_used) = lookupFsEnv acc_fs fs `orElse` (emptyNameSet, Any False) + acc_fs' = extendFsEnv acc_fs fs (extendNameSet flds n, Any used S.<> flds_used) + in UnusedNames acc_ns acc_fs' + | used + = acc + | otherwise + = UnusedNames (acc_ns `extendNameSet` n) acc_fs + where + used = isJust $ lookupGRE_Name used_gre_env n + + add_unused_all :: Name -> UnusedNames -> UnusedNames + add_unused_all n (UnusedNames acc_ns acc_fs) + | Just {} <- lookupGRE_Name used_gre_env n = UnusedNames acc_ns acc_fs + | n `elemNameSet` used_parents = UnusedNames acc_ns acc_fs + | otherwise = UnusedNames (acc_ns `extendNameSet` n) acc_fs + + add_unused_with :: Name -> [Name] -> UnusedNames -> UnusedNames + add_unused_with p ns acc + | all (`elemNameSet` acc1_ns) ns = add_unused_name p False acc1 + | otherwise = acc1 + where + acc1@(UnusedNames acc1_ns _acc1_fs) = foldr (\n acc' -> add_unused_name n False acc') acc ns + -- If you use 'signum' from Num, then the user may well have + -- imported Num(signum). We don't want to complain that + -- Num is not itself mentioned. Hence the two cases in add_unused_with. + + +-- | An accumulator for unused names in an import list. +-- +-- See Note [Reporting unused imported duplicate record fields]. +data UnusedNames = + UnusedNames + { unused_names :: NameSet + -- ^ Unused 'Name's in an import list, not including record fields + -- that are plain 'IEVar' imports + , rec_fld_uses :: FastStringEnv (NameSet, Any) + -- ^ Record fields imported without a parent (i.e. an 'IEVar' import). + -- + -- The 'Any' value records whether any of the record fields + -- sharing the same underlying 'FastString' have been used. + } +instance Outputable UnusedNames where + ppr (UnusedNames nms flds) = + text "UnusedNames" <+> + braces (ppr nms <+> ppr (fmap (second getAny) flds)) + +-- | Collect all unused names from a 'UnusedNames' value. +collectUnusedNames :: UnusedNames -> NameSet +collectUnusedNames (UnusedNames { unused_names = nms, rec_fld_uses = flds }) + = nms S.<> unused_flds + where + unused_flds = nonDetFoldFsEnv collect_unused emptyNameSet flds + collect_unused :: (NameSet, Any) -> NameSet -> NameSet + collect_unused (nms, Any at_least_one_name_is_used) acc + | at_least_one_name_is_used = acc + | otherwise = unionNameSet nms acc + +{- Note [Reporting unused imported duplicate record fields] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we have (#24035): + + {-# LANGUAGE DuplicateRecordFields #-} + module M1 (R1(..), R2(..)) where + data R1 = MkR1 { fld :: Int } + data R2 = MkR2 { fld :: Int } + + {-# LANGUAGE DuplicateRecordFields #-} + module M2 where + import M1 (R1(MkR1), R2, fld) + f :: R1 -> Int + f (MkR1 { fld = x }) = x + g :: R2 -> Int + g _ = 3 + +In the import of 'M1' in 'M2', the 'fld' import resolves to two separate GREs, +namely R1(fld) and R2(fld). From the perspective of the renamer, and in particular +the 'findImportUsage' function, it's as if the user had imported the two names +separately (even though no source syntax allows that). + +This means that we need to be careful when reporting unused imports: the R2(fld) +import is indeed unused, but because R1(fld) is used, we should not report +fld as unused altogether. + +To achieve this, we keep track of record field imports without a parent (i.e. +using the IEVar constructor) separately from other import items, using the +UnusedNames datatype. +Once we have accumulated usages, we emit warnings for unused record fields +without parents one whole group (of record fields sharing the same textual name) +at a time, and only if *all* of the record fields in the group are unused; +see 'collectUnusedNames'. + +Note that this only applies to record fields imported without a parent. If we +had: + + import M1 (R1(MkR1, fld), R2(fld)) + f :: R1 -> Int + f (MkR1 { fld = x }) = x + g :: R2 -> Int + g _ = 3 + +then of course we should report the second 'fld' as unused. +-} + + +{- Note [The ImportMap] +~~~~~~~~~~~~~~~~~~~~~~~ +The ImportMap is a short-lived intermediate data structure records, for +each import declaration, what stuff brought into scope by that +declaration is actually used in the module. + +The SrcLoc is the location of the END of a particular 'import' +declaration. Why *END*? Because we don't want to get confused +by the implicit Prelude import. Consider (#7476) the module + import Foo( foo ) + main = print foo +There is an implicit 'import Prelude(print)', and it gets a SrcSpan +of line 1:1 (just the point, not a span). If we use the *START* of +the SrcSpan to identify the import decl, we'll confuse the implicit +import Prelude with the explicit 'import Foo'. So we use the END. +It's just a cheap hack; we could equally well use the Span too. + +The [GlobalRdrElt] are the things imported from that decl. +-} + +type ImportMap = Map RealSrcLoc [GlobalRdrElt] -- See [The ImportMap] + -- If loc :-> gres, then + -- 'loc' = the end loc of the bestImport of each GRE in 'gres' + +mkImportMap :: [GlobalRdrElt] -> ImportMap +-- For each of a list of used GREs, find all the import decls that brought +-- it into scope; choose one of them (bestImport), and record +-- the RdrName in that import decl's entry in the ImportMap +mkImportMap gres + = foldr add_one Map.empty gres + where + add_one gre@(GRE { gre_imp = imp_specs }) imp_map = + case srcSpanEnd (is_dloc (is_decl best_imp_spec)) of + -- For srcSpanEnd see Note [The ImportMap] + RealSrcLoc decl_loc _ -> Map.insertWith add decl_loc [gre] imp_map + UnhelpfulLoc _ -> imp_map + where + best_imp_spec = + case bagToList imp_specs of + [] -> pprPanic "mkImportMap: GRE with no ImportSpecs" (ppr gre) + is:iss -> bestImport (is NE.:| iss) + add _ gres = gre : gres + +warnUnusedImport :: GlobalRdrEnv -> ImportDeclUsage -> RnM () +warnUnusedImport rdr_env (L loc decl, used, unused) + + -- Do not warn for 'import M()' + | Just (Exactly, L _ []) <- ideclImportList decl + = return () + + -- Note [Do not warn about Prelude hiding] + | Just (EverythingBut, L _ hides) <- ideclImportList decl + , not (null hides) + , pRELUDE_NAME == unLoc (ideclName decl) + = return () + + -- Nothing used; drop entire declaration + | null used + = addDiagnosticAt (locA loc) (TcRnUnusedImport decl UnusedImportNone) + + -- Everything imported is used; nop + | null unused + = return () + + -- Some imports are unused: make the `SrcSpan` cover only the unused + -- items instead of the whole import statement + | Just (_, L _ imports) <- ideclImportList decl + , let unused_locs = [ locA loc | L loc ie <- imports + , name <- ieNames ie + , name `elem` unused ] + , loc1 : locs <- unused_locs + , let span = foldr1 combineSrcSpans ( loc1 NE.:| locs ) + = addDiagnosticAt span (TcRnUnusedImport decl (UnusedImportSome sort_unused)) + + -- Some imports are unused + | otherwise + = addDiagnosticAt (locA loc) (TcRnUnusedImport decl (UnusedImportSome sort_unused)) + + where + -- In warning message, pretty-print identifiers unqualified unconditionally + -- to improve the consistent for ambiguous/unambiguous identifiers. + -- See #14881. + possible_field n = + case lookupGRE_Name rdr_env n of + Just (GRE { gre_par = par, gre_info = IAmRecField info }) -> + let fld_occ :: OccName + fld_occ = nameOccName $ flSelector $ recFieldLabel info + in UnusedImportNameRecField par fld_occ + _ -> UnusedImportNameRegular n + + -- Print unused names in a deterministic (lexicographic) order + sort_unused :: [UnusedImportName] + sort_unused = fmap possible_field $ + sortBy (comparing nameOccName) unused + +{- +Note [Do not warn about Prelude hiding] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We do not warn about + import Prelude hiding( x, y ) +because even if nothing else from Prelude is used, it may be essential to hide +x,y to avoid name-shadowing warnings. Example (#9061) + import Prelude hiding( log ) + f x = log where log = () + + + +Note [Printing minimal imports] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +To print the minimal imports we walk over the user-supplied import +decls, and simply trim their import lists. NB that + + * We do *not* change the 'qualified' or 'as' parts! + + * We do not discard a decl altogether; we might need instances + from it. Instead we just trim to an empty import list +-} + +getMinimalImports :: [ImportDeclUsage] -> RnM [LImportDecl GhcRn] +getMinimalImports ie_decls + = do { rdr_env <- getGlobalRdrEnv + ; fmap combine $ mapM (mk_minimal rdr_env) ie_decls } + where + mk_minimal rdr_env (L l decl, used_gres, unused) + | null unused + , Just (Exactly, _) <- ideclImportList decl + = return (L l decl) + | otherwise + = do { let ImportDecl { ideclName = L _ mod_name + , ideclSource = is_boot + , ideclPkgQual = pkg_qual } = decl + ; iface <- loadSrcInterface doc mod_name is_boot pkg_qual + ; let used_avails = gresToAvailInfo used_gres + ; lies <- map (L l) <$> concatMapM (to_ie rdr_env iface) used_avails + ; return (L l (decl { ideclImportList = Just (Exactly, L (l2l l) lies) })) } + where + doc = text "Compute minimal imports for" <+> ppr decl + + to_ie :: GlobalRdrEnv -> ModIface -> AvailInfo -> RnM [IE GhcRn] + -- The main trick here is that if we're importing all the constructors + -- we want to say "T(..)", but if we're importing only a subset we want + -- 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 $ 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 (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 + , availExportsDecl avail -- Note [Partial export] + ] of + [xs] + | all_used xs + -> return [IEThingAll (Nothing, noAnn) (to_ie_post_rn $ noLocA n) Nothing] + | otherwise + -> do { let ns_gres = map (expectJust . lookupGRE_Name rdr_env) cs + ns = map greName ns_gres + ; return [IEThingWith (Nothing, noAnn) (to_ie_post_rn $ noLocA n) NoIEWildcard + (map (to_ie_post_rn . noLocA) (filter (/= n) ns)) Nothing] } + -- Note [Overloaded field import] + _other + -> do { let infos = map (expectJust . 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 (\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)) Nothing] } + where + + all_used avail_cs = all (`elem` cs) avail_cs + + all_non_overloaded = all (not . flIsOverloaded . recFieldLabel) + + combine :: [LImportDecl GhcRn] -> [LImportDecl GhcRn] + combine = map merge . NE.groupAllWith getKey + + getKey :: LImportDecl GhcRn -> (Bool, Maybe ModuleName, ModuleName) + getKey decl = + ( isImportDeclQualified . ideclQualified $ idecl -- is this qualified? (important that this be first) + , unLoc <$> ideclAs idecl -- what is the qualifier (inside Maybe monad) + , unLoc . ideclName $ idecl -- Module Name + ) + where + idecl :: ImportDecl GhcRn + idecl = unLoc decl + + merge :: NonEmpty (LImportDecl GhcRn) -> LImportDecl GhcRn + merge decls@((L l decl) :| _) = L l (decl { ideclImportList = Just (Exactly, L (noAnnSrcSpan (locA l)) lies) }) + where lies = concatMap (unLoc . snd) $ mapMaybe (ideclImportList . unLoc) $ NE.toList decls + +classifyGREs :: [GlobalRdrElt] -> ([GlobalRdrElt], [FieldGlobalRdrElt]) +classifyGREs = partition (not . isRecFldGRE) + +printMinimalImports :: HscSource -> [ImportDeclUsage] -> RnM () +-- See Note [Printing minimal imports] +printMinimalImports hsc_src imports_w_usage + = do { imports' <- getMinimalImports imports_w_usage + ; this_mod <- getModule + ; dflags <- getDynFlags + ; liftIO $ withFile (mkFilename dflags this_mod) WriteMode $ \h -> + printForUser dflags h neverQualify AllTheWay (vcat (map ppr imports')) + -- The neverQualify is important. We are printing Names + -- but they are in the context of an 'import' decl, and + -- we never qualify things inside there + -- E.g. import Blag( f, b ) + -- not import Blag( Blag.f, Blag.g )! + } + where + mkFilename dflags this_mod + | Just d <- dumpDir dflags = d basefn + | otherwise = basefn + where + suffix = case hsc_src of + HsBootFile -> ".imports-boot" + HsSrcFile -> ".imports" + HsigFile -> ".imports" + basefn = moduleNameString (moduleName this_mod) ++ suffix + + +to_ie_post_rn_var :: LocatedA (IdP GhcRn) -> LIEWrappedName GhcRn +to_ie_post_rn_var (L 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 noAnn (L (l2l l) n)) + | otherwise = L l (IEName noExtField (L (l2l l) n)) + where occ = occName n + +{- +Note [Partial export] +~~~~~~~~~~~~~~~~~~~~~ +Suppose we have + + module A( op ) where + class C a where + op :: a -> a + + module B where + import A + f = ..op... + +Then the minimal import for module B is + import A( op ) +not + import A( C( op ) ) +which we would usually generate if C was exported from B. Hence +the availExportsDecl test when deciding what to generate. + + +Note [Overloaded field import] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +On the other hand, if we have + + {-# LANGUAGE DuplicateRecordFields #-} + module A where + data T = MkT { foo :: Int } + + module B where + import A + f = ...foo... + +then the minimal import for module B must be + import A ( T(foo) ) +because when DuplicateRecordFields is enabled, field selectors are +not in scope without their enclosing datatype. + +On the third hand, if we have + + {-# LANGUAGE DuplicateRecordFields #-} + module A where + pattern MkT { foo } = Just foo + + module B where + import A + f = ...foo... + +then the minimal import for module B must be + import A ( foo ) +because foo doesn't have a parent. This might actually be ambiguous if A +exports another field called foo, but there is no good answer to return and this +is a very obscure corner, so it seems to be the best we can do. See +DRFPatSynExport for a test of this. + + +************************************************************************ +* * +\subsection{Errors} +* * +************************************************************************ +-} + +badImportItemErr + :: ModIface -> ImpDeclSpec -> IE GhcPs + -> IsSubordinateError + -> [AvailInfo] + -> TcRn (NonEmpty ImportLookupReason) +badImportItemErr iface decl_spec ie sub avails = do + 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 $ 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 -> 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 what_look WL_Global) + dflags rdr_env emptyLocalRdrEnv rdr + similar_suggs = + case NE.nonEmpty $ mapMaybe imported_item $ similar_names of + Just similar -> [ SuggestSimilarNames rdr similar ] + Nothing -> [ ] + + -- Only keep imported items, and set the "HowInScope" to + -- "Nothing" to avoid printing "imported from..." in the suggestion + -- error message. + imported_item (SimilarRdrName rdr_name (Just (ImportedBy {}))) + = Just (SimilarRdrName rdr_name Nothing) + imported_item _ = Nothing + + checkIfDataCon = checkIfAvailMatches isDataConName + checkIfTyCon = checkIfAvailMatches isTyConName + checkIfVarName = + \case + AvailTC{} -> False + Avail n -> importedFS == occNameFS (occName n) + && (isVarOcc <||> isFieldOcc) (occName n) + checkIfAvailMatches namePred = + \case + AvailTC _ ns -> + case find (\n -> importedFS == occNameFS (occName n)) ns of + Just n -> namePred n + Nothing -> False + Avail{} -> False + availOccName = occName . availName + rdr = ieName ie + importedFS = occNameFS $ rdrNameOcc rdr + imp_spec = ImpSpec { is_decl = decl_spec, is_item = ImpAll } + all_avails = mi_exports iface + +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 + = addErrAt (getSrcSpan (NE.last sorted_names)) $ (TcRnDuplicateDecls (greOccName gre) sorted_names) + where + sorted_names = + NE.sortBy (SrcLoc.leftmost_smallest `on` nameSrcSpan) + (fmap greName gres) + +-- This data decl will parse OK +-- data T = a Int +-- treating "a" as the constructor. +-- It is really hard to make the parser spot this malformation. +-- So the renamer has to check that the constructor is legal +-- +-- We can get an operator as the constructor, even in the prefix form: +-- data T = :% Int Int +-- from interface files, which always print in prefix form +-- +-- We also allow type constructor names, which are defined by "type data" +-- declarations. See Note [Type data declarations] in GHC.Rename.Module. + +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,11 +1,17 @@ -{-# 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 @@ -41,47 +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.Zonk ( hsOverLitName ) +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.Avail ( greNameMangledName ) -import GHC.Types.Error + +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, ConFieldInfo (..) ) import GHC.Builtin.Types ( nilDataCon ) import GHC.Core.DataCon -import GHC.Driver.Session ( getDynFlags, xopt_DuplicateRecordFields ) +import GHC.Core.TyCon ( isKindName ) import qualified GHC.LanguageExtensions as LangExt 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 GHC.Types.FieldLabel (DuplicateRecordFields(..)) -import Language.Haskell.Syntax.Basic (FieldLabelString(..)) +import Control.Monad.Trans.Writer.CPS +import Control.Monad.Trans.Class +import Control.Monad.Trans.Reader +import Data.Functor ((<&>)) +import Data.Coerce {- ********************************************************* @@ -145,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] @@ -212,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 @@ -232,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] $ @@ -299,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. @@ -321,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] @@ -329,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. @@ -338,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 #-} > @@ -363,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`. @@ -404,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) @@ -470,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) @@ -485,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 @@ -543,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 @@ -554,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 @@ -607,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) @@ -620,45 +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 = do - scoped_tyvars <- xoptM LangExt.ScopedTypeVariables - type_app <- xoptM LangExt.TypeApplications - unless (scoped_tyvars && type_app) $ - case listToMaybe tyargs of - Nothing -> pure () - Just tyarg -> addErr $ mkTcRnUnknownMessage $ mkPlainError noHints $ - hang (text "Illegal visible type application in a pattern:" - <+> quotes (ppr tyarg)) - 2 (text "Both ScopedTypeVariables and TypeApplications are" - <+> text "required to use this feature") - 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) @@ -666,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) @@ -687,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 @@ -739,8 +787,8 @@ -} data HsRecFieldContext - = HsRecFieldCon Name - | HsRecFieldPat Name + = HsRecFieldCon (WithUserRdr Name) + | HsRecFieldPat (WithUserRdr Name) | HsRecFieldUpd rnHsRecFields @@ -773,36 +821,39 @@ mb_con = case ctxt of HsRecFieldCon con -> Just con HsRecFieldPat con -> Just con - _ {- update -} -> Nothing + 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 - { hfbLHS = - (L loc (FieldOcc _ (L ll lbl))) + { hfbLHS = L loc (FieldOcc _ (L ll lbl)) , hfbRHS = arg - , hfbPun = pun })) + , hfbPun = pun })) = do { sel <- setSrcSpanA loc $ lookupRecFieldOcc parent lbl + ; let arg_rdr = mkRdrUnqual $ recFieldToVarOcc $ occName sel + -- Discard any module qualifier (#11662) ; arg' <- if pun - then do { checkErr pun_ok (TcRnIllegalFieldPunning (L (locA loc) lbl)) - -- Discard any module qualifier (#11662) - ; let arg_rdr = mkRdrUnqual (rdrNameOcc lbl) - ; return (L (l2l loc) (mk_arg (locA loc) arg_rdr)) } + then do { checkErr pun_ok $ + TcRnIllegalFieldPunning (L (locA loc) arg_rdr) + ; return $ L (l2l loc) $ + mk_arg (locA loc) arg_rdr } else return arg - ; return (L l (HsFieldBind - { hfbAnn = noAnn - , hfbLHS = (L loc (FieldOcc sel (L ll lbl))) - , hfbRHS = arg' - , hfbPun = pun })) } - + ; return $ L l $ + HsFieldBind + { hfbAnn = noAnn + , 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 @@ -811,9 +862,9 @@ do { dd_flag <- xoptM LangExt.RecordWildCards ; checkErr dd_flag (needFlagDotDot ctxt) ; (rdr_env, lcl_env) <- getRdrEnvs - ; con_fields <- lookupConstructorFields con - ; when (null con_fields) (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; @@ -822,28 +873,31 @@ -- f x = R { .. } -- Should expand to R {x=x}, not R{x=x,y=y} arg_in_scope lbl = mkRdrUnqual lbl `elemLocalRdrEnv` lcl_env - (dot_dot_fields, dot_dot_gres) - = unzip [ (fl, gre) - | fl <- con_fields - , let lbl = mkVarOccFS (field_label $ flLabel fl) - , not (lbl `elemOccSet` present_flds) - , Just gre <- [lookupGRE_FieldLabel rdr_env fl] - -- Check selector is in scope - , case ctxt of - HsRecFieldCon {} -> arg_in_scope lbl - _other -> True ] + (dot_dot_fields, dot_dot_gres) = + unzip [ (fl, gre) + | fl <- conInfoFields conInfo + , let lbl = recFieldToVarOcc $ occName $ flSelector fl + , not (lbl `elemOccSet` present_flds) + , Just gre <- [lookupGRE_FieldLabel rdr_env fl] + -- Check selector is in scope + , case ctxt of + HsRecFieldCon {} -> arg_in_scope lbl + _other -> True ] - ; addUsedGREs dot_dot_gres + ; 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 }) + , hfbPun = False }) | fl <- dot_dot_fields , let sel = flSelector fl - , let arg_rdr = mkVarUnqual (field_label $ flLabel fl) ] } + arg_rdr = mkRdrUnqual + $ recFieldToVarOcc + $ nameOccName sel ] } rn_dotdot _dotdot _mb_con _flds = return [] @@ -855,77 +909,115 @@ -- Each list represents a RdrName that occurred more than once -- (the list contains all occurrences) -- Each list in dup_fields is non-empty - (_, dup_flds) = removeDups compare (getFieldLbls flds) - - --- NB: Consider this: --- module Foo where { data R = R { fld :: Int } } --- module Odd where { import Foo; fld x = x { fld = 3 } } --- Arguably this should work, because the reference to 'fld' is --- unambiguous because there is only one field id 'fld' in scope. --- But currently it's rejected. + (_, dup_flds) = removeDups (uniqCompareFS `on` (occNameFS . rdrNameOcc)) (getFieldLbls flds) + -- See the same duplicate handling logic in rnHsRecUpdFields below for further context. +-- | Rename a regular (non-overloaded) record field update, +-- disambiguating the fields if necessary. rnHsRecUpdFields - :: [LHsRecUpdField GhcPs] - -> RnM ([LHsRecUpdField GhcRn], FreeVars) + :: [LHsRecUpdField GhcPs GhcPs] + -> RnM (XLHsRecUpdLabels GhcRn, [LHsRecUpdField GhcRn GhcRn], FreeVars) rnHsRecUpdFields flds - = do { pun_ok <- xoptM LangExt.NamedFieldPuns - ; dup_fields_ok <- xopt_DuplicateRecordFields <$> getDynFlags - ; (flds1, fvss) <- mapAndUnzipM (rn_fld pun_ok dup_fields_ok) flds - ; mapM_ (addErr . dupFieldErr HsRecFieldUpd) dup_flds + = do { pun_ok <- xoptM LangExt.NamedFieldPuns - -- Check for an empty record update e {} + -- Check for an empty record update: e {} -- NB: don't complain about e { .. }, because rn_dotdot has done that already - ; when (null flds) $ addErr TcRnEmptyRecordUpdate + ; case flds of + { [] -> failWithTc TcRnEmptyRecordUpdate + ; fld:other_flds -> + do { let dup_lbls :: [NE.NonEmpty RdrName] + (_, dup_lbls) = removeDups (uniqCompareFS `on` (occNameFS . rdrNameOcc)) + (fmap (unLoc . getFieldUpdLbl) flds) + -- NB: we compare using the underlying field label FastString, + -- in order to catch duplicates involving qualified names, + -- as in the record update `r { fld = x, Mod.fld = y }`. + -- See #21959. + -- Note that this test doesn't correctly handle exact Names, but those + -- aren't handled properly by the rest of the compiler anyway. See #22122. + ; mapM_ (addErr . dupFieldErr HsRecFieldUpd) dup_lbls - ; return (flds1, plusFVs fvss) } - where - rn_fld :: Bool -> DuplicateRecordFields -> LHsRecUpdField GhcPs - -> RnM (LHsRecUpdField GhcRn, FreeVars) - rn_fld pun_ok dup_fields_ok (L l (HsFieldBind { hfbLHS = L loc f - , hfbRHS = arg - , hfbPun = pun })) - = do { let lbl = rdrNameAmbiguousFieldOcc f - ; mb_sel <- setSrcSpanA loc $ - -- Defer renaming of overloaded fields to the typechecker - -- See Note [Disambiguating record fields] in GHC.Tc.Gen.Head - lookupRecFieldOcc_update dup_fields_ok lbl - ; arg' <- if pun - then do { 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))) } - else return arg - ; (arg'', fvs) <- rnLExpr arg' + -- See Note [Disambiguating record updates] + ; possible_parents <- lookupRecUpdFields (fld NE.:| other_flds) + ; let mb_unambig_lbls :: Maybe [FieldLabel] + fvs :: FreeVars + (mb_unambig_lbls, fvs) = + case possible_parents of + RnRecUpdParent { rnRecUpdLabels = gres } NE.:| [] + | let lbls = map fieldGRELabel $ NE.toList gres + -> ( Just lbls, mkFVs $ map flSelector lbls) + _ -> ( Nothing + , plusFVs $ map (plusFVs . map pat_syn_free_vars . NE.toList . rnRecUpdLabels) + $ NE.toList possible_parents + -- See Note [Using PatSyn FreeVars] + ) - ; let (lbl', fvs') = case mb_sel of - UnambiguousGre gname -> let sel_name = greNameMangledName gname - in (Unambiguous sel_name (L (l2l loc) lbl), fvs `addOneFV` sel_name) - AmbiguousFields -> (Ambiguous noExtField (L (l2l loc) lbl), fvs) + -- Rename each field. + ; (upd_flds, fvs') <- rn_flds pun_ok mb_unambig_lbls flds + ; let all_fvs = fvs `plusFV` fvs' + ; return (possible_parents, upd_flds, all_fvs) } } } - ; return (L l (HsFieldBind { hfbAnn = noAnn - , hfbLHS = L loc lbl' - , hfbRHS = arg'' - , hfbPun = pun }), fvs') } + where - dup_flds :: [NE.NonEmpty RdrName] - -- Each list represents a RdrName that occurred more than once - -- (the list contains all occurrences) - -- Each list in dup_fields is non-empty - (_, dup_flds) = removeDups compare (getFieldUpdLbls flds) + -- For an ambiguous record update involving pattern synonym record fields, + -- we must add all the possibly-relevant field selector names to ensure that + -- we typecheck the record update **after** we typecheck the pattern synonym + -- definition. See Note [Using PatSyn FreeVars]. + pat_syn_free_vars :: FieldGlobalRdrElt -> FreeVars + pat_syn_free_vars (GRE { gre_info = info }) + | IAmRecField fld_info <- info + , RecFieldInfo { recFieldLabel = fl, recFieldCons = cons } <- fld_info + , uniqSetAny is_PS cons + = unitFV (flSelector fl) + pat_syn_free_vars _ + = emptyFVs + is_PS :: ConLikeName -> Bool + is_PS (PatSynName {}) = True + is_PS (DataConName {}) = False + rn_flds :: Bool -> Maybe [FieldLabel] + -> [LHsRecUpdField GhcPs GhcPs] + -> RnM ([LHsRecUpdField GhcRn GhcRn], FreeVars) + rn_flds _ _ [] = return ([], emptyFVs) + rn_flds pun_ok mb_unambig_lbls + ((L l (HsFieldBind { hfbLHS = L loc (FieldOcc _ f) + , hfbRHS = arg + , hfbPun = pun })):flds) + = 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) (mkHsVarWithUserRdr lbl (L (l2l loc) arg_rdr))) } + else return arg + ; (arg'', fvs) <- rnLExpr arg' + ; let lbl' :: FieldOcc GhcRn + lbl' = case mb_unambig_lbls of + { Just (fl:_) -> + let sel_name = flSelector fl + 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 (l2l loc) lbl' + , hfbRHS = arg'' + , hfbPun = pun }) + ; (flds', fvs') <- rn_flds pun_ok (tail <$> mb_unambig_lbls) flds + ; return (fld' : flds', fvs `plusFV` fvs') } getFieldIds :: [LHsRecField GhcRn arg] -> [Name] getFieldIds flds = map (hsRecFieldSel . unLoc) flds -getFieldLbls :: forall p arg . UnXRec p => [LHsRecField p arg] -> [RdrName] -getFieldLbls flds - = map (unXRec @p . foLabel . unXRec @p . hfbLHS . unXRec @p) flds +getFieldRdrs :: [LHsRecField GhcRn arg] -> [RdrName] +getFieldRdrs flds = map (foExt . unXRec @GhcRn . hfbLHS . unLoc) flds -getFieldUpdLbls :: [LHsRecUpdField GhcPs] -> [RdrName] -getFieldUpdLbls flds = map (rdrNameAmbiguousFieldOcc . unLoc . hfbLHS . unLoc) flds +getFieldLbls :: [LHsRecField (GhcPass p) arg] -> [IdGhcP p] +getFieldLbls flds + = map (unLoc . foLabel . unLoc . hfbLHS . unLoc) flds needFlagDotDot :: HsRecFieldContext -> TcRnMessage needFlagDotDot = TcRnIllegalWildcardsInRecord . toRecordFieldPart @@ -934,11 +1026,128 @@ 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] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When the -XDuplicateRecordFields extension is used, to rename and typecheck +a non-overloaded record update, we might need to disambiguate the field labels. + +Consider the following definitions: + + {-# LANGUAGE DuplicateRecordFields #-} + + data R = MkR1 { fld1 :: Int, fld2 :: Char } + | MKR2 { fld1 :: Int, fld2 :: Char, fld3 :: Bool } + data S = MkS1 { fld1 :: Int } | MkS2 { fld2 :: Char } + +In a record update, the `lookupRecUpdFields` function tries to determine +the parent datatype by computing the parents (TyCon/PatSyn) which have +at least one constructor (DataCon/PatSyn) with all of the fields. + +To do this, given the (non-empty) set of fields in the record update, +lookupRecUpdFields proceeds as follows: + + (1) For each field, retrieve all the in-scope GREs that it could possibly + refer to. + + (2) Take an intersection to compute the possible parent data constructors. + For example, for an update + + 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: only R contains the field fld1 with the M qualifier. + + 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 +Note [Disambiguating record updates], and have determined that this +record update might involve pattern synonym record fields, it is important +to declare usage of all these pattern synonyms record fields in the returned +FreeVars of rnHsRecUpdFields. This ensures that the typechecker sees +that the typechecking of the record update depends on the typechecking +of the pattern synonym, and typechecks the pattern synonyms first. +Not doing so caused #21898. + +Note that this can be removed once GHC proposal #366 is implemented, +as we will be able to fully disambiguate the record update in the renamer, +and can immediately declare the correct used FreeVars instead of having +to over-estimate in case of ambiguity. + ************************************************************************ * * \subsubsection{Literals} @@ -997,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.Session +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) @@ -62,12 +64,13 @@ , tcTopSpliceExpr ) -import GHC.Tc.Utils.Zonk +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 {- ************************************************************************ @@ -78,60 +81,88 @@ -} -- Check that -XTemplateHaskellQuotes is enabled and available -checkForTemplateHaskellQuotes :: HsExpr GhcPs -> RnM () +checkForTemplateHaskellQuotes :: HsExpr GhcPs -> RnM () checkForTemplateHaskellQuotes e = - do { thQuotesEnabled <- xoptM LangExt.TemplateHaskellQuotes - ; unless thQuotesEnabled $ - failWith ( mkTcRnUnknownMessage $ mkPlainError noHints $ vcat - [ text "Syntax error on" <+> ppr e - , text ("Perhaps you intended to use TemplateHaskell" - ++ " or TemplateHaskellQuotes") ] ) - } + 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 illegalTypedBracket + ; 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" (ppr e) ; Comp -> return () - ; Brack {} -> failWithTc illegalBracket + ; Brack {} -> failWithTc $ thSyntaxError + $ NestedTHBrackets } -- Brackets are desugared to code that mentions the TH package ; 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 illegalUntypedBracket - ; 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" (ppr e) ; Comp -> return () - ; Brack {} -> failWithTc illegalBracket + ; Brack {} -> failWithTc $ thSyntaxError + $ NestedTHBrackets } -- Brackets are desugared to code that mentions the TH package @@ -142,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) - (quotedNameStageErr 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 } @@ -196,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 @@ -210,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 @@ -222,36 +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) - -illegalBracket :: TcRnMessage -illegalBracket = mkTcRnUnknownMessage $ mkPlainError noHints $ - text "Template Haskell brackets cannot be nested" <+> - text "(without intervening splices)" - -illegalTypedBracket :: TcRnMessage -illegalTypedBracket = mkTcRnUnknownMessage $ mkPlainError noHints $ - text "Typed brackets may only appear in typed splices." - -illegalUntypedBracket :: TcRnMessage -illegalUntypedBracket = mkTcRnUnknownMessage $ mkPlainError noHints $ - text "Untyped brackets may only appear in untyped splices." - -quotedNameStageErr :: HsQuote GhcPs -> TcRnMessage -quotedNameStageErr br - = mkTcRnUnknownMessage $ mkPlainError noHints $ - sep [ text "Stage error: the non-top-level quoted name" <+> ppr br - , text "must be used at the same stage at which it is bound" ] - - {- ********************************************************* * * @@ -290,31 +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 - -> failWithTc illegalUntypedSplice +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 @@ -326,15 +311,14 @@ -- are not executed until the top-level splice is run. checkTopSpliceAllowed :: HsUntypedSplice GhcPs -> RnM () checkTopSpliceAllowed splice = do - let (herald, ext) = spliceExtension splice - extEnabled <- xoptM ext - unless extEnabled - (failWith $ mkTcRnUnknownMessage $ mkPlainError noHints $ - text herald <+> text "are not permitted without" <+> ppr ext) + let (ext, err) = spliceExtension splice + unlessXOptM ext $ failWith err where - spliceExtension :: HsUntypedSplice GhcPs -> (String, LangExt.Extension) - spliceExtension (HsQuasiQuote {}) = ("Quasi-quotes", LangExt.QuasiQuotes) - spliceExtension (HsUntypedSpliceExpr {}) = ("Top-level splices", LangExt.TemplateHaskell) + spliceExtension :: HsUntypedSplice GhcPs -> (LangExt.Extension, TcRnMessage) + spliceExtension (HsQuasiQuote {}) = + (LangExt.QuasiQuotes, TcRnIllegalQuasiQuotes) + spliceExtension (HsUntypedSpliceExpr {}) = + (LangExt.TemplateHaskell, thSyntaxError $ IllegalTHSplice) ------------------ @@ -354,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 @@ -366,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 @@ -391,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 @@ -430,41 +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 _) - -> failWithTc illegalTypedSplice + UntypedBrack {} + -> failWithTc $ thSyntaxError $ MismatchedSpliceType Typed IsSplice - _ -> do { extEnabled <- xoptM LangExt.TemplateHaskell - ; unless extEnabled - (failWith $ mkTcRnUnknownMessage $ mkPlainError noHints $ - text "Top-level splices are not permitted without" - <+> ppr LangExt.TemplateHaskell) + _ -> 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 @@ -474,44 +467,50 @@ ; traceRn "rnTypedSplice: typed expression splice" empty ; lcl_rdr <- getLocalRdrEnv ; gbl_rdr <- getGlobalRdrEnv - ; let gbl_names = mkNameSet [greMangledName gre | gre <- globalRdrEnvElts gbl_rdr - , isLocalGRE gre] + ; let gbl_names = mkNameSet [ greName gre + | gre <- globalRdrEnvElts gbl_rdr + , isLocalGRE gre] 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 +thSyntaxError err = TcRnTHError $ THSyntaxError err + {- Note [Running splices in the Renamer] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -657,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' ...)) -} @@ -667,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 @@ -747,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 @@ -761,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) @@ -776,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. -- @@ -841,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 @@ -895,86 +907,137 @@ = vcat [ text "--" <+> ppr loc <> colon <+> text "Splicing" <+> text sd , gen ] -illegalTypedSplice :: TcRnMessage -illegalTypedSplice = mkTcRnUnknownMessage $ mkPlainError noHints $ - text "Typed splices may not appear in untyped brackets" - -illegalUntypedSplice :: TcRnMessage -illegalUntypedSplice = mkTcRnUnknownMessage $ mkPlainError noHints $ - text "Untyped splices may not appear in typed brackets" - -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 (quotes (ppr 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] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1011,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 @@ -1030,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 #-} {- @@ -9,29 +10,41 @@ module GHC.Rename.Unbound ( mkUnboundName , mkUnboundNameRdr + , mkUnboundGRE + , mkUnboundGRERdr , isUnboundName , reportUnboundName - , reportUnboundName' , unknownNameSuggestions + , unknownNameSuggestionsMessage + , similarNameSuggestions + , fieldSelectorSuggestions , WhatLooking(..) , WhereLooking(..) , LookingFor(..) , unboundName , unboundNameX + , unboundTermNameInTypes + , IsTermInTypes(..) , notInScopeErr - , nameSpacesRelated + , relevantNameSpace + , suggestionIsRelevant + , termNameInType ) where import GHC.Prelude -import GHC.Driver.Session +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) import GHC.Data.Maybe import GHC.Data.FastString @@ -45,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 {- ************************************************************************ @@ -67,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 @@ -93,39 +95,91 @@ , lf_where :: WhereLooking } +data IsTermInTypes = UnknownTermInTypes RdrName | TermInTypes RdrName | NoTermInTypes + mkUnboundNameRdr :: RdrName -> Name mkUnboundNameRdr rdr = mkUnboundName (rdrNameOcc rdr) -reportUnboundName' :: WhatLooking -> RdrName -> RnM Name -reportUnboundName' what_look rdr = unboundName (LF what_look WL_Anywhere) rdr +mkUnboundGRE :: OccName -> GlobalRdrElt +mkUnboundGRE occ = mkLocalGRE UnboundGRE NoParent $ mkUnboundName occ -reportUnboundName :: RdrName -> RnM Name -reportUnboundName = reportUnboundName' WL_Anything +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 + unboundName :: LookingFor -> RdrName -> RnM Name unboundName lf rdr = unboundNameX lf rdr [] unboundNameX :: LookingFor -> RdrName -> [GhcHint] -> RnM Name unboundNameX looking_for rdr_name hints + = unboundNameOrTermInType NoTermInTypes looking_for rdr_name hints + +unboundTermNameInTypes :: LookingFor -> RdrName -> RdrName -> RnM Name +unboundTermNameInTypes looking_for rdr_name demoted_rdr_name + = unboundNameOrTermInType (UnknownTermInTypes demoted_rdr_name) looking_for rdr_name [] + +-- Catches imported qualified terms in type signatures +-- with proper error message and suggestions +termNameInType :: LookingFor -> RdrName -> RdrName -> [GhcHint] -> RnM Name +termNameInType looking_for rdr_name demoted_rdr_name external_hints + = unboundNameOrTermInType (TermInTypes demoted_rdr_name) looking_for rdr_name external_hints + +unboundNameOrTermInType :: IsTermInTypes -> LookingFor -> RdrName -> [GhcHint] -> RnM Name +unboundNameOrTermInType if_term_in_type looking_for rdr_name hints = do { dflags <- getDynFlags ; let show_helpful_errors = gopt Opt_HelpfulErrors dflags - err = notInScopeErr (lf_where looking_for) rdr_name ; if not show_helpful_errors - then addErr $ TcRnNotInScope err rdr_name [] 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 $ - TcRnNotInScope err rdr_name imp_errs (hints ++ suggs) } + ; 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 + name_to_search = case if_term_in_type of + NoTermInTypes -> rdr_name + UnknownTermInTypes demoted_name -> demoted_name + TermInTypes demoted_name -> demoted_name + err = notInScopeErr (lf_where looking_for) name_to_search + 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 @@ -136,14 +190,20 @@ = NotInScope -- | Called from the typechecker ("GHC.Tc.Errors") when we find an unbound variable -unknownNameSuggestions :: WhatLooking -> DynFlags - -> HomePackageTable -> Module - -> GlobalRdrEnv -> LocalRdrEnv -> ImportAvails - -> RdrName -> ([ImportError], [GhcHint]) -unknownNameSuggestions what_look = unknownNameSuggestions_ (LF what_look WL_Anywhere) +unknownNameSuggestions :: LocalRdrEnv -> WhatLooking -> RdrName -> RnM ([ImportError], [GhcHint]) +unknownNameSuggestions lcl_env what_look tried_rdr_name = + do { dflags <- getDynFlags + ; rdr_env <- getGlobalRdrEnv + ; imp_info <- getImports + ; curr_mod <- getModule + ; interactive_context <- hsc_IC <$> getTopEnv + ; return $ + unknownNameSuggestions_ + (LF what_look WL_Anywhere) + 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 @@ -152,10 +212,10 @@ suggs = mconcat [ if_ne (SuggestSimilarNames tried_rdr_name) $ similarNameSuggestions looking_for dflags global_env local_env tried_rdr_name - , map ImportSuggestion imp_suggs + , 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 _ [] = [] @@ -168,9 +228,9 @@ | null gres = [] | otherwise = [RemindFieldSelectorSuppressed tried_rdr_name parents] where - gres = filter isNoFieldSelectorGRE $ - lookupGRE_RdrName' tried_rdr_name global_env - parents = [ parent | ParentIs parent <- map gre_par gres ] + gres = filter isNoFieldSelectorGRE + $ lookupGRE global_env (LookupRdrName tried_rdr_name AllRelevantGREs) + parents = [ parent | ParentIs parent <- map greParent gres ] similarNameSuggestions :: LookingFor -> DynFlags -> GlobalRdrEnv -> LocalRdrEnv @@ -182,18 +242,17 @@ all_possibilities :: [(String, SimilarName)] all_possibilities = case what_look of WL_None -> [] - _ -> [ (showPpr dflags r, SimilarRdrName r (LocallyBoundAt loc)) + _ -> [ (showPpr dflags r, SimilarRdrName r (Just $ LocallyBoundAt loc)) | (r,loc) <- local_possibilities local_env ] ++ [ (showPpr dflags r, rp) | (r, rp) <- global_possibilities global_env ] 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) @@ -209,15 +268,16 @@ | 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 - | tried_is_qual = [ (rdr_qual, SimilarRdrName rdr_qual how) + | tried_is_qual = [ (rdr_qual, SimilarRdrName rdr_qual (Just how)) | 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 ] @@ -226,9 +286,9 @@ , 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 how ] + (how:_, _) -> [ SimilarRdrName rdr_unqual (Just how) ] ([], pr:_) -> [ pr ] -- See Note [Only-quals] ([], []) -> [] ] @@ -256,31 +316,29 @@ quals_only :: GlobalRdrElt -> [SimilarName] -- Ones for which *only* the qualified version is in scope quals_only (gre@GRE { gre_imp = is }) - = [ (SimilarRdrName (mkRdrQual (is_as ispec) (greOccName gre)) (ImportedBy ispec)) + = [ (SimilarRdrName (mkRdrQual (is_as ispec) (greOccName gre)) (Just $ ImportedBy ispec)) | i <- bagToList is, let ispec = is_decl i, is_qual ispec ] -- | 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) occ_name]) + = ([], [CouldImportFrom (mod :| mods)]) | mod : mods <- helpful_imports_hiding - = ([], [CouldUnhideFrom (mod :| mods) occ_name]) + = ([], [CouldUnhideFrom (mod :| mods)]) | otherwise = ([], []) where @@ -288,16 +346,27 @@ (mod_name, occ_name) = case rdr_name of Unqual occ_name -> (Nothing, occ_name) Qual mod_name occ_name -> (Just mod_name, occ_name) - _ -> error "importSuggestions: dead code" + _ -> panic "importSuggestions: dead code" -- 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 @@ -312,7 +381,8 @@ helpful_imports = filter helpful interesting_imports where helpful (_,imv) = any (isGreOk looking_for) $ - lookupGlobalRdrEnv (imv_all_exports imv) occ_name + lookupGRE (imv_all_exports imv) + (LookupOccName occ_name $ RelevantGREsFOS WantNormal) -- Which of these do that because of an explicit hiding list resp. an -- explicit import list @@ -322,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 @@ -367,39 +430,47 @@ 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' `elem` ns : [ other_ns - | (orig_ns, others) <- other_namespaces - , ns == orig_ns - , (other_ns, wls) <- others - , what_looking `elem` WL_Anything : wls - ] - where - -- explanation: - -- [(orig_ns, [(other_ns, what_looking_possibilities)])] - -- A particular other_ns is related if the original namespace is orig_ns - -- and what_looking is either WL_Anything or is one of - -- what_looking_possibilities - other_namespaces = - [ (varName , [(dataName, [WL_Constructor])]) - , (dataName , [(varName , [WL_RecField])]) - , (tvName , (tcClsName, [WL_Constructor]) : promoted_datacons) - , (tcClsName, (tvName , []) : promoted_datacons) - ] - -- If -XDataKinds is enabled, the data constructor name space is also - -- related to the type-level name spaces - data_kinds = xopt LangExt.DataKinds dflags - promoted_datacons = [(dataName, [WL_Constructor]) | data_kinds] +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] -~~~~~~~~~~~~~~~~~~~~~~~~~ +{- Note [Related name spaces] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Name spaces are related if there is a chance to mean the one when one writes the other, i.e. variables <-> data constructors and type variables <-> type constructors. @@ -426,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 #-} {- @@ -9,26 +11,29 @@ -} module GHC.Rename.Utils ( - checkDupRdrNames, checkDupRdrNamesN, checkShadowedRdrNames, + checkDupRdrNames, checkShadowedRdrNames, checkDupNames, checkDupAndShadowedNames, dupNamesErr, checkTupSize, checkCTupSize, addFvRn, mapFvRn, mapMaybeFvRn, warnUnusedMatches, warnUnusedTypePatterns, warnUnusedTopBinds, warnUnusedLocalBinds, - warnForallIdentifier, + DeprecationWarnings(..), warnIfDeprecated, checkUnusedRecordWildcard, - mkFieldEnv, badQualBndrErr, typeAppErr, badFieldConErr, - wrapGenSpan, genHsVar, genLHsVar, genHsApp, genHsApps, genAppType, - genHsIntegralLit, genHsTyLit, genSimpleConPat, + 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, + bindLocalNames, bindLocalNamesFV, delLocalNames, - addNameClashErrRn, + addNameClashErrRn, mkNameClashErr, checkInferredVars, noNestedForallsContextsErr, addNoNestedForallsContextsErr @@ -37,15 +42,14 @@ where -import GHC.Prelude hiding (unzip) +import GHC.Prelude import GHC.Core.Type import GHC.Hs import GHC.Types.Name.Reader import GHC.Tc.Errors.Types -import GHC.Tc.Utils.Env +-- import GHC.Tc.Utils.Env import GHC.Tc.Utils.Monad -import GHC.Types.Error import GHC.Types.Name import GHC.Types.Name.Set import GHC.Types.Name.Env @@ -54,21 +58,27 @@ import GHC.Types.SourceFile import GHC.Types.SourceText ( SourceText(..), IntegralLit ) import GHC.Utils.Outputable -import GHC.Utils.Panic import GHC.Utils.Misc -import GHC.Types.Basic ( TopLevelFlag(..), Origin(Generated) ) -import GHC.Data.List.SetOps ( removeDups ) +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.Session +import GHC.Driver.DynFlags import GHC.Data.FastString +import GHC.Data.Bag ( mapBagM, headMaybe ) import Control.Monad -import Data.List (find, sortBy) import GHC.Settings.Constants ( mAX_TUPLE_SIZE, mAX_CTUPLE_SIZE ) -import qualified Data.List.NonEmpty as NE +import GHC.Unit.Module +import GHC.Unit.Module.Warnings ( WarningTxt(..) ) +import GHC.Iface.Load import qualified GHC.LanguageExtensions as LangExt -import GHC.Data.Bag -import qualified Data.List as List +import qualified Data.List.NonEmpty as NE +import Data.Foldable (for_) +import Data.Maybe + + {- ********************************************************* * * @@ -95,8 +105,8 @@ bindLocalNames :: [Name] -> RnM a -> RnM a bindLocalNames names - = updLclEnv $ \ lcl_env -> - let th_level = thLevel (tcl_th_ctxt lcl_env) + = updLclCtxt $ \ 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 @@ -108,20 +118,21 @@ = do { (result, fvs) <- bindLocalNames names enclosed_scope ; return (result, delFVs names fvs) } +delLocalNames :: [Name] -> RnM a -> RnM a +delLocalNames names + = updLclCtxt $ \ lcl_env -> + let th_bndrs' = delListFromNameEnv (tcl_th_bndrs lcl_env) names + rdr_env' = minusLocalRdrEnvList (tcl_rdr lcl_env) (map occName names) + in lcl_env { tcl_th_bndrs = th_bndrs' + , tcl_rdr = rdr_env' } + ------------------------------------- checkDupRdrNames :: [LocatedN RdrName] -> RnM () -- Check for duplicated names in a binding group checkDupRdrNames rdr_names_w_loc - = mapM_ (dupNamesErr getLocA) dups - where - (_, dups) = removeDups (\n1 n2 -> unLoc n1 `compare` unLoc n2) rdr_names_w_loc - -checkDupRdrNamesN :: [LocatedN RdrName] -> RnM () --- Check for duplicated names in a binding group -checkDupRdrNamesN rdr_names_w_loc - = mapM_ (dupNamesErr getLocA) dups + = mapM_ (\ ns -> dupNamesErr (getLocA <$> ns) (unLoc <$> ns)) dups where - (_, dups) = removeDups (\n1 n2 -> unLoc n1 `compare` unLoc n2) rdr_names_w_loc + (_, dups) = removeDupsOn unLoc rdr_names_w_loc checkDupNames :: [Name] -> RnM () -- Check for duplicated names in a binding group @@ -130,9 +141,9 @@ check_dup_names :: [Name] -> RnM () check_dup_names names - = mapM_ (dupNamesErr nameSrcSpan) dups + = mapM_ (\ ns -> dupNamesErr (nameSrcSpan <$> ns) (getRdrName <$> ns)) dups where - (_, dups) = removeDups (\n1 n2 -> nameOccName n1 `compare` nameOccName n2) names + (_, dups) = removeDupsOn nameOccName names --------------------- checkShadowedRdrNames :: [LocatedN RdrName] -> RnM () @@ -171,7 +182,7 @@ where (loc,occ) = get_loc_occ n mb_local = lookupLocalRdrOcc local_env occ - gres = lookupGRE_RdrName (mkRdrUnqual occ) global_env + gres = lookupGRE global_env (LookupRdrName (mkRdrUnqual occ) (RelevantGREsFOS WantNormal)) -- Make an Unqualified RdrName and look that up, so that -- we don't find any GREs that are in scope qualified-only @@ -193,19 +204,15 @@ -- @{a}@, but @forall a. [a] -> [a]@ would be accepted. -- See @Note [Unobservably inferred type variables]@. checkInferredVars :: HsDocContext - -> Maybe SDoc - -- ^ The error msg if the signature is not allowed to contain - -- manually written inferred variables. -> LHsSigType GhcPs -> RnM () -checkInferredVars _ Nothing _ = return () -checkInferredVars ctxt (Just msg) ty = +checkInferredVars ctxt ty = let bndrs = sig_ty_bndrs ty - in case find ((==) InferredSpec . hsTyVarBndrFlag) bndrs of - Nothing -> return () - Just _ -> addErr $ + in case filter ((==) InferredSpec . hsTyVarBndrFlag) bndrs of + [] -> return () + iv : ivs -> addErr $ TcRnWithHsDocContext ctxt $ - mkTcRnUnknownMessage $ mkPlainError noHints msg + TcRnIllegalInferredTyVars (iv NE.:| ivs) where sig_ty_bndrs :: LHsSigType GhcPs -> [HsTyVarBndr Specificity GhcPs] sig_ty_bndrs (L _ (HsSig{sig_bndrs = outer_bndrs})) @@ -288,7 +295,9 @@ -- "GHC.Rename.Module" and 'renameSig' in "GHC.Rename.Bind"). -- See @Note [No nested foralls or contexts in instance types]@ in -- "GHC.Hs.Type". -noNestedForallsContextsErr :: SDoc -> LHsType GhcRn -> Maybe (SrcSpan, TcRnMessage) +noNestedForallsContextsErr :: NestedForallsContextsIn + -> LHsType GhcRn + -> Maybe (SrcSpan, TcRnMessage) noNestedForallsContextsErr what lty = case ignoreParens lty of L l (HsForAllTy { hst_tele = tele }) @@ -305,12 +314,13 @@ _ -> Nothing where nested_foralls_contexts_err = - mkTcRnUnknownMessage $ mkPlainError noHints $ - what <+> text "cannot contain nested" - <+> quotes forAllLit <> text "s or contexts" + TcRnNestedForallsContexts what -- | A common way to invoke 'noNestedForallsContextsErr'. -addNoNestedForallsContextsErr :: HsDocContext -> SDoc -> LHsType GhcRn -> RnM () +addNoNestedForallsContextsErr :: HsDocContext + -> NestedForallsContextsIn + -> LHsType GhcRn + -> RnM () addNoNestedForallsContextsErr ctxt what lty = whenIsJust (noNestedForallsContextsErr what lty) $ \(l, err_msg) -> addErrAt l $ TcRnWithHsDocContext ctxt err_msg @@ -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) } @@ -356,13 +361,13 @@ warnUnusedTopBinds gres = whenWOptM Opt_WarnUnusedTopBinds $ do env <- getGblEnv - let isBoot = tcg_src env == HsBootFile - let noParent gre = case gre_par gre of + let isBoot = isHsBootFile $ tcg_src env + let noParent gre = case greParent gre of NoParent -> True _ -> 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 @@ -396,13 +404,7 @@ -- -- The `..` here doesn't bind any variables as `x` is already bound. warnRedundantRecordWildcard :: RnM () -warnRedundantRecordWildcard = - whenWOptM Opt_WarnRedundantRecordWildcards $ - let msg = mkTcRnUnknownMessage $ - mkPlainDiagnostic (WarningWithFlag Opt_WarnRedundantRecordWildcards) - noHints - redundantWildcardWarning - in addDiagnostic msg +warnRedundantRecordWildcard = addDiagnostic TcRnRedundantRecordWildcard -- | Produce a warning when no variables bound by a `..` pattern are used. @@ -419,104 +421,192 @@ warnUnusedRecordWildcard ns used_names = do let used = filter (`elemNameSet` used_names) ns traceRn "warnUnused" (ppr ns $$ ppr used_names $$ ppr used) - warnIf (null used) - unusedRecordWildcardWarning + 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 :: [Name] -> FreeVars -> RnM () -warnUnusedLocalBinds = check_unused Opt_WarnUnusedLocalBinds -warnUnusedMatches = check_unused Opt_WarnUnusedMatches -warnUnusedTypePatterns = check_unused Opt_WarnUnusedTypePatterns +warnUnusedLocalBinds = check_unused UnusedNameLocalBind +warnUnusedMatches = check_unused UnusedNameMatch +warnUnusedTypePatterns = check_unused UnusedNameTypePattern -check_unused :: WarningFlag -> [Name] -> FreeVars -> RnM () -check_unused flag bound_names used_names - = whenWOptM flag (warnUnused flag (filterOut (`elemNameSet` used_names) - bound_names)) +check_unused :: UnusedNameProv -> [Name] -> FreeVars -> RnM () +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 () warnUnusedGREs gres = mapM_ warnUnusedGRE gres -- NB the Names must not be the names of record fields! -warnUnused :: WarningFlag -> [Name] -> RnM () -warnUnused flag names = - mapM_ (warnUnused1 flag . NormalGreName) names +warnUnused :: UnusedNameProv -> [Name] -> RnM () +warnUnused prov names = + mapM_ (\ nm -> warnUnused1 prov nm (nameOccName nm)) names -warnUnused1 :: WarningFlag -> GreName -> RnM () -warnUnused1 flag child - = when (reportable child) $ - addUnusedWarning flag - (occName child) (greNameSrcSpan child) - (text $ "Defined but not used" ++ opt_str) - where - opt_str = case flag of - Opt_WarnUnusedTypePatterns -> " on the right hand side" - _ -> "" +warnUnused1 :: UnusedNameProv -> Name -> OccName -> RnM () +warnUnused1 prov child child_occ + = when (reportable child child_occ) $ + warn_unused_name prov (nameSrcSpan child) child_occ +warn_unused_name :: UnusedNameProv -> SrcSpan -> OccName -> RnM () +warn_unused_name prov span child_occ = + addDiagnosticAt span (TcRnUnusedName child_occ prov) + warnUnusedGRE :: GlobalRdrElt -> RnM () warnUnusedGRE gre@(GRE { gre_lcl = lcl, gre_imp = is }) - | lcl = warnUnused1 Opt_WarnUnusedTopBinds (gre_name gre) - | otherwise = when (reportable (gre_name gre)) (mapM_ warn is) + | lcl = warnUnused1 UnusedNameTopDecl nm occ + | otherwise = when (reportable nm occ) (mapM_ warn is) where occ = greOccName gre - warn spec = addUnusedWarning Opt_WarnUnusedTopBinds occ span msg - where - span = importSpecLoc spec - pp_mod = quotes (ppr (importSpecModule spec)) - msg = text "Imported from" <+> pp_mod <+> text "but not used" - --- | Make a map from selector names to field labels and parent tycon --- names, to be used when reporting unused record fields. -mkFieldEnv :: GlobalRdrEnv -> NameEnv (FieldLabelString, Parent) -mkFieldEnv rdr_env = mkNameEnv [ (greMangledName gre, (flLabel fl, gre_par gre)) - | gres <- nonDetOccEnvElts rdr_env - , gre <- gres - , Just fl <- [greFieldLabel gre] - ] + nm = greName gre + warn spec = + warn_unused_name (UnusedNameImported (importSpecModule spec)) span occ + where + span = importSpecLoc spec -- | Should we report the fact that this 'Name' is unused? The -- 'OccName' may differ from 'nameOccName' due to -- DuplicateRecordFields. -reportable :: GreName -> Bool -reportable child - | NormalGreName name <- child - , isWiredInName name = False -- Don't report unused wired-in names - -- Otherwise we get a zillion warnings - -- from Data.Tuple - | otherwise = not (startsWithUnderscore (occName child)) - -addUnusedWarning :: WarningFlag -> OccName -> SrcSpan -> SDoc -> RnM () -addUnusedWarning flag occ span msg = do - let diag = mkTcRnUnknownMessage $ mkPlainDiagnostic (WarningWithFlag flag) noHints $ - sep [msg <> colon, - nest 2 $ pprNonVarNameSpace (occNameSpace occ) - <+> quotes (ppr occ)] - addDiagnosticAt span diag - -unusedRecordWildcardWarning :: TcRnMessage -unusedRecordWildcardWarning = - mkTcRnUnknownMessage $ mkPlainDiagnostic (WarningWithFlag Opt_WarnUnusedRecordWildcards) noHints $ - wildcardDoc $ text "No variables bound in the record wildcard match are used" - -redundantWildcardWarning :: SDoc -redundantWildcardWarning = - wildcardDoc $ text "Record wildcard does not bind any new variables" - -wildcardDoc :: SDoc -> SDoc -wildcardDoc herald = - herald - $$ nest 2 (text "Possible fix" <> colon <+> text "omit the" - <+> quotes (text "..")) +reportable :: Name -> OccName -> Bool +reportable child child_occ + | isWiredInName child + = False -- Don't report unused wired-in names + -- Otherwise we get a zillion warnings + -- from Data.Tuple + | otherwise + = not (startsWithUnderscore child_occ) {- Note [Skipping ambiguity errors at use sites of local declarations] @@ -555,45 +645,9 @@ -- already, and we don't want an error cascade. = return () | otherwise - = addErr $ mkTcRnUnknownMessage $ mkPlainError noHints $ - (vcat [ text "Ambiguous occurrence" <+> quotes (ppr rdr_name) - , text "It could refer to" - , nest 3 (vcat (msg1 : msgs)) ]) + = do { gre_env <- getGlobalRdrEnv + ; addErr $ mkNameClashErr gre_env rdr_name gres } where - np1 NE.:| nps = gres - msg1 = text "either" <+> ppr_gre np1 - msgs = [text " or" <+> ppr_gre np | np <- nps] - ppr_gre gre = sep [ pp_greMangledName gre <> comma - , pprNameProvenance gre] - - -- 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 - pp_greMangledName gre@(GRE { gre_name = child, gre_par = par - , gre_lcl = lcl, gre_imp = iss }) = - case child of - FieldGreName fl -> text "the field" <+> quotes (ppr fl) <+> parent_info - NormalGreName name -> quotes (pp_qual name <> dot <> ppr (nameOccName name)) - where - parent_info = case par of - NoParent -> empty - ParentIs { par_is = par_name } -> text "of record" <+> quotes (ppr par_name) - pp_qual name - | lcl - = ppr (nameModule name) - | Just imp <- headMaybe iss -- This 'imp' is the one that - -- pprNameProvenance chooses - , ImpDeclSpec { is_as = mod } <- is_decl imp - = ppr mod - | otherwise - = pprPanic "addNameClassErrRn" (ppr gre $$ ppr iss) - -- Invariant: either 'lcl' is True or 'iss' is non-empty - -- If all the GREs are defined locally, can we skip reporting an ambiguity -- error at use sites, because it will have been reported already? See -- Note [Skipping ambiguity errors at use sites of local declarations] @@ -605,34 +659,23 @@ num_flds = length flds num_non_flds = length non_flds +mkNameClashErr :: GlobalRdrEnv -> RdrName -> NE.NonEmpty GlobalRdrElt -> TcRnMessage +mkNameClashErr gre_env rdr_name gres = TcRnAmbiguousName gre_env rdr_name gres -dupNamesErr :: Outputable n => (n -> SrcSpan) -> NE.NonEmpty n -> RnM () -dupNamesErr get_loc names - = addErrAt big_loc $ mkTcRnUnknownMessage $ mkPlainError noHints $ - vcat [text "Conflicting definitions for" <+> quotes (ppr (NE.head names)), - locations] +dupNamesErr :: NE.NonEmpty SrcSpan -> NE.NonEmpty RdrName -> RnM () +dupNamesErr locs names + = addErrAt big_loc (TcRnBindingNameConflict (NE.head names) locs) where - locs = map get_loc (NE.toList names) - big_loc = foldr1 combineSrcSpans locs - locations = text "Bound at:" <+> vcat (map ppr (sortBy SrcLoc.leftmost_smallest locs)) + big_loc = foldr1 combineSrcSpans locs badQualBndrErr :: RdrName -> TcRnMessage -badQualBndrErr rdr_name - = mkTcRnUnknownMessage $ mkPlainError noHints $ - text "Qualified name in binding position:" <+> ppr rdr_name +badQualBndrErr rdr_name = TcRnQualifiedBinder rdr_name -typeAppErr :: String -> LHsType GhcPs -> TcRnMessage -typeAppErr what (L _ k) - = mkTcRnUnknownMessage $ mkPlainError noHints $ - hang (text "Illegal visible" <+> text what <+> text "application" - <+> quotes (char '@' <> ppr k)) - 2 (text "Perhaps you intended to use TypeApplications") +typeAppErr :: TypeOrKind -> LHsType GhcPs -> TcRnMessage +typeAppErr what (L _ k) = TcRnTypeApplicationsDisabled k what badFieldConErr :: Name -> FieldLabelString -> TcRnMessage -badFieldConErr con field - = mkTcRnUnknownMessage $ mkPlainError noHints $ - hsep [text "Constructor" <+> quotes (ppr con), - text "does not have field", quotes (ppr field)] +badFieldConErr con field = TcRnInvalidRecordField con field -- | Ensure that a boxed or unboxed tuple has arity no larger than -- 'mAX_TUPLE_SIZE'. @@ -641,10 +684,7 @@ | tup_size <= mAX_TUPLE_SIZE = return () | otherwise - = addErr $ mkTcRnUnknownMessage $ mkPlainError noHints $ - 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")] + = addErr (TcRnTupleTooLarge tup_size) -- | Ensure that a constraint tuple has arity no larger than 'mAX_CTUPLE_SIZE'. checkCTupSize :: Int -> TcM () @@ -652,41 +692,57 @@ | tup_size <= mAX_CTUPLE_SIZE = return () | otherwise - = addErr $ mkTcRnUnknownMessage $ mkPlainError noHints $ - 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") + = addErr (TcRnCTupleTooLarge tup_size) {- ********************************************************************* * * - 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) + 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)) -genHsIntegralLit :: IntegralLit -> LocatedAn an (HsExpr GhcRn) -genHsIntegralLit lit = wrapGenSpan $ HsLit noAnn (HsInt noExtField lit) +genLHsLit :: (NoAnn an) => HsLit GhcRn -> LocatedAn an (HsExpr GhcRn) +genLHsLit = wrapGenSpan . HsLit noExtField +genHsIntegralLit :: (NoAnn an) => IntegralLit -> LocatedAn an (HsExpr GhcRn) +genHsIntegralLit = genLHsLit . HsInt noExtField + genHsTyLit :: FastString -> HsType GhcRn genHsTyLit = HsTyLit noExtField . HsStrTy NoSourceText @@ -694,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) @@ -706,16 +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 (wrapGenSpan ms) + , fun_matches = mkMatchGroup (Generated OtherExpansion SkipPmc) (wrapGenSpan ms) , fun_ext = emptyNameSet } + +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 @@ -8,6 +8,7 @@ , substInteractiveContext , replaceImportEnv , icReaderEnv + , icExtendGblRdrEnv , icInteractiveModule , icInScopeTTs , icNamePprCtx @@ -18,7 +19,7 @@ import GHC.Hs -import GHC.Driver.Session +import GHC.Driver.DynFlags import {-# SOURCE #-} GHC.Driver.Plugins import GHC.Runtime.Eval.Types ( IcGlobalRdrEnv(..), Resume ) @@ -30,7 +31,7 @@ import GHC.Core.InstEnv import GHC.Core.Type -import GHC.Types.Avail +import GHC.Types.DefaultEnv ( DefaultEnv, emptyDefaultEnv ) import GHC.Types.Fixity.Env import GHC.Types.Id.Info ( IdDetails(..) ) import GHC.Types.Name @@ -94,7 +95,7 @@ call to initTc in initTcInteractive, which in turn get the module from it 'icInteractiveModule' field of the interactive context. - The 'homeUnitId' field stays as 'main' (or whatever -this-unit-id says. + The 'homeUnitId' field stays as 'main' (or whatever -this-unit-id says). * The main trickiness is that the type environment (tcg_type_env) and fixity envt (tcg_fix_env), now contain entities from all the @@ -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 @@ -185,10 +231,13 @@ Note [icReaderEnv recalculation] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The GlobalRdrEnv describing what’s in scope at the prompts consists -of all the imported things, followed by all the things defined on the prompt, with -shadowing. Defining new things on the prompt is easy: we shadow as needed and then extend the environment. But changing the set of imports, which can happen later as well, -is tricky: we need to re-apply the shadowing from all the things defined at the prompt! +of all the imported things, followed by all the things defined on the prompt, +with shadowing. Defining new things on the prompt is easy: we shadow as needed, +and then extend the environment. +But changing the set of imports, which can happen later as well, is tricky +we need to re-apply the shadowing from all the things defined at the prompt! + For example: ghci> let empty = True @@ -196,22 +245,21 @@ ghci> empty -- Still gets the 'empty' defined at the prompt True - -It would be correct ot re-construct the env from scratch based on +It would be correct to re-construct the env from scratch based on `ic_tythings`, but that'd be quite expensive if there are many entries in `ic_tythings` that shadow each other. -Therefore we keep around a that `GlobalRdrEnv` in `igre_prompt_env` that -contians _just_ the things defined at the prompt, and use that in -`replaceImportEnv` to rebuild the full env. Conveniently, `shadowNames` takes -such an `OccEnv` to denote the set of names to shadow. +Therefore we keep around a `GlobalRdrEnv` in `igre_prompt_env` that contains +_just_ the things defined at the prompt, and use that in `replaceImportEnv` to +rebuild the full env. Conveniently, `shadowNames` takes such an `OccEnv` +to denote the set of names to shadow. INVARIANT: Every `OccName` in `igre_prompt_env` is present unqualified as well -(else it would not be right to use pass `igre_prompt_env` to `shadowNames`.) +(else it would not be right to pass `igre_prompt_env` to `shadowNames`.) -The definition of the IcGlobalRdrEnv type should conceptually be in this module, and -made abstract, but it’s used in `Resume`, so it lives in GHC.Runtime.Eval.Type. -- +The definition of the IcGlobalRdrEnv type should conceptually be in this module, +and made abstract, but it’s used in `Resume`, so it lives in GHC.Runtime.Eval.Type. + -} -- | Interactive context, recording information about the state of the @@ -267,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 @@ -293,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. @@ -317,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 @@ -328,7 +376,7 @@ icInteractiveModule :: InteractiveContext -> Module icInteractiveModule (InteractiveContext { ic_mod_index = index }) - = mkInteractiveModule index + = mkInteractiveModule (show index) -- | This function returns the list of visible TyThings (useful for -- e.g. showBindings). @@ -343,12 +391,11 @@ where in_scope_unqualified thing = or [ unQualOK gre - | avail <- tyThingAvailInfo thing - , name <- availNames avail + | gre <- tyThingLocalGREs thing + , let name = greName gre , Just gre <- [lookupGRE_Name (icReaderEnv ictxt) name] ] - -- | Get the NamePprCtx function based on the flags and this InteractiveContext icNamePprCtx :: UnitEnv -> InteractiveContext -> NamePprCtx icNamePprCtx unit_env ictxt = mkNamePprCtx ptc unit_env (icReaderEnv ictxt) @@ -361,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 @@ -400,8 +447,11 @@ icExtendIcGblRdrEnv :: IcGlobalRdrEnv -> [TyThing] -> IcGlobalRdrEnv icExtendIcGblRdrEnv igre tythings = IcGlobalRdrEnv - { igre_env = igre_env igre `icExtendGblRdrEnv` tythings - , igre_prompt_env = igre_prompt_env igre `icExtendGblRdrEnv` tythings + { igre_env = icExtendGblRdrEnv False (igre_env igre) tythings + , igre_prompt_env = icExtendGblRdrEnv True (igre_prompt_env igre) tythings + -- Pass 'True' <=> drop names that are only available qualified. + -- This is done to maintain the invariant of Note [icReaderEnv recalculation] + -- that igre_prompt_env should only contain Names that are available unqualified. } -- This is used by setContext in GHC.Runtime.Eval when the set of imports @@ -409,13 +459,14 @@ replaceImportEnv :: IcGlobalRdrEnv -> GlobalRdrEnv -> IcGlobalRdrEnv replaceImportEnv igre import_env = igre { igre_env = new_env } where - import_env_shadowed = import_env `shadowNames` igre_prompt_env igre + import_env_shadowed = shadowNames False import_env (igre_prompt_env igre) new_env = import_env_shadowed `plusGlobalRdrEnv` igre_prompt_env igre --- | Add TyThings to the GlobalRdrEnv, earlier ones in the list shadowing --- later ones, and shadowing existing entries in the GlobalRdrEnv. -icExtendGblRdrEnv :: GlobalRdrEnv -> [TyThing] -> GlobalRdrEnv -icExtendGblRdrEnv env tythings +-- | Add 'TyThings' to the 'GlobalRdrEnv', earlier ones in the list shadowing +-- later ones, and shadowing existing entries in the 'GlobalRdrEnv'. +icExtendGblRdrEnv :: Bool -- ^ discard names that are only available qualified? + -> GlobalRdrEnv -> [TyThing] -> GlobalRdrEnv +icExtendGblRdrEnv drop_only_qualified env tythings = foldr add env tythings -- Foldr makes things in the front of -- the list shadow things at the back where @@ -424,12 +475,10 @@ | is_sub_bndr thing = env | otherwise - = foldl' extendGlobalRdrEnv env1 (concatMap localGREsFromAvail avail) + = foldl' extendGlobalRdrEnv env1 new_gres where - new_gres = concatMap availGreNames avail - new_occs = occSetToEnv (mkOccSet (map occName new_gres)) - env1 = shadowNames env new_occs - avail = tyThingAvailInfo thing + new_gres = tyThingLocalGREs thing + env1 = shadowNames drop_only_qualified env $ mkGlobalRdrEnv new_gres -- Ugh! The new_tythings may include record selectors, since they -- are not implicit-ids, and must appear in the TypeEnv. But they diff --git a/GHC/Runtime/Debugger.hs b/GHC/Runtime/Debugger.hs --- a/GHC/Runtime/Debugger.hs +++ b/GHC/Runtime/Debugger.hs @@ -16,7 +16,10 @@ import GHC -import GHC.Driver.Session +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 import GHC.Driver.Env @@ -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, @@ -50,10 +49,12 @@ import GHC.Driver.Main import GHC.Driver.Errors.Types ( hoistTcRnMessage ) import GHC.Driver.Env -import GHC.Driver.Session +import GHC.Driver.DynFlags 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,34 +64,40 @@ import GHC.ByteCode.Types import GHC.Linker.Loader as Loader +import GHC.Linker.Types (LinkedBreaks (..)) import GHC.Hs -import GHC.Core.Predicate -import GHC.Core.InstEnv +import GHC.Core.Class (classTyCon) import GHC.Core.FamInstEnv ( FamInst, orphNamesOfFamInst ) +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 GHC.Core.TyCo.Ppr 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 import GHC.Data.Bag -import GHC.Utils.Monad -import GHC.Utils.Panic import GHC.Utils.Error -import GHC.Utils.Outputable -import GHC.Utils.Misc +import GHC.Utils.Exception import GHC.Utils.Logger +import GHC.Utils.Misc +import GHC.Utils.Monad +import GHC.Utils.Outputable +import GHC.Utils.Panic import GHC.Types.RepType import GHC.Types.Fixity.Env @@ -105,37 +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 System.Directory +import GHC.Tc.Module ( runTcInteractive, tcRnTypeSkolemising, loadUnqualIfaces ) +import GHC.Tc.Solver (simplifyWantedsTcM) +import GHC.Tc.Utils.Env (tcGetInstEnvs) +import GHC.Tc.Utils.Instantiate (instDFunType) +import GHC.Tc.Utils.Monad + +import GHC.IfaceToCore +import GHC.ByteCode.Breakpoints + +import Control.Monad 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 Control.Monad -import Control.Monad.Catch as MC -import Data.Array -import GHC.Utils.Exception import Unsafe.Coerce ( unsafeCoerce ) - -import GHC.Tc.Module ( runTcInteractive, tcRnType, loadUnqualIfaces ) -import GHC.Tc.Utils.Zonk ( ZonkFlexi (SkolemiseFlexi) ) -import GHC.Tc.Utils.Env (tcGetInstEnvs) -import GHC.Tc.Utils.Instantiate (instDFunType) -import GHC.Tc.Solver (simplifyWantedsTcM) -import GHC.Tc.Utils.Monad -import GHC.Core.Class (classTyCon) -import GHC.Unit.Env -import GHC.IfaceToCore +import qualified GHC.Unit.Home.Graph as HUG +import GHCi.BreakArray (BreakArray) -- ----------------------------------------------------------------------------- -- running a statement interactively @@ -143,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 () @@ -229,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) @@ -279,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 @@ -319,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 @@ -437,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 @@ -494,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 @@ -510,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) -- ----------------------------------------------------------------------------- @@ -526,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" @@ -548,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; @@ -595,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 @@ -615,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 @@ -623,8 +645,10 @@ -- saved/restored, but not the linker state. See #1743, test break026. mkNewId :: OccName -> Type -> Id -> IO Id mkNewId occ ty old_id - = do { name <- newInteractiveBinder hsc_env occ (getSrcSpan old_id) - ; return (Id.mkVanillaGlobalWithInfo name ty (idInfo old_id)) } + = do { name <- newInteractiveBinder hsc_env (mkVarOccFS (occNameFS occ)) (getSrcSpan old_id) + -- NB: use variable namespace. + -- Don't use record field namespaces, lest we cause #25109. + ; return $ Id.mkVanillaGlobalWithInfo name ty (idInfo old_id) } newTyVars :: UniqSupply -> [TcTyVar] -> Subst -- Similarly, clone the type variables mentioned in the types @@ -650,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 @@ -665,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 @@ -811,34 +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 - ([], imods_env) -> Right (foldr plusGlobalRdrEnv idecls_env imods_env) - (err : _, _) -> Left err } + ; 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 + mkEnv mod = do + mkTopLevEnv hsc_env mod >>= \case + Left err -> pure $ Left (mod, err) + Right env -> pure $ Right env -mkTopLevEnv :: HomePackageTable -> ModuleName -> Either String GlobalRdrEnv -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 + 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. @@ -850,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) @@ -893,7 +944,7 @@ -- | Returns all names in scope in the current interactive context getNamesInScope :: GhcMonad m => m [Name] getNamesInScope = withSession $ \hsc_env -> - return (map greMangledName (globalRdrEnvElts (icReaderEnv (hsc_IC hsc_env)))) + return $ map greName $ globalRdrEnvElts (icReaderEnv (hsc_IC hsc_env)) -- | Returns all 'RdrName's in scope in the current interactive -- context, excluding any that are internally-generated. @@ -1051,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 @@ -1062,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, @@ -1211,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 @@ -1219,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 @@ -1239,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 @@ -41,9 +53,10 @@ import GHC.Tc.Utils.Monad import GHC.Tc.Utils.TcType import GHC.Tc.Utils.TcMType -import GHC.Tc.Utils.Zonk ( zonkTcTypeToTypeX, mkEmptyZonkEnv, ZonkFlexi( RuntimeUnkFlexi ) ) +import GHC.Tc.Zonk.Type import GHC.Tc.Utils.Unify import GHC.Tc.Utils.Env +import GHC.Tc.Zonk.TcType import GHC.Types.Var import GHC.Types.Name @@ -55,11 +68,10 @@ import GHC.Types.Basic ( Boxity(..) ) import GHC.Builtin.Types.Prim import GHC.Builtin.Types -import GHC.Driver.Session +import GHC.Driver.DynFlags 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 ) @@ -75,6 +87,7 @@ import Data.Sequence (viewl, ViewL(..)) import Foreign hiding (shiftL, shiftR) import System.IO.Unsafe +import GHC.InfoProv --------------------------------------------- -- * A representation of semi evaluated Terms @@ -95,6 +108,7 @@ , ty :: RttiType , val :: ForeignHValue , bound_to :: Maybe Name -- Useful for printing + , infoprov :: Maybe InfoProv -- Provenance is printed when available } | NewtypeWrap{ -- At runtime there are no newtypes, and hence no -- newtype constructors. A NewtypeWrap is just a @@ -117,6 +131,11 @@ isFullyEvaluatedTerm RefWrap{wrapped_term=t} = isFullyEvaluatedTerm t isFullyEvaluatedTerm _ = False +-- | Gives an error if the term doesn't have subterms +expectSubTerms :: Term -> [Term] +expectSubTerms (Term { subTerms = subTerms} ) = subTerms +expectSubTerms _ = panic "expectSubTerms" + instance Outputable (Term) where ppr t | Just doc <- cPprTerm cPprTermBase t = doc | otherwise = panic "Outputable Term instance" @@ -148,7 +167,7 @@ data TermFold a = TermFold { fTerm :: TermProcessor a a , fPrim :: RttiType -> [Word] -> a , fSuspension :: ClosureType -> RttiType -> ForeignHValue - -> Maybe Name -> a + -> Maybe Name -> Maybe InfoProv -> a , fNewtypeWrap :: RttiType -> Either String DataCon -> a -> a , fRefWrap :: RttiType -> a -> a @@ -159,7 +178,7 @@ TermFoldM {fTermM :: TermProcessor a (m a) , fPrimM :: RttiType -> [Word] -> m a , fSuspensionM :: ClosureType -> RttiType -> ForeignHValue - -> Maybe Name -> m a + -> Maybe Name -> Maybe InfoProv -> m a , fNewtypeWrapM :: RttiType -> Either String DataCon -> a -> m a , fRefWrapM :: RttiType -> a -> m a @@ -168,7 +187,7 @@ foldTerm :: TermFold a -> Term -> a foldTerm tf (Term ty dc v tt) = fTerm tf ty dc v (map (foldTerm tf) tt) foldTerm tf (Prim ty v ) = fPrim tf ty v -foldTerm tf (Suspension ct ty v b) = fSuspension tf ct ty v b +foldTerm tf (Suspension ct ty v b i) = fSuspension tf ct ty v b i foldTerm tf (NewtypeWrap ty dc t) = fNewtypeWrap tf ty dc (foldTerm tf t) foldTerm tf (RefWrap ty t) = fRefWrap tf ty (foldTerm tf t) @@ -176,7 +195,7 @@ foldTermM :: Monad m => TermFoldM m a -> Term -> m a foldTermM tf (Term ty dc v tt) = mapM (foldTermM tf) tt >>= fTermM tf ty dc v foldTermM tf (Prim ty v ) = fPrimM tf ty v -foldTermM tf (Suspension ct ty v b) = fSuspensionM tf ct ty v b +foldTermM tf (Suspension ct ty v b i) = fSuspensionM tf ct ty v b i foldTermM tf (NewtypeWrap ty dc t) = foldTermM tf t >>= fNewtypeWrapM tf ty dc foldTermM tf (RefWrap ty t) = foldTermM tf t >>= fRefWrapM tf ty @@ -192,8 +211,8 @@ mapTermType :: (RttiType -> Type) -> Term -> Term mapTermType f = foldTerm idTermFold { fTerm = \ty dc hval tt -> Term (f ty) dc hval tt, - fSuspension = \ct ty hval n -> - Suspension ct (f ty) hval n, + fSuspension = \ct ty hval n i -> + Suspension ct (f ty) hval n i, fNewtypeWrap= \ty dc t -> NewtypeWrap (f ty) dc t, fRefWrap = \ty t -> RefWrap (f ty) t} @@ -201,8 +220,8 @@ mapTermTypeM f = foldTermM TermFoldM { fTermM = \ty dc hval tt -> f ty >>= \ty' -> return $ Term ty' dc hval tt, fPrimM = (return.) . Prim, - fSuspensionM = \ct ty hval n -> - f ty >>= \ty' -> return $ Suspension ct ty' hval n, + fSuspensionM = \ct ty hval n i -> + f ty >>= \ty' -> return $ Suspension ct ty' hval n i, fNewtypeWrapM= \ty dc t -> f ty >>= \ty' -> return $ NewtypeWrap ty' dc t, fRefWrapM = \ty t -> f ty >>= \ty' -> return $ RefWrap ty' t} @@ -210,7 +229,7 @@ termTyCoVars = foldTerm TermFold { fTerm = \ty _ _ tt -> tyCoVarsOfType ty `unionVarSet` concatVarEnv tt, - fSuspension = \_ ty _ _ -> tyCoVarsOfType ty, + fSuspension = \_ ty _ _ _ -> tyCoVarsOfType ty, fPrim = \ _ _ -> emptyVarSet, fNewtypeWrap= \ty _ t -> tyCoVarsOfType ty `unionVarSet` t, fRefWrap = \ty t -> tyCoVarsOfType ty `unionVarSet` t} @@ -268,8 +287,24 @@ ppr_termM1 :: Monad m => Term -> m SDoc ppr_termM1 Prim{valRaw=words, ty=ty} = return $ repPrim (tyConAppTyCon ty) words -ppr_termM1 Suspension{ty=ty, bound_to=Nothing} = - return (char '_' <+> whenPprDebug (dcolon <> pprSigmaType ty)) +ppr_termM1 Suspension{ty=ty, bound_to=Nothing, infoprov=mipe} = + return $ hcat $ +    [ char '_' +    , whenPprDebug $ + space <> + dcolon <> + pprSigmaType ty +    ] ++ +    [ whenPprDebug $ + space <> + char '<' <> + text (ipSrcFile ipe) <> + char ':' <> + text (ipSrcSpan ipe) <> + char '>' +    | Just ipe <- [mipe] + , not $ null $ ipSrcFile ipe +    ] ppr_termM1 Suspension{ty=ty, bound_to=Just n} | otherwise = return$ parens$ ppr n <> dcolon <> pprSigmaType ty ppr_termM1 Term{} = panic "ppr_termM1 - Term" @@ -321,8 +356,8 @@ cPprTermBase y = [ ifTerm (isTupleTy.ty) (\_p -> liftM (parens . hcat . punctuate comma) . mapM (y (-1)) - . subTerms) - , ifTerm (\t -> isTyCon listTyCon (ty t) && subTerms t `lengthIs` 2) + . expectSubTerms) + , ifTerm (\t -> isTyCon listTyCon (ty t) && expectSubTerms t `lengthIs` 2) ppr_list , ifTerm' (isTyCon intTyCon . ty) ppr_int , ifTerm' (isTyCon charTyCon . ty) ppr_char @@ -478,22 +513,6 @@ | t == int64PrimTyCon = text $ show (build x :: Int64) | t == word64PrimTyCon = text $ show (build x :: Word64) | t == addrPrimTyCon = text $ show (nullPtr `plusPtr` build x) - | t == stablePtrPrimTyCon = text "" - | t == stableNamePrimTyCon = text "" - | t == statePrimTyCon = text "" - | t == proxyPrimTyCon = text "" - | t == realWorldTyCon = text "" - | t == threadIdPrimTyCon = text "" - | t == weakPrimTyCon = text "" - | t == arrayPrimTyCon = text "" - | t == smallArrayPrimTyCon = text "" - | t == byteArrayPrimTyCon = text "" - | t == mutableArrayPrimTyCon = text "" - | t == smallMutableArrayPrimTyCon = text "" - | t == mutableByteArrayPrimTyCon = text "" - | t == mutVarPrimTyCon = text "" - | t == mVarPrimTyCon = text "" - | t == tVarPrimTyCon = text "" | otherwise = char '<' <> ppr t <> char '>' where build ww = unsafePerformIO $ withArray ww (peek . castPtr) -- This ^^^ relies on the representation of Haskell heap values being @@ -672,7 +691,7 @@ -- Apply the *reverse* substitution in-place to any un-filled-in -- meta tyvars. This recovers the original debugger-world variable -- unless it has been refined by new information from the heap -applyRevSubst pairs = liftTcM (mapM_ do_pair pairs) +applyRevSubst pairs = liftTcM (liftZonkM $ mapM_ do_pair pairs) where do_pair (tc_tv, rtti_tv) = do { tc_ty <- zonkTcTyVar tc_tv @@ -735,7 +754,7 @@ when (check1 old_tvs) (traceTR (text "check1 passed") >> addConstraint my_ty old_ty') term <- go max_depth my_ty old_ty hval - new_ty <- zonkTcType (termType term) + new_ty <- liftTcM $ liftZonkM $ zonkTcType (termType term) if isMonomorphic new_ty || check2 new_ty old_ty then do traceTR (text "check2 passed") @@ -773,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 @@ -797,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 @@ -855,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 @@ -869,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 @@ -885,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 @@ -904,8 +934,8 @@ (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) @@ -923,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 @@ -944,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 ] @@ -967,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 @@ -1012,11 +1042,11 @@ my_ty <- newOpenVar when (check1 old_tvs) (traceTR (text "check1 passed") >> addConstraint my_ty old_ty') - search (isMonomorphic `fmap` zonkTcType my_ty) + search (isMonomorphic `fmap` liftZonkM (zonkTcType my_ty)) (\(ty,a) -> go ty a) (Seq.singleton (my_ty, hval)) max_depth - new_ty <- zonkTcType my_ty + new_ty <- liftZonkM $ zonkTcType my_ty if isMonomorphic new_ty || check2 new_ty old_ty then do traceTR (text "check2 passed" <+> ppr old_ty $$ ppr new_ty) @@ -1109,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) @@ -1386,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` @@ -1397,8 +1427,8 @@ zonkRttiType :: TcType -> TcM Type -- Zonk the type, replacing any unbound Meta tyvars -- by RuntimeUnk skolems, safely out of Meta-tyvar-land -zonkRttiType ty= do { ze <- mkEmptyZonkEnv RuntimeUnkFlexi - ; zonkTcTypeToTypeX ze ty } +zonkRttiType ty + = initZonkEnv RuntimeUnkFlexi $ zonkTcTypeToTypeX ty -------------------------------------------------------------------------------- -- Restore Class predicates out of a representation type diff --git a/GHC/Runtime/Interpreter.hs b/GHC/Runtime/Interpreter.hs --- a/GHC/Runtime/Interpreter.hs +++ b/GHC/Runtime/Interpreter.hs @@ -1,8 +1,6 @@ {-# LANGUAGE CPP #-} -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TupleSections #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} -- | Interacting with the iserv interpreter, whether it is running on an -- external process or in the current process. @@ -11,7 +9,6 @@ ( module GHC.Runtime.Interpreter.Types -- * High-level interface to the interpreter - , BCOOpts (..) , evalStmt, EvalStatus_(..), EvalStatus, EvalResult(..), EvalExpr(..) , resumeStmt , abandonStmt @@ -24,19 +21,22 @@ , mkCostCentres , costCentreStackInfo , newBreakArray - , newModuleName , storeBreakpoint , breakpointStatus , getBreakpointVar , getClosure + , whereFrom , getModBreaks + , readIModBreaks + , readIModBreaksMaybe + , readIModModBreaks , seqHValue - , interpreterDynamic - , interpreterProfiled + , evalBreakpointToId -- * The object-code linker , initObjLinker , lookupSymbol + , lookupSymbolInDLL , lookupClosure , loadDLL , loadArchive @@ -47,84 +47,79 @@ , resolveObjs , findSystemLibrary - -- * Lower-level API using messages - , interpCmd, Message(..), withIServ, withIServ_ + , interpCmd + , withExtInterp + , withExtInterpStatus + , withIServ + , withJSInterp , stopInterp - , iservCall, readIServ, writeIServ , purgeLookupSymbolCache + , freeReallyRemoteRef , freeHValueRefs , mkFinalizedHValue , wormhole, wormholeRef , fromEvalResult + + -- * Reexport for convenience + , Message (..) + , module GHC.Runtime.Interpreter.Process ) where import GHC.Prelude -import GHC.IO (catchException) - 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 import Control.Monad import Control.Monad.IO.Class -import Control.Monad.Catch as MC (mask, onException) +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.Exit -import GHC.IO.Handle.Types (Handle) -#if defined(mingw32_HOST_OS) -import Foreign.C -import GHC.IO.Handle.FD (fdToHandle) -# if defined(__IO_MANAGER_WINIO__) -import GHC.IO.SubSystem (()) -import GHC.IO.Handle.Windows (handleToHANDLE) -import GHC.Event.Windows (associateHandle') -# endif -#else -import System.Posix as Posix -#endif 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 @@ -162,22 +157,22 @@ - implementation of Template Haskell (GHCi.TH) - a few other things needed to run interpreted code -- top-level iserv directory, containing the codefor the external - server. This is a fairly simple wrapper, most of the functionality +- top-level iserv directory, containing the code for the external + server. This is a fairly simple wrapper, most of the functionality is provided by modules in libraries/ghci. - This module which provides the interface to the server used by the rest of GHC. -GHC works with and without -fexternal-interpreter. With the flag, all -interpreted code is run by the iserv binary. Without the flag, +GHC works with and without -fexternal-interpreter. With the flag, all +interpreted code is run by the iserv binary. Without the flag, interpreted code is run in the same process as GHC. Things that do not work with -fexternal-interpreter ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ dynCompileExpr cannot work, because we have no way to run code of an -unknown type in the remote process. This API fails with an error +unknown type in the remote process. This API fails with an error message if it is used with -fexternal-interpreter. Other Notes on Remote GHCi @@ -199,11 +194,23 @@ #if defined(HAVE_INTERNAL_INTERPRETER) InternalInterp -> run msg -- Just run it directly #endif - ExternalInterp c i -> withIServ_ c i $ \iserv -> + ExternalInterp ext -> withExtInterp ext $ \inst -> uninterruptibleMask_ $ -- Note [uninterruptibleMask_ and interpCmd] - iservCall iserv msg + sendMessage inst msg +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] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -- If we receive an async exception, such as ^C, while communicating @@ -217,38 +224,57 @@ -- Overloaded because this is used from TcM as well as IO. withIServ :: (ExceptionMonad m) - => IServConfig -> IServ -> (IServInstance -> m (IServInstance, a)) -> m a -withIServ conf (IServ mIServState) action = - MC.mask $ \restore -> do - state <- liftIO $ takeMVar mIServState + => IServ -> (ExtInterpInstance () -> m a) -> m a +withIServ (ExtInterpState cfg mstate) action = do + inst <- spawnInterpMaybe cfg spawnIServ mstate + action inst - iserv <- case state of - -- start the external iserv process if we haven't done so yet - IServPending -> - liftIO (spawnIServ conf) - `MC.onException` (liftIO $ putMVar mIServState state) +-- | Spawn JS interpreter if it isn't already running and execute the given action +-- +-- Update the interpreter state. +withJSInterp :: ExceptionMonad m => JSInterp -> (ExtInterpInstance JSInterpExtra -> m a) -> m a +withJSInterp (ExtInterpState cfg mstate) action = do + inst <- spawnInterpMaybe cfg spawnJSInterp mstate + action inst - IServRunning inst -> return 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. +-- +-- This function is generic to support both the native external interpreter and +-- the JS one. +spawnInterpMaybe :: ExceptionMonad m => cfg -> (cfg -> IO (ExtInterpInstance d)) -> ExtInterpStatusVar d -> m (ExtInterpInstance d) +spawnInterpMaybe cfg spawn mstatus = do + inst <- liftIO $ modifyMVarMasked mstatus $ \case + -- start the external iserv process if we haven't done so yet + InterpPending -> do + inst <- spawn cfg + pure (InterpRunning inst, inst) - let iserv' = iserv{ iservPendingFrees = [] } + InterpRunning inst -> do + pure (InterpRunning inst, inst) - (iserv'',a) <- (do - -- free any ForeignHValues that have been garbage collected. - liftIO $ when (not (null (iservPendingFrees iserv))) $ - iservCall iserv (FreeHValueRefs (iservPendingFrees iserv)) - -- run the inner action - restore $ action iserv') - `MC.onException` (liftIO $ putMVar mIServState (IServRunning iserv')) - liftIO $ putMVar mIServState (IServRunning iserv'') - return a + -- free any ForeignRef that have been garbage collected. + pending_frees <- liftIO $ swapMVar (instPendingFrees inst) [] + liftIO $ when (not (null (pending_frees))) $ + sendMessage inst (FreeHValueRefs pending_frees) -withIServ_ - :: (MonadIO m, ExceptionMonad m) - => IServConfig -> IServ -> (IServInstance -> m a) -> m a -withIServ_ conf iserv action = withIServ conf iserv $ \inst -> - (inst,) <$> action inst + -- run the inner action + pure inst +withExtInterpMaybe + :: (ExceptionMonad m) + => ExtInterp -> (forall d. Maybe (ExtInterpInstance d) -> m a) -> m a +withExtInterpMaybe ext action = withExtInterpStatus ext $ \mstate -> do + liftIO (readMVar mstate) >>= \case + InterpPending {} -> action Nothing -- already shut down or never launched + InterpRunning inst -> action (Just inst) + -- ----------------------------------------------------------------------------- -- Wrappers around messages @@ -293,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 @@ -329,37 +355,10 @@ mkCostCentres interp mod ccs = interpCmd interp (MkCostCentres mod ccs) -newtype BCOOpts = BCOOpts - { bco_n_jobs :: Int -- ^ Number of parallel jobs doing BCO serialization - } - -- | Create a set of BCOs that may be mutually recursive. -createBCOs :: Interp -> BCOOpts -> [ResolvedBCO] -> IO [HValueRef] -createBCOs interp opts rbcos = do - let n_jobs = bco_n_jobs opts - -- Serializing ResolvedBCO is expensive, so if we support doing it in parallel - if (n_jobs == 1) - then - interpCmd interp (CreateBCOs [runPut (put rbcos)]) - else do - old_caps <- getNumCapabilities - if old_caps == n_jobs - then void $ evaluate puts - else bracket_ (setNumCapabilities n_jobs) - (setNumCapabilities old_caps) - (void $ evaluate puts) - 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 +createBCOs :: Interp -> [ResolvedBCO] -> IO [HValueRef] +createBCOs interp rbcos = do + interpCmd interp (CreateBCOs rbcos) addSptEntry :: Interp -> Fingerprint -> ForeignHValue -> IO () addSptEntry interp fpr ref = @@ -375,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 -> @@ -401,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 = @@ -408,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) -- ----------------------------------------------------------------------------- @@ -448,58 +462,109 @@ 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 -> 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))) - ExternalInterp c i -> withIServ c i $ \iserv -> 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. - let cache = iservLookupSymbolCache iserv - case lookupUFM cache str of - Just p -> return (iserv, Just p) - Nothing -> do - m <- uninterruptibleMask_ $ - iservCall iserv (LookupSymbol (unpackFS str)) - case m of - Nothing -> return (iserv, Nothing) - Just r -> do - let p = fromRemotePtr r - cache' = addToUFM cache str p - iserv' = iserv {iservLookupSymbolCache = cache'} - return (iserv', Just p) +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 (interpSymbolToCLabel str))) +#endif + ExternalInterp ext -> case ext of + ExtIServ i -> withIServ i $ \inst -> fmap fromRemotePtr <$> do + uninterruptibleMask_ $ + 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))) -purgeLookupSymbolCache :: Interp -> IO () -purgeLookupSymbolCache interp = case interpInstance interp of -#if defined(HAVE_INTERNAL_INTERPRETER) - InternalInterp -> pure () -#endif - ExternalInterp _ (IServ mstate) -> - modifyMVar_ mstate $ \state -> pure $ case state of - IServPending -> state - IServRunning iserv -> IServRunning - (iserv { iservLookupSymbolCache = emptyUFM }) +-- | 'withSymbolCache' tries to find a symbol in the 'interpLookupSymbolCache' +-- which maps symbols to the address where they are loaded. +-- When there's a cache hit we simply return the cached address, when there is +-- a miss we run the action which determines the symbol's address and populate +-- the cache with the answer. +withSymbolCache :: Interp + -> InterpSymbol s + -- ^ The symbol we are looking up in the cache + -> IO (Maybe (Ptr ())) + -- ^ An action which determines the address of the symbol we + -- are looking up in the cache, which is run if there is a + -- cache miss. The result will be cached. + -> IO (Maybe (Ptr ())) +withSymbolCache interp str determine_addr = 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. + -- + -- 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. + 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 + updateInterpSymbolCache str (interpSymbolCache interp) p + return maddr +purgeLookupSymbolCache :: Interp -> IO () +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 -- an absolute pathname to the file, or a relative filename -- (e.g. "libfoo.so" or "foo.dll"). In the latter case, loadDLL -- searches the standard locations for the appropriate library. --- --- Returns: --- --- Nothing => success --- Just err_msg => failure -loadDLL :: Interp -> String -> IO (Maybe String) +loadDLL :: Interp -> String -> IO (Either String (RemotePtr LoadedDLL)) loadDLL interp str = interpCmd interp (LoadDLL str) loadArchive :: Interp -> String -> IO () @@ -537,133 +602,51 @@ findSystemLibrary :: Interp -> String -> IO (Maybe String) findSystemLibrary interp str = interpCmd interp (FindSystemLibrary str) - -- ----------------------------------------------------------------------------- --- Raw calls and messages - --- | Send a 'Message' and receive the response from the iserv process -iservCall :: Binary a => IServInstance -> Message a -> IO a -iservCall iserv msg = - remoteCall (iservPipe iserv) msg - `catchException` \(e :: SomeException) -> handleIServFailure iserv e - --- | Read a value from the iserv process -readIServ :: IServInstance -> Get a -> IO a -readIServ iserv get = - readPipe (iservPipe iserv) get - `catchException` \(e :: SomeException) -> handleIServFailure iserv e - --- | Send a value to the iserv process -writeIServ :: IServInstance -> Put -> IO () -writeIServ iserv put = - writePipe (iservPipe iserv) put - `catchException` \(e :: SomeException) -> handleIServFailure iserv e - -handleIServFailure :: IServInstance -> SomeException -> IO a -handleIServFailure iserv e = do - let proc = iservProcess iserv - ex <- getProcessExitCode proc - case ex of - Just (ExitFailure n) -> - throwIO (InstallationError ("ghc-iserv terminated (" ++ show n ++ ")")) - _ -> do - terminateProcess proc - _ <- waitForProcess proc - throw e +-- IServ specific calls and messages -- | Spawn an external interpreter -spawnIServ :: IServConfig -> IO IServInstance +spawnIServ :: IServConfig -> IO (ExtInterpInstance ()) spawnIServ conf = do iservConfTrace conf let createProc = fromMaybe (\cp -> do { (_,_,_,ph) <- createProcess cp ; return ph }) (iservConfHook conf) (ph, rh, wh) <- runWithPipes createProc (iservConfProgram conf) + [] (iservConfOpts conf) - lo_ref <- newIORef Nothing - return $ IServInstance - { iservPipe = Pipe { pipeRead = rh, pipeWrite = wh, pipeLeftovers = lo_ref } - , iservProcess = ph - , iservLookupSymbolCache = emptyUFM - , iservPendingFrees = [] - } + interpPipe <- mkPipeFromHandles rh wh + lock <- newMVar () + let process = InterpProcess + { interpHandle = ph + , interpPipe + , interpLock = lock + } + pending_frees <- newMVar [] + let inst = ExtInterpInstance + { instProcess = process + , instPendingFrees = pending_frees + , instExtra = () + } + pure inst + -- | Stop the interpreter stopInterp :: Interp -> IO () stopInterp interp = case interpInstance interp of #if defined(HAVE_INTERNAL_INTERPRETER) InternalInterp -> pure () #endif - ExternalInterp _ (IServ mstate) -> + ExternalInterp ext -> withExtInterpStatus ext $ \mstate -> do MC.mask $ \_restore -> modifyMVar_ mstate $ \state -> do case state of - IServPending -> pure state -- already stopped - IServRunning i -> do - ex <- getProcessExitCode (iservProcess i) + InterpPending -> pure state -- already stopped + InterpRunning i -> do + ex <- getProcessExitCode (interpHandle (instProcess i)) if isJust ex then pure () - else iservCall i Shutdown - pure IServPending - -runWithPipes :: (CreateProcess -> IO ProcessHandle) - -> FilePath -> [String] -> IO (ProcessHandle, Handle, Handle) -#if defined(mingw32_HOST_OS) -foreign import ccall "io.h _close" - c__close :: CInt -> IO CInt - -foreign import ccall unsafe "io.h _get_osfhandle" - _get_osfhandle :: CInt -> IO CInt - -runWithPipesPOSIX :: (CreateProcess -> IO ProcessHandle) - -> FilePath -> [String] -> IO (ProcessHandle, Handle, Handle) -runWithPipesPOSIX createProc prog opts = do - (rfd1, wfd1) <- createPipeFd -- we read on rfd1 - (rfd2, wfd2) <- createPipeFd -- we write on wfd2 - wh_client <- _get_osfhandle wfd1 - rh_client <- _get_osfhandle rfd2 - let args = show wh_client : show rh_client : opts - ph <- createProc (proc prog args) - rh <- mkHandle rfd1 - wh <- mkHandle wfd2 - return (ph, rh, wh) - where mkHandle :: CInt -> IO Handle - mkHandle fd = (fdToHandle fd) `Ex.onException` (c__close fd) - -# if defined (__IO_MANAGER_WINIO__) -runWithPipesNative :: (CreateProcess -> IO ProcessHandle) - -> FilePath -> [String] -> IO (ProcessHandle, Handle, Handle) -runWithPipesNative createProc prog opts = do - (rh, wfd1) <- createPipe -- we read on rfd1 - (rfd2, wh) <- createPipe -- we write on wfd2 - wh_client <- handleToHANDLE wfd1 - rh_client <- handleToHANDLE rfd2 - -- Associate the handle with the current manager - -- but don't touch the ones we're passing to the child - -- since it needs to register the handle with its own manager. - associateHandle' =<< handleToHANDLE rh - associateHandle' =<< handleToHANDLE wh - let args = show wh_client : show rh_client : opts - ph <- createProc (proc prog args) - return (ph, rh, wh) - -runWithPipes = runWithPipesPOSIX runWithPipesNative -# else -runWithPipes = runWithPipesPOSIX -# endif -#else -runWithPipes createProc prog opts = do - (rfd1, wfd1) <- Posix.createPipe -- we read on rfd1 - (rfd2, wfd2) <- Posix.createPipe -- we write on wfd2 - setFdOption rfd1 CloseOnExec True - setFdOption wfd2 CloseOnExec True - let args = show wfd1 : show rfd2 : opts - ph <- createProc (proc prog args) - closeFd wfd1 - closeFd rfd2 - rh <- fdToHandle rfd1 - wh <- fdToHandle wfd2 - return (ph, rh, wh) -#endif + else sendMessage i Shutdown + pure InterpPending -- ----------------------------------------------------------------------------- {- Note [External GHCi pointers] @@ -680,10 +663,10 @@ RemoteRef --------- -RemoteRef is a StablePtr to a heap-resident value. When --fexternal-interpreter is used, this value resides in the external -process's heap. RemoteRefs are mostly used to send pointers in -messages between GHC and iserv. +RemoteRef is a StablePtr to a heap-resident value. When -fexternal-interpreter +or the JS interpreter is used, this value resides in the external process's +heap. RemoteRefs are mostly used to send pointers in messages between GHC and +iserv. A RemoteRef must be explicitly freed when no longer required, using freeHValueRefs, or by attaching a finalizer with mkForeignHValue. @@ -709,20 +692,18 @@ -- 'RemoteRef' when it is no longer referenced. mkFinalizedHValue :: Interp -> RemoteRef a -> IO (ForeignRef a) mkFinalizedHValue interp rref = do - let hvref = toHValueRef rref - - free <- case interpInstance interp of + case interpInstance interp of #if defined(HAVE_INTERNAL_INTERPRETER) - InternalInterp -> return (freeRemoteRef hvref) + InternalInterp -> mkForeignRef rref (freeRemoteRef rref) #endif - ExternalInterp _ (IServ i) -> return $ modifyMVar_ i $ \state -> - case state of - IServPending {} -> pure state -- already shut down - IServRunning inst -> do - let !inst' = inst {iservPendingFrees = hvref:iservPendingFrees inst} - pure (IServRunning inst') + ExternalInterp ext -> withExtInterpMaybe ext $ \case + Nothing -> mkForeignRef rref (pure ()) -- nothing to do, interpreter already stopped + Just inst -> mkForeignRef rref (freeReallyRemoteRef inst rref) - mkForeignRef rref free +freeReallyRemoteRef :: ExtInterpInstance d -> RemoteRef a -> IO () +freeReallyRemoteRef inst rref = + -- add to the list of HValues to free + modifyMVar_ (instPendingFrees inst) (\xs -> pure (castRemoteRef rref : xs)) freeHValueRefs :: Interp -> [HValueRef] -> IO () @@ -746,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 @@ -753,31 +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 c _ -> iservConfProfiled c - --- | Interpreter uses Dynamic way -interpreterDynamic :: Interp -> Bool -interpreterDynamic interp = case interpInstance interp of -#if defined(HAVE_INTERNAL_INTERPRETER) - InternalInterp -> hostIsDynamic -#endif - ExternalInterp c _ -> iservConfDynamic c diff --git a/GHC/Runtime/Interpreter/JS.hs b/GHC/Runtime/Interpreter/JS.hs new file mode 100644 --- /dev/null +++ b/GHC/Runtime/Interpreter/JS.hs @@ -0,0 +1,421 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE LambdaCase #-} + +-- | JavaScript interpreter +-- +-- See Note [The JS interpreter] +-- +module GHC.Runtime.Interpreter.JS + ( spawnJSInterp + , jsLinkRts + , jsLinkInterp + , jsLinkObject + , jsLinkObjects + , jsLoadFile + , jsRunServer + -- * Reexported for convenience + , mkExportedModFuns + ) +where + +import GHC.Prelude +import GHC.Runtime.Interpreter.Types +import GHC.Runtime.Interpreter.Process +import GHC.Runtime.Utils +import GHCi.Message + +import GHC.StgToJS.Linker.Types +import GHC.StgToJS.Linker.Linker +import GHC.StgToJS.Types +import GHC.StgToJS.Object + +import GHC.Unit.Env +import GHC.Unit.Types +import GHC.Unit.State + +import GHC.Utils.Logger +import GHC.Utils.TmpFs +import GHC.Utils.Panic +import GHC.Utils.Error (logInfo) +import GHC.Utils.Outputable (text) +import GHC.Data.FastString + +import Control.Concurrent +import Control.Monad + +import System.Process +import System.IO +import System.FilePath + +import Data.IORef +import qualified Data.Set as Set +import qualified Data.ByteString as B + +import Foreign.C.String + + +-- Note [The JS interpreter] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~ +-- +-- The JS interpreter works as follows: +-- +-- ghc-interp.js is a simple JS script used to bootstrap the external +-- interpreter server (iserv) that is written in Haskell. This script waits for +-- commands on stdin: +-- +-- LOAD foo.js +-- +-- load a JS file in the current JS environment +-- +-- RUN_SERVER ghci_unit_id +-- +-- execute h$main(h$ghci_unit_idZCGHCiziServerzidefaultServer), +-- the entry point of the interpreter server +-- +-- On the GHC side, when we need the interpreter we do the following: +-- +-- 1. spawn nodejs with $topdir/ghc-interp.js script +-- 2. link the JS rts and send a LOAD command to load it +-- 3. link iserv (i.e. use GHCi.Server.defaultServer as root) and LOAD it +-- 4. send a RUN_SERVER command to execute the JS iserv +-- +-- From this moment on, everything happens as with the native iserv, using a +-- pipe for communication, with the following differences: +-- +-- - the JS iserv only supports the LoadObj linking command which has been +-- repurposed to load a JS source file. The JS iserv doesn't deal with +-- libraries (.a) and with object files (.o). The linker state is maintained on +-- the GHC side and GHC only sends the appropriate chunks of JS code to link. +-- +-- - the JS iserv doesn't support ByteCode (i.e. it doesn't support CreateBCOs +-- messages). JS iserv clients should use the usual JS compilation pipeline and +-- send JS code instead. See GHC.Driver.Main.hscCompileCoreExpr for an example. +-- +-- GHC keeps track of JS blocks (JS unit of linking corresponding to top-level +-- binding groups) that have already been linked by the JS interpreter. It only +-- links new ones when necessary. +-- +-- Note that the JS interpreter isn't subject to staging issues: we can use it +-- in a Stage1 GHC. +-- + +--------------------------------------------------------- +-- Running node +--------------------------------------------------------- + +-- | Start NodeJS interactively with "ghc-interp.js" script loaded in +startTHRunnerProcess :: FilePath -> NodeJsSettings -> IO (Handle,InterpProcess) +startTHRunnerProcess interp_js settings = do + interp_in <- newIORef undefined + + let createProc cp = do + let cp' = cp + { std_in = CreatePipe + , std_out = Inherit + , std_err = Inherit + } + (mb_in, _mb_out, _mb_err, hdl) <- createProcess cp' + -- we can't directly return stdin for the process given the current + -- implementation of runWithPipes. So we just use an IORef for this... + case mb_in of + Nothing -> panic "startTHRunnerProcess: expected stdin for interpreter" + Just i -> writeIORef interp_in i + return hdl + + (hdl, rh, wh) <- runWithPipes createProc (nodeProgram settings) + [interp_js] + (nodeExtraArgs settings) + std_in <- readIORef interp_in + + interpPipe <- mkPipeFromHandles rh wh + lock <- newMVar () + let proc = InterpProcess + { interpHandle = hdl + , interpPipe + , interpLock = lock + } + pure (std_in, proc) + +-- | Spawn a JS interpreter +-- +-- Run NodeJS with "ghc-interp.js" loaded in. Then load GHCi.Server and its deps +-- (including the rts) and run GHCi.Server.defaultServer. +spawnJSInterp :: JSInterpConfig -> IO (ExtInterpInstance JSInterpExtra) +spawnJSInterp cfg = do + let logger= jsInterpLogger cfg + when (logVerbAtLeast logger 2) $ + logInfo logger (text "Spawning JS interpreter") + + let tmpfs = jsInterpTmpFs cfg + tmp_dir = jsInterpTmpDir cfg + logger = jsInterpLogger cfg + codegen_cfg = jsInterpCodegenCfg cfg + unit_env = jsInterpUnitEnv cfg + finder_opts = jsInterpFinderOpts cfg + finder_cache = jsInterpFinderCache cfg + + (std_in, proc) <- startTHRunnerProcess (jsInterpScript cfg) (jsInterpNodeConfig cfg) + + js_state <- newMVar (JSState + { jsLinkState = emptyLinkPlan + , jsServerStarted = False + }) + + -- get the unit-id of the ghci package. We need this to load the + -- interpreter code. + 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 + + let extra = JSInterpExtra + { instStdIn = std_in + , instJSState = js_state + , instFinderCache = finder_cache + , instFinderOpts = finder_opts + , instGhciUnitId = ghci_unit_id + } + + pending_frees <- newMVar [] + let inst = ExtInterpInstance + { instProcess = proc + , instPendingFrees = pending_frees + , 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 + + -- link interpreter and its deps + jsLinkInterp logger tmpfs tmp_dir codegen_cfg unit_env inst + + -- run interpreter main loop + jsRunServer inst + + pure inst + + + +--------------------------------------------------------- +-- Interpreter commands +--------------------------------------------------------- + +-- | Link JS RTS +jsLinkRts :: Logger -> TmpFs -> TempDir -> StgToJSConfig -> UnitEnv -> ExtInterpInstance JSInterpExtra -> IO () +jsLinkRts logger tmpfs tmp_dir cfg unit_env inst = do + let link_cfg = JSLinkConfig + { lcNoStats = True -- we don't need the stats + , lcNoRts = False -- we need the RTS + , lcCombineAll = False -- we don't need the combined all.js, we'll link each part independently below + , 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 `ghc-internal`, etc.) + let link_spec = LinkSpec + { lks_unit_ids = [rtsUnitId, ghcInternalUnitId] + , lks_obj_root_filter = const False + , lks_extra_roots = mempty + , lks_objs_hs = mempty + , lks_objs_js = mempty + , lks_objs_cc = mempty + } + + let finder_opts = instFinderOpts (instExtra inst) + finder_cache = instFinderCache (instExtra inst) + + 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 () +jsLinkInterp logger tmpfs tmp_dir cfg unit_env inst = do + + let link_cfg = JSLinkConfig + { lcNoStats = True -- we don't need the stats + , lcNoRts = True -- we don't need the RTS + , lcCombineAll = False -- we don't need the combined all.js, we'll link each part independently below + , 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 + + let ghci_unit_id = instGhciUnitId (instExtra inst) + + -- compute unit dependencies of ghc_unit_id + 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] + + -- indicate that our root function is GHCi.Server.defaultServer + let root_deps = Set.fromList $ mkExportedFuns ghci_unit_id (fsLit "GHCi.Server") [fsLit "defaultServer"] + + -- link the interpreter and its dependencies + let link_spec = LinkSpec + { lks_unit_ids = units + , lks_obj_root_filter = is_root + , lks_extra_roots = root_deps + , lks_objs_hs = mempty + , lks_objs_js = mempty + , lks_objs_cc = mempty + } + + let finder_cache = instFinderCache (instExtra inst) + finder_opts = instFinderOpts (instExtra inst) + + 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 +jsLinkObjects :: Logger -> TmpFs -> TempDir -> StgToJSConfig -> UnitEnv -> ExtInterpInstance JSInterpExtra -> [FilePath] -> (ExportedFun -> Bool) -> IO () +jsLinkObjects logger tmpfs tmp_dir cfg unit_env inst objs is_root = do + let link_cfg = JSLinkConfig + { lcNoStats = True -- we don't need the stats + , lcNoRts = True -- we don't need the RTS (already linked) + , lcCombineAll = False -- we don't need the combined all.js, we'll link each part independently below + , 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_homeUnitState unit_env) + + -- compute dependencies + let link_spec = LinkSpec + { lks_unit_ids = units + , lks_obj_root_filter = is_root + , lks_extra_roots = mempty + , lks_objs_hs = objs + , lks_objs_js = mempty + , lks_objs_cc = mempty + } + + let finder_opts = instFinderOpts (instExtra inst) + finder_cache = instFinderCache (instExtra inst) + + 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 an object file using the given functions as roots +jsLinkObject :: Logger -> TmpFs -> TempDir -> StgToJSConfig -> UnitEnv -> ExtInterpInstance JSInterpExtra -> FilePath -> [ExportedFun] -> IO () +jsLinkObject logger tmpfs tmp_dir cfg unit_env inst obj roots = do + let is_root f = Set.member f (Set.fromList roots) + let objs = [obj] + jsLinkObjects logger tmpfs tmp_dir cfg unit_env inst objs is_root + + +-- | Link the given link plan +-- +-- Perform incremental linking by removing what is already linked from the plan +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 + ---------------------------------------------------------------- + + old_plan <- jsLinkState <$> readMVar (instJSState (instExtra inst)) + + -- compute new plan discarding what's already linked + let (diff_plan, total_plan) = incrementLinkPlan old_plan link_plan + + ---------------------------------------------------------------- + -- Generate JS code for the incremental plan + ---------------------------------------------------------------- + + tmp_out <- newTempSubDir logger tmpfs tmp_dir + 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) + -- - raw js files from tmp_out/lib.js + -- - Haskell generated JS from tmp_out/out.js + + -- We need to combine at least rts.js and lib.js for the RTS because they + -- depend on each other. We might as well combine them all, so that's what we + -- do. + let filenames + | lcNoRts link_cfg = ["lib.js", "out.js"] + | otherwise = ["rts.js", "lib.js", "out.js"] + let files = map (tmp_out ) filenames + let all_js = tmp_out "all.js" + let all_files = all_js : files + withBinaryFile all_js WriteMode $ \h -> do + let cpy i = B.readFile i >>= B.hPut h + mapM_ cpy files + + -- add files to clean + addFilesToClean tmpfs TFL_CurrentModule all_files + + ---------------------------------------------------------------- + -- Link JS code + ---------------------------------------------------------------- + + -- linking JS code depends on the phase we're in: + -- - during in the initialization phase, we send a LoadFile message to the + -- JS server; + -- - once the Haskell server is started, we send a LoadObj message to the + -- Haskell server. + server_started <- jsServerStarted <$> readMVar (instJSState (instExtra inst)) + if server_started + then sendMessageNoResponse inst $ LoadObj all_js + else jsLoadFile inst all_js + + ---------------------------------------------------------------- + -- update linker state + ---------------------------------------------------------------- + modifyMVar_ (instJSState (instExtra inst)) $ \state -> pure state { jsLinkState = total_plan } + + +-- | Send a command to the JS interpreter +jsSendCommand :: ExtInterpInstance JSInterpExtra -> String -> IO () +jsSendCommand inst cmd = send_cmd cmd + where + extra = instExtra inst + handle = instStdIn extra + send_cmd s = do + withCStringLen s \(p,n) -> hPutBuf handle p n + hFlush handle + +-- | Load a JS file in the interpreter +jsLoadFile :: ExtInterpInstance JSInterpExtra -> FilePath -> IO () +jsLoadFile inst path = jsSendCommand inst ("LOAD " ++ path ++ "\n") + +-- | Run JS server +jsRunServer :: ExtInterpInstance JSInterpExtra -> IO () +jsRunServer inst = do + let ghci_unit_id = instGhciUnitId (instExtra inst) + let zghci_unit_id = zString (zEncodeFS (unitIdFS ghci_unit_id)) + + -- Run `GHCi.Server.defaultServer` + jsSendCommand inst ("RUN_SERVER " ++ zghci_unit_id ++ "\n") + + -- indicate that the Haskell server is now started + modifyMVar_ (instJSState (instExtra inst)) $ \state -> pure state { jsServerStarted = True } diff --git a/GHC/Runtime/Interpreter/Process.hs b/GHC/Runtime/Interpreter/Process.hs new file mode 100644 --- /dev/null +++ b/GHC/Runtime/Interpreter/Process.hs @@ -0,0 +1,133 @@ +{-# LANGUAGE LambdaCase #-} +module GHC.Runtime.Interpreter.Process + ( + -- * Message API + 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 + , receiveTHMessage + ) +where + +import GHC.Prelude + +import GHC.Runtime.Interpreter.Types +import GHCi.Message + +import GHC.IO (catchException) +import GHC.Utils.Panic +import GHC.Utils.Exception as Ex + +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 = + withLock i $ writeInterpProcess (instProcess i) (putMessage m) + +-- | 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 = 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 + +-- | 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 = ensureLocked i >> writeInterpProcess (instProcess i) (put m) + +-- | Expect a value to be received (requires locked interpreter) +receiveAnyValue :: ExtInterpInstance d -> Get a -> IO a +receiveAnyValue i get = ensureLocked i >> readInterpProcess (instProcess i) get + +-- | Wait for a Template Haskell message (requires locked interpreter) +receiveTHMessage :: ExtInterpInstance d -> IO THMsg +receiveTHMessage i = ensureLocked i >> receiveAnyValue i getTHMessage + +-- ----------------------------------------------------------------------------- + +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 +callInterpProcess i msg = + remoteCall (interpPipe i) msg + `catchException` \(e :: SomeException) -> handleInterpProcessFailure i e + +-- | Read a value from the interpreter process +readInterpProcess :: InterpProcess -> Get a -> IO a +readInterpProcess i get = + readPipe (interpPipe i) get + `catchException` \(e :: SomeException) -> handleInterpProcessFailure i e + +-- | Send a value to the interpreter process +writeInterpProcess :: InterpProcess -> Put -> IO () +writeInterpProcess i put = + writePipe (interpPipe i) put + `catchException` \(e :: SomeException) -> handleInterpProcessFailure i e + +handleInterpProcessFailure :: InterpProcess -> SomeException -> IO a +handleInterpProcessFailure i e = do + let hdl = interpHandle i + ex <- getProcessExitCode hdl + case ex of + Just (ExitFailure n) -> + throwIO (InstallationError ("External interpreter terminated (" ++ show n ++ ")")) + _ -> do + terminateProcess hdl + _ <- waitForProcess hdl + throw e 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,13 +1,44 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE RecordWildCards #-} -- | Types used by the runtime interpreter module GHC.Runtime.Interpreter.Types ( Interp(..) , InterpInstance(..) - , IServ(..) - , IServInstance(..) + , InterpProcess (..) + , ExtInterp (..) + , ExtInterpStatusVar + , ExtInterpInstance (..) + , ExtInterpState (..) + , InterpStatus(..) + -- * InterpSymbolCache + , InterpSymbolCache(..) + , mkInterpSymbolCache + , lookupInterpSymbolCache + , updateInterpSymbolCache + , purgeInterpSymbolCache + , InterpSymbol(..) + , SuffixOrInterpreted(..) + , interpSymbolName + , interpSymbolSuffix + , eliminateInterpSymbol + , interpretedInterpSymbol + , interpreterProfiled + , interpreterDynamic + + -- * IServ + , IServ , IServConfig(..) - , IServState(..) + -- * JSInterp + , JSInterp + , JSInterpExtra (..) + , JSInterpConfig (..) + , JSState (..) + , NodeJsSettings (..) + , defaultNodeJsSettings + , WasmInterp + , WasmInterpConfig (..) ) where @@ -16,12 +47,24 @@ 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 ) +import System.IO +import GHC.Unit.Finder.Types (FinderCache, FinderOpts) -- | Interpreter data Interp = Interp @@ -30,27 +73,49 @@ , interpLoader :: !Loader -- ^ Interpreter loader - } + , interpSymbolCache :: !InterpSymbolCache + -- ^ LookupSymbol cache + } data InterpInstance - = ExternalInterp !IServConfig !IServ -- ^ External interpreter + = ExternalInterp !ExtInterp -- ^ External interpreter #if defined(HAVE_INTERNAL_INTERPRETER) - | InternalInterp -- ^ Internal interpreter + | InternalInterp -- ^ Internal interpreter #endif +data ExtInterp + = ExtIServ !IServ + | ExtJS !JSInterp + | ExtWasm !WasmInterp + -- | External interpreter -- -- The external interpreter is spawned lazily (on first use) to avoid slowing -- down sessions that don't require it. The contents of the MVar reflects the -- state of the interpreter (running or not). -newtype IServ = IServ (MVar IServState) +data ExtInterpState cfg details = ExtInterpState + { interpConfig :: !cfg + , interpStatus :: !(ExtInterpStatusVar details) + } --- | State of an external interpreter -data IServState - = IServPending -- ^ Not spawned yet - | IServRunning !IServInstance -- ^ Running +type ExtInterpStatusVar d = MVar (InterpStatus (ExtInterpInstance d)) +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 +data InterpStatus inst + = InterpPending -- ^ Not spawned yet + | InterpRunning !inst -- ^ Running + -- | Configuration needed to spawn an external interpreter data IServConfig = IServConfig { iservConfProgram :: !String -- ^ External program to run @@ -61,14 +126,108 @@ , iservConfTrace :: IO () -- ^ Trace action executed after spawn } --- | External interpreter instance -data IServInstance = IServInstance - { iservPipe :: !Pipe - , iservProcess :: !ProcessHandle - , iservLookupSymbolCache :: !(UniqFM FastString (Ptr ())) - , iservPendingFrees :: ![HValueRef] +-- | Common field between native external interpreter and the JS one +data ExtInterpInstance c = ExtInterpInstance + { instProcess :: {-# UNPACK #-} !InterpProcess + -- ^ External interpreter process and its pipe (communication channel) + + , instPendingFrees :: !(MVar [HValueRef]) -- ^ Values that need to be freed before the next command is sent. - -- Threads can append values to this list asynchronously (by modifying the - -- IServ state MVar). + -- Finalizers for ForeignRefs can append values to this list + -- asynchronously. + + , instExtra :: !c + -- ^ 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 +------------------------ + +data JSInterpExtra = JSInterpExtra + { instStdIn :: !Handle -- ^ Stdin for the process + , instFinderCache :: !FinderCache + , instFinderOpts :: !FinderOpts + , instJSState :: !(MVar JSState) -- ^ Mutable state + , instGhciUnitId :: !UnitId -- ^ GHCi unit-id + } + +data JSState = JSState + { jsLinkState :: !LinkPlan -- ^ Linker state of the interpreter + , jsServerStarted :: !Bool -- ^ Is the Haskell server started? + } + +-- | NodeJs configuration +data NodeJsSettings = NodeJsSettings + { nodeProgram :: FilePath -- ^ location of node.js program + , nodePath :: Maybe FilePath -- ^ value of NODE_PATH environment variable (search path for Node modules; GHCJS used to provide some) + , nodeExtraArgs :: [String] -- ^ extra arguments to pass to node.js + , nodeKeepAliveMaxMem :: Integer -- ^ keep node.js (TH, GHCJSi) processes alive if they don't use more than this + } + +defaultNodeJsSettings :: NodeJsSettings +defaultNodeJsSettings = NodeJsSettings + { nodeProgram = "node" + , nodePath = Nothing + , nodeExtraArgs = [] + , nodeKeepAliveMaxMem = 536870912 + } + + +data JSInterpConfig = JSInterpConfig + { jsInterpNodeConfig :: !NodeJsSettings -- ^ NodeJS settings + , jsInterpScript :: !FilePath -- ^ Path to "ghc-interp.js" script + , jsInterpTmpFs :: !TmpFs + , jsInterpTmpDir :: !TempDir + , jsInterpLogger :: !Logger + , jsInterpCodegenCfg :: !StgToJSConfig + , jsInterpUnitEnv :: !UnitEnv + , jsInterpFinderOpts :: !FinderOpts + , 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 @@ -23,7 +23,7 @@ import GHC.Prelude import GHC.Data.FastString -import GHC.Driver.Session +import GHC.Driver.DynFlags import GHC.Driver.Ppr import GHC.Driver.Hooks import GHC.Driver.Plugins @@ -33,34 +33,37 @@ import GHC.Runtime.Interpreter ( wormhole ) import GHC.Runtime.Interpreter.Types +import GHC.Rename.Names ( gresFromAvails ) + import GHC.Tc.Utils.Monad ( initTcInteractive, initIfaceTcRn ) import GHC.Iface.Load ( loadPluginInterface, cannotFindModule ) -import GHC.Rename.Names ( gresFromAvails ) import GHC.Builtin.Names ( pluginTyConName, frontendPluginTyConName ) import GHC.Driver.Env import GHCi.RemoteTypes ( HValue ) import GHC.Core.Type ( Type, mkTyConTy ) import GHC.Core.TyCo.Compare( eqType ) -import GHC.Core.TyCon ( TyCon ) +import GHC.Core.TyCon ( TyCon(tyConName) ) + import GHC.Types.SrcLoc ( noSrcSpan ) -import GHC.Types.Name ( Name, nameModule_maybe ) +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 ( RdrName, ImportSpec(..), ImpDeclSpec(..) - , ImpItemSpec(..), mkGlobalRdrEnv, lookupGRE_RdrName - , greMangledName, mkRdrQual ) +import GHC.Types.Name.Reader +import GHC.Types.Unique.DFM import GHC.Unit.Finder ( findPluginModule, FindResult(..) ) -import GHC.Driver.Config.Finder ( initFinderOpts ) -import GHC.Unit.Module ( Module, ModuleName ) +import GHC.Driver.Config.Diagnostic ( initIfaceMessageOpts ) +import GHC.Unit.Module ( Module, ModuleName, thisGhcUnit, GenModule(moduleUnit), IsBootInterface(NotBoot) ) import GHC.Unit.Module.ModIface import GHC.Unit.Env import GHC.Utils.Panic import GHC.Utils.Logger +import GHC.Utils.Misc ( HasDebugCallStack ) import GHC.Utils.Error import GHC.Utils.Outputable import GHC.Utils.Exception @@ -69,10 +72,33 @@ import Data.Maybe ( mapMaybe ) import Unsafe.Coerce ( unsafeCoerce ) import GHC.Linker.Types -import GHC.Types.Unique.DFM import Data.List (unzip4) +import GHC.Iface.Errors.Ppr import GHC.Driver.Monad +{- Note [Timing of plugin initialization] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Plugins needs to be initialised as soon as possible in the pipeline. This is because +driver plugins are executed immediately after being loaded, which can modify anything +in the HscEnv, including the logger and DynFlags (for example #21279). For example, +in ghc/Main.hs the logger is used almost immediately after the session has been initialised +and so if a user overwrites the logger expecting all output to go there then unless +the plugins are initialised before that point then unexpected things will happen. + +We initialise plugins in ghc/Main.hs for the main ghc executable. + +When people are using the GHC API, they also need to initialise plugins +at the highest level possible for things to work as expected. We keep +some defensive calls to plugin initialisation in functions like `load'` and `oneshot` +to catch cases where API users have not initialised their own plugins. + +In addition to this, there needs to be an initialisation call for each module +just in case the user has enabled a plugin just for that module using OPTIONS_GHC +pragma. + +-} + -- | Initialise plugins specified by the current DynFlags and update the session. initializeSessionPlugins :: GhcMonad m => m () initializeSessionPlugins = getSession >>= liftIO . initializePlugins >>= setSession @@ -94,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) @@ -176,18 +203,25 @@ Just (name, mod_iface) -> do { plugin_tycon <- forceLoadTyCon hsc_env plugin_name - ; eith_plugin <- getValueSafely hsc_env name (mkTyConTy plugin_tycon) + ; case thisGhcUnit == (moduleUnit . nameModule . tyConName) plugin_tycon of { + False -> + throwGhcExceptionIO (CmdLineError $ showSDoc dflags $ hsep + [ text "The plugin module", ppr mod_name + , text "was built with a compiler that is incompatible with the one loading it" + ]) ; + True -> + do { eith_plugin <- getValueSafely hsc_env name (mkTyConTy plugin_tycon) ; 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 , text "did not have the type" , text "GHC.Plugins.Plugin" , text "as required"]) - Right (plugin, links, pkgs) -> return (plugin, mod_iface, links, pkgs) } } } + Right (plugin, links, pkgs) -> return (plugin, mod_iface, links, pkgs) } } } } } -- | Force the interfaces for the given modules to be loaded. The 'SDoc' parameter is used @@ -303,17 +337,13 @@ -- being compiled. This was introduced by 57d6798. -- -- Need the module as well to record information in the interface file -lookupRdrNameInModuleForPlugins :: HscEnv -> ModuleName -> RdrName +lookupRdrNameInModuleForPlugins :: HasDebugCallStack + => HscEnv -> ModuleName -> RdrName -> 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 @@ -323,17 +353,22 @@ case mb_iface of Just iface -> do -- Try and find the required name in the exports - let decl_spec = ImpDeclSpec { is_mod = mod_name, 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 (Just imp_spec) (mi_exports iface)) - case lookupGRE_RdrName rdr_name env of - [gre] -> return (Just (greMangledName gre, iface)) + env = mkGlobalRdrEnv + $ gresFromAvails hsc_env (Just imp_spec) (mi_exports iface) + case lookupGRE env (LookupRdrName rdr_name (RelevantGREsFOS WantNormal)) of + [gre] -> return (Just (greName gre, iface)) [] -> return Nothing _ -> panic "lookupRdrNameInModule" Nothing -> throwCmdLineErrorS dflags $ hsep [text "Could not determine the exports of the module", ppr mod_name] - err -> throwCmdLineErrorS dflags $ cannotFindModule hsc_env mod_name err + err -> + let opts = initIfaceMessageOpts dflags + err_txt = missingInterfaceErrorDiagnostic opts + $ cannotFindModule hsc_env mod_name err + in throwCmdLineErrorS dflags err_txt where doc = text "contains a name used in an invocation of lookupRdrNameInModule" diff --git a/GHC/Runtime/Utils.hs b/GHC/Runtime/Utils.hs new file mode 100644 --- /dev/null +++ b/GHC/Runtime/Utils.hs @@ -0,0 +1,84 @@ +{-# LANGUAGE CPP #-} + +module GHC.Runtime.Utils + ( runWithPipes + ) +where + +import GHC.Prelude + +#if defined(mingw32_HOST_OS) +import Foreign.C +import GHC.IO.Handle.FD (fdToHandle) +import GHC.Utils.Exception as Ex +# if defined(__IO_MANAGER_WINIO__) +import GHC.IO.SubSystem (()) +import GHC.IO.Handle.Windows (handleToHANDLE) +import GHC.Event.Windows (associateHandle') +# endif +#else +import System.Posix as Posix +#endif +import System.Process +import System.IO + +runWithPipes :: (CreateProcess -> IO ProcessHandle) + -> FilePath -> [String] -> [String] -> IO (ProcessHandle, Handle, Handle) +#if defined(mingw32_HOST_OS) +foreign import ccall "io.h _close" + c__close :: CInt -> IO CInt + +foreign import ccall unsafe "io.h _get_osfhandle" + _get_osfhandle :: CInt -> IO CIntPtr + +runWithPipesPOSIX :: (CreateProcess -> IO ProcessHandle) + -> FilePath -> [String] -> [String] -> IO (ProcessHandle, Handle, Handle) +runWithPipesPOSIX createProc prog pre_opts opts = do + (rfd1, wfd1) <- createPipeFd -- we read on rfd1 + (rfd2, wfd2) <- createPipeFd -- we write on wfd2 + wh_client <- _get_osfhandle wfd1 + rh_client <- _get_osfhandle rfd2 + let args = pre_opts ++ (show wh_client : show rh_client : opts) + ph <- createProc (proc prog args) + rh <- mkHandle rfd1 + wh <- mkHandle wfd2 + return (ph, rh, wh) + where mkHandle :: CInt -> IO Handle + mkHandle fd = (fdToHandle fd) `Ex.onException` (c__close fd) + +# if defined (__IO_MANAGER_WINIO__) +runWithPipesNative :: (CreateProcess -> IO ProcessHandle) + -> FilePath -> [String] -> [String] -> IO (ProcessHandle, Handle, Handle) +runWithPipesNative createProc prog pre_opts opts = do + (rh, wfd1) <- createPipe -- we read on rfd1 + (rfd2, wh) <- createPipe -- we write on wfd2 + wh_client <- handleToHANDLE wfd1 + rh_client <- handleToHANDLE rfd2 + -- Associate the handle with the current manager + -- but don't touch the ones we're passing to the child + -- since it needs to register the handle with its own manager. + associateHandle' =<< handleToHANDLE rh + associateHandle' =<< handleToHANDLE wh + let args = pre_opts ++ (show wh_client : show rh_client : opts) + ph <- createProc (proc prog args) + return (ph, rh, wh) + +runWithPipes = runWithPipesPOSIX runWithPipesNative +# else +runWithPipes = runWithPipesPOSIX +# endif +#else +runWithPipes createProc prog pre_opts opts = do + (rfd1, wfd1) <- Posix.createPipe -- we read on rfd1 + (rfd2, wfd2) <- Posix.createPipe -- we write on wfd2 + setFdOption rfd1 CloseOnExec True + setFdOption wfd2 CloseOnExec True + let args = pre_opts ++ (show wfd1 : show rfd2 : opts) + ph <- createProc (proc prog args) + closeFd wfd1 + closeFd rfd2 + rh <- fdToHandle rfd1 + wh <- fdToHandle wfd2 + return (ph, rh, wh) +#endif + 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,20 +20,22 @@ , sGlobalPackageDatabasePath , sLdSupportsCompactUnwind , sLdSupportsFilelist + , 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 @@ -40,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 @@ -54,12 +61,12 @@ , sOpt_windres , sOpt_lo , sOpt_lc - , sOpt_lcc , sOpt_i , sExtraGccViaCFlags , sTargetPlatformString , sGhcWithInterpreter , sLibFFI + , sTargetRTSLinkerOnlySupportsSharedLibs ) where import GHC.Prelude @@ -67,6 +74,7 @@ import GHC.Utils.CliOption import GHC.Utils.Fingerprint import GHC.Platform +import GHC.Unit.Types data Settings = Settings { sGhcNameVersion :: {-# UNPACk #-} !GhcNameVersion @@ -74,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,25 +99,32 @@ { toolSettings_ldSupportsCompactUnwind :: Bool , toolSettings_ldSupportsFilelist :: 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 @@ -116,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] @@ -137,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] @@ -190,6 +215,8 @@ sLdSupportsCompactUnwind = toolSettings_ldSupportsCompactUnwind . sToolSettings sLdSupportsFilelist :: Settings -> Bool sLdSupportsFilelist = toolSettings_ldSupportsFilelist . sToolSettings +sMergeObjsSupportsResponseFiles :: Settings -> Bool +sMergeObjsSupportsResponseFiles = toolSettings_mergeObjsSupportsResponseFiles . sToolSettings sLdIsGnuLd :: Settings -> Bool sLdIsGnuLd = toolSettings_ldIsGnuLd . sToolSettings sGccSupportsNoPie :: Settings -> Bool @@ -203,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 @@ -233,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] @@ -243,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] @@ -261,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 @@ -275,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,6 +30,27 @@ mAX_SOLVER_ITERATIONS :: Int mAX_SOLVER_ITERATIONS = 4 +-- | 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] +mAX_QC_FUEL :: Int +mAX_QC_FUEL = 3 + +-- | In case of loopy wanted constraints, +-- how many times should we allow superclass expansions +-- Should be less than mAX_GIVENS_FUEL +-- See Note [Expanding Recursive Superclasses and ExpansionFuel] +mAX_WANTEDS_FUEL :: Int +mAX_WANTEDS_FUEL = 1 + +-- | In case of loopy given constraints, +-- how many times should we allow superclass expansions +-- Should be less than max_SOLVER_ITERATIONS +-- See Note [Expanding Recursive Superclasses and ExpansionFuel] +mAX_GIVENS_FUEL :: Int +mAX_GIVENS_FUEL = 3 + wORD64_SIZE :: Int wORD64_SIZE = 8 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,43 +72,76 @@ 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" - myExtraGccViaCFlags <- getSetting "GCC extra via C opts" + 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. + -- + -- -fwrapv is needed for gcc to emit well-behaved code in the presence of + -- integer wrap around (#952). + extraGccViaCFlags = if platformUnregisterised platform + -- configure guarantees cc support these flags + then ["-fwrapv", "-fno-builtin"] + else [] + ldSupportsCompactUnwind <- getBooleanSetting "ld supports compact unwind" ldSupportsFilelist <- getBooleanSetting "ld supports filelist" 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 @@ -119,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" @@ -167,25 +200,33 @@ , fileSettings_globalPackageDatabase = globalpkgdb_path } + , sUnitSettings = UnitSettings + { + unitSettings_baseUnitId = stringToUnitId baseUnitId + } + , sToolSettings = ToolSettings { toolSettings_ldSupportsCompactUnwind = ldSupportsCompactUnwind , toolSettings_ldSupportsFilelist = ldSupportsFilelist , 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 @@ -193,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 @@ -205,12 +250,12 @@ , 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 = words myExtraGccViaCFlags + , toolSettings_extraGccViaCFlags = extraGccViaCFlags } , sTargetPlatform = platform @@ -219,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 @@ -37,14 +37,14 @@ bcPrepRHS :: StgRhs -> BcPrepM StgRhs -- explicitly match all constructors so we get a warning if we miss any -bcPrepRHS (StgRhsClosure fvs cc upd args (StgTick bp@Breakpoint{} expr)) = do +bcPrepRHS (StgRhsClosure fvs cc upd args (StgTick bp@Breakpoint{} expr) typ) = do {- If we have a breakpoint directly under an StgRhsClosure we don't need to introduce a new binding for it. -} expr' <- bcPrepExpr expr - pure (StgRhsClosure fvs cc upd args (StgTick bp expr')) -bcPrepRHS (StgRhsClosure fvs cc upd args expr) = - StgRhsClosure fvs cc upd args <$> bcPrepExpr expr + pure (StgRhsClosure fvs cc upd args (StgTick bp expr') typ) +bcPrepRHS (StgRhsClosure fvs cc upd args expr typ) = + StgRhsClosure fvs cc upd args <$> bcPrepExpr expr <*> pure typ bcPrepRHS con@StgRhsCon{} = pure con bcPrepExpr :: StgExpr -> BcPrepM StgExpr @@ -59,6 +59,7 @@ ReEntrant [] expr' + tick_ty ) letExp = StgLet noExtFieldSilent bnd (StgApp id []) pure letExp @@ -71,6 +72,7 @@ ReEntrant [voidArgId] expr' + tick_ty ) pure $ StgLet noExtFieldSilent bnd (StgApp id [StgVarArg realWorldPrimId]) bcPrepExpr (StgTick tick rhs) = @@ -110,10 +112,10 @@ bcPrepSingleBind :: (Id, StgRhs) -> (Id, StgRhs) -- If necessary, modify this Id and body to protect not-necessarily-lifted join points. -- See Note [Not-necessarily-lifted join points], step 2. -bcPrepSingleBind (x, StgRhsClosure ext cc upd_flag args body) +bcPrepSingleBind (x, StgRhsClosure ext cc upd_flag args body typ) | isNNLJoinPoint x = ( protectNNLJoinPointId x - , StgRhsClosure ext cc upd_flag (args ++ [voidArgId]) body) + , StgRhsClosure ext cc upd_flag (args ++ [voidArgId]) body typ) bcPrepSingleBind bnd = bnd bcPrepTopLvl :: StgTopBinding -> BcPrepM StgTopBinding @@ -128,7 +130,7 @@ isNNLJoinPoint :: Id -> Bool isNNLJoinPoint x = isJoinId x && mightBeUnliftedType (idType x) --- Update an Id's type to take a Void# argument. +-- Update an Id's type to take a (# #) argument. -- Precondition: the Id is a not-necessarily-lifted join point. -- See Note [Not-necessarily-lifted join points] protectNNLJoinPointId :: Id -> Id @@ -168,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* @@ -200,7 +202,7 @@ Our plan is to behave is if the code was f = \(r :: RuntimeRep) (a :: TYPE r) (x :: T). - let j :: (Void# -> a) + let j :: ((# #) -> a) j = \ _ -> error @r @a "bloop" in case x of A -> j void# 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 -- @@ -165,8 +177,8 @@ -- ^ This substitution is applied to the code as we traverse it. -- Entries have one of two reasons: -- - -- * The input might have shadowing (see Note [Shadowing]), so we have - -- to rename some binders as we traverse the tree. + -- * The input might have shadowing (see Note [Shadowing in Core]), + -- so we have to rename some binders as we traverse the tree. -- * If we remove `let x = Con z` because `let y = Con z` is in scope, -- we note this here as x ↦ y. , ce_bndrMap :: IdEnv OutId @@ -319,11 +331,11 @@ where in_scope' = in_scope `extendInScopeSetList` [ bndr | (bndr, _) <- eqs ] stgCseTopLvlRhs :: InScopeSet -> InStgRhs -> OutStgRhs -stgCseTopLvlRhs in_scope (StgRhsClosure ext ccs upd args body) +stgCseTopLvlRhs in_scope (StgRhsClosure ext ccs upd args body typ) = let body' = stgCseExpr (initEnv in_scope) body - in StgRhsClosure ext ccs upd args body' -stgCseTopLvlRhs _ (StgRhsCon ccs dataCon mu ticks args) - = StgRhsCon ccs dataCon mu ticks args + in StgRhsClosure ext ccs upd args body' typ +stgCseTopLvlRhs _ (StgRhsCon ccs dataCon mu ticks args typ) + = StgRhsCon ccs dataCon mu ticks args typ ------------------------------ -- The actual AST traversal -- @@ -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. @@ -427,7 +443,7 @@ -- The RHS of a binding. -- If it is a constructor application, either short-cut it or extend the environment stgCseRhs :: CseEnv -> OutId -> InStgRhs -> (Maybe (OutId, OutStgRhs), CseEnv) -stgCseRhs env bndr (StgRhsCon ccs dataCon mu ticks args) +stgCseRhs env bndr (StgRhsCon ccs dataCon mu ticks args typ) | Just other_bndr <- envLookup dataCon args' env , not (isWeakLoopBreaker (idOccInfo bndr)) -- See Note [Care with loop breakers] = let env' = addSubst bndr other_bndr env @@ -435,15 +451,15 @@ | otherwise = let env' = addDataCon bndr dataCon args' env -- see Note [Case 1: CSEing allocated closures] - pair = (bndr, StgRhsCon ccs dataCon mu ticks args') + pair = (bndr, StgRhsCon ccs dataCon mu ticks args' typ) in (Just pair, env') where args' = substArgs env args -stgCseRhs env bndr (StgRhsClosure ext ccs upd args body) +stgCseRhs env bndr (StgRhsClosure ext ccs upd args body typ) = let (env1, args') = substBndrs env args env2 = forgetCse env1 -- See Note [Free variables of an StgClosure] body' = stgCseExpr env2 body - in (Just (substVar env bndr, StgRhsClosure ext ccs upd args' body'), env) + in (Just (substVar env bndr, StgRhsClosure ext ccs upd args' body' typ), env) mkStgCase :: StgExpr -> OutId -> AltType -> [StgAlt] -> StgExpr diff --git a/GHC/Stg/Debug.hs b/GHC/Stg/Debug.hs --- a/GHC/Stg/Debug.hs +++ b/GHC/Stg/Debug.hs @@ -11,25 +11,25 @@ import GHC.Stg.Syntax +import GHC.Types.Unique.DFM import GHC.Types.Id import GHC.Types.Tickish import GHC.Core.DataCon import GHC.Types.IPE import GHC.Unit.Module -import GHC.Types.Name ( getName, getOccName, occNameString, nameSrcSpan ) +import GHC.Types.Name ( getName, getOccName, occNameFS, nameSrcSpan) import GHC.Data.FastString import Control.Monad (when) 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 import Data.List.NonEmpty (NonEmpty(..)) -data SpanWithLabel = SpanWithLabel RealSrcSpan String +data SpanWithLabel = SpanWithLabel RealSrcSpan LexicalFastString data StgDebugOpts = StgDebugOpts { stgDebug_infoTableMap :: !Bool @@ -70,13 +70,13 @@ collectStgRhs :: Id -> StgRhs -> M StgRhs collectStgRhs bndr rhs = case rhs of - StgRhsClosure ext cc us bs e -> do + StgRhsClosure ext cc us bs e t -> do e' <- with_span $ collectExpr e recordInfo bndr e' - return $ StgRhsClosure ext cc us bs e' - StgRhsCon cc dc _mn ticks args -> do + 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) + 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 @@ -85,7 +85,7 @@ let name = idName bndr in case nameSrcSpan name of RealSrcSpan pos _ -> - withSpan (pos, occNameString (getOccName name)) + withSpan (pos, LexicalFastString $ occNameFS (getOccName name)) _ -> id recordInfo :: Id -> StgExpr -> M () @@ -96,7 +96,7 @@ -- A span from the ticks surrounding the new_rhs best_span = quickSourcePos thisFile new_rhs -- A back-up span if the bndr had a source position, many do not (think internally generated ids) - bndr_span = (\s -> SpanWithLabel s (occNameString (getOccName bndr))) + bndr_span = (\s -> SpanWithLabel s (LexicalFastString $ occNameFS (getOccName bndr))) <$> srcSpanToRealSrcSpan (nameSrcSpan (getName bndr)) recordStgIdPosition bndr best_span bndr_span @@ -153,7 +153,7 @@ --Useful for debugging why a certain Id gets given a certain span --pprTraceM "recordStgIdPosition" (ppr id $$ ppr cc $$ ppr best_span $$ ppr ss) let mbspan = (\(SpanWithLabel rss d) -> (rss, d)) <$> (best_span <|> cc <|> ss) - lift $ modify (\env -> env { provClosure = addToUniqMap (provClosure env) (idName id) (idType id, mbspan) }) + lift $ modify (\env -> env { provClosure = addToUDFM (provClosure env) (idName id) (idName id, (idType id, mbspan)) }) numberDataCon :: DataCon -> [StgTickish] -> M ConstructorNumber -- Unboxed tuples and sums do not allocate so they @@ -166,13 +166,13 @@ env <- lift get mcc <- asks rSpan let !mbest_span = (\(SpanWithLabel rss l) -> (rss, l)) <$> (selectTick ts <|> mcc) - let !dcMap' = alterUniqMap (maybe (Just ((0, mbest_span) :| [] )) - (\xs@((k, _):|_) -> Just $! ((k + 1, mbest_span) `NE.cons` xs))) (provDC env) dc + let !dcMap' = alterUDFM (maybe (Just (dc, (0, mbest_span) :| [] )) + (\(_dc, xs@((k, _):|_)) -> Just $! (dc, (k + 1, mbest_span) `NE.cons` xs))) (provDC env) dc lift $ put (env { provDC = dcMap' }) - let r = lookupUniqMap dcMap' dc + let r = lookupUDFM dcMap' dc return $ case r of Nothing -> NoNumber - Just res -> Numbered (fst (NE.head res)) + Just (_, res) -> Numbered (fst (NE.head res)) selectTick :: [StgTickish] -> Maybe SpanWithLabel selectTick [] = Nothing 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/FVs.hs b/GHC/Stg/FVs.hs --- a/GHC/Stg/FVs.hs +++ b/GHC/Stg/FVs.hs @@ -1,4 +1,5 @@ {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE LambdaCase #-} {- | Non-global free variable analysis on STG terms. This pass annotates @@ -84,26 +85,31 @@ -- with the free variables needed in the closure -- * Each StgCase is correctly annotated (in its extension field) with -- the variables that must be saved across the case -depSortWithAnnotStgPgm :: Module -> [StgTopBinding] -> [CgStgTopBinding] +depSortWithAnnotStgPgm :: Module -> [StgTopBinding] -> [(CgStgTopBinding,ImpFVs)] depSortWithAnnotStgPgm this_mod binds = {-# SCC "STG.depSortWithAnnotStgPgm" #-} - lit_binds ++ map from_scc sccs + zip lit_binds (repeat emptyVarSet) ++ map from_scc sccs where lit_binds :: [CgStgTopBinding] pairs :: [(Id, StgRhs)] (lit_binds, pairs) = flattenTopStgBindings binds - nodes :: [Node Name (Id, CgStgRhs)] + nodes :: [Node Name (Id, CgStgRhs, ImpFVs)] nodes = map (annotateTopPair env0) pairs env0 = Env { locals = emptyVarSet, mod = this_mod } -- Do strongly connected component analysis. Why? -- See Note [Why do we need dependency analysis?] - sccs :: [SCC (Id,CgStgRhs)] + sccs :: [SCC (Id,CgStgRhs,ImpFVs)] sccs = stronglyConnCompFromEdgedVerticesUniq nodes - from_scc (CyclicSCC pairs) = StgTopLifted (StgRec pairs) - from_scc (AcyclicSCC (bndr,rhs)) = StgTopLifted (StgNonRec bndr rhs) + from_scc = \case + AcyclicSCC (bndr,rhs,imp_fvs) -> (StgTopLifted (StgNonRec bndr rhs), imp_fvs) + CyclicSCC triples -> (StgTopLifted (StgRec pairs), imp_fvs) + where + (ids,rhss,imp_fvss) = unzip3 triples + pairs = zip ids rhss + imp_fvs = unionVarSets imp_fvss flattenTopStgBindings :: [StgTopBinding] -> ([CgStgTopBinding], [(Id,StgRhs)]) @@ -119,13 +125,13 @@ flatten_one (StgNonRec b r) = [(b,r)] flatten_one (StgRec pairs) = pairs -annotateTopPair :: Env -> (Id, StgRhs) -> Node Name (Id, CgStgRhs) +annotateTopPair :: Env -> (Id, StgRhs) -> Node Name (Id, CgStgRhs, ImpFVs) annotateTopPair env0 (bndr, rhs) = DigraphNode { node_key = idName bndr - , node_payload = (bndr, rhs') + , node_payload = (bndr, rhs', imp_fvs) , node_dependencies = map idName (nonDetEltsUniqSet top_fvs) } where - (rhs', top_fvs, _) = rhsFVs env0 rhs + (rhs', imp_fvs, top_fvs, _) = rhsFVs env0 rhs -------------------------------------------------------------------------------- -- * Non-global free variable analysis @@ -158,6 +164,12 @@ -- analysis on the top-level bindings. type TopFVs = IdSet +-- | ImpFVs: set of variables that are imported +-- +-- It is a /non-deterministic/ set because we use it only to perform module +-- dependency analysis. +type ImpFVs = IdSet + -- | LocalFVs: set of variable that are: -- (a) bound locally (by a lambda, non-top-level let, or case); that is, -- it appears in the 'locals' field of 'Env' @@ -181,97 +193,100 @@ -- annBindingFreeVars :: Module -> StgBinding -> CgStgBinding -annBindingFreeVars this_mod = fstOf3 . bindingFVs (Env emptyVarSet this_mod) emptyDVarSet +annBindingFreeVars this_mod = fstOf4 . bindingFVs (Env emptyVarSet this_mod) emptyDVarSet -bindingFVs :: Env -> LocalFVs -> StgBinding -> (CgStgBinding, TopFVs, LocalFVs) +bindingFVs :: Env -> LocalFVs -> StgBinding -> (CgStgBinding, ImpFVs, TopFVs, LocalFVs) bindingFVs env body_fv b = case b of - StgNonRec bndr r -> (StgNonRec bndr r', fvs, lcl_fvs) + StgNonRec bndr r -> (StgNonRec bndr r', imp_fvs, top_fvs, lcl_fvs) where - (r', fvs, rhs_lcl_fvs) = rhsFVs env r + (r', imp_fvs, top_fvs, rhs_lcl_fvs) = rhsFVs env r lcl_fvs = delDVarSet body_fv bndr `unionDVarSet` rhs_lcl_fvs - StgRec pairs -> (StgRec pairs', fvs, lcl_fvss) + StgRec pairs -> (StgRec pairs', imp_fvs, top_fvs, lcl_fvss) where bndrs = map fst pairs env' = addLocals bndrs env - (rhss, rhs_fvss, rhs_lcl_fvss) = mapAndUnzip3 (rhsFVs env' . snd) pairs - fvs = unionVarSets rhs_fvss + (rhss, rhs_imp_fvss, rhs_top_fvss, rhs_lcl_fvss) = mapAndUnzip4 (rhsFVs env' . snd) pairs + top_fvs = unionVarSets rhs_top_fvss + imp_fvs = unionVarSets rhs_imp_fvss pairs' = zip bndrs rhss lcl_fvss = delDVarSetList (unionDVarSets (body_fv:rhs_lcl_fvss)) bndrs -varFVs :: Env -> Id -> (TopFVs, LocalFVs) -> (TopFVs, LocalFVs) -varFVs env v (top_fvs, lcl_fvs) +varFVs :: Env -> Id -> (ImpFVs, TopFVs, LocalFVs) -> (ImpFVs, TopFVs, LocalFVs) +varFVs env v (imp_fvs, top_fvs, lcl_fvs) | v `elemVarSet` locals env -- v is locally bound - = (top_fvs, lcl_fvs `extendDVarSet` v) + = (imp_fvs, top_fvs, lcl_fvs `extendDVarSet` v) | nameIsLocalOrFrom (mod env) (idName v) -- v is bound at top level - = (top_fvs `extendVarSet` v, lcl_fvs) + = (imp_fvs, top_fvs `extendVarSet` v, lcl_fvs) | otherwise -- v is imported - = (top_fvs, lcl_fvs) + = (imp_fvs `extendVarSet` v, top_fvs, lcl_fvs) -exprFVs :: Env -> StgExpr -> (CgStgExpr, TopFVs, LocalFVs) +exprFVs :: Env -> StgExpr -> (CgStgExpr, ImpFVs, TopFVs, LocalFVs) exprFVs env = go where go (StgApp f as) - | (top_fvs, lcl_fvs) <- varFVs env f (argsFVs env as) - = (StgApp f as, top_fvs, lcl_fvs) + | (imp_fvs, top_fvs, lcl_fvs) <- varFVs env f (argsFVs env as) + = (StgApp f as, imp_fvs, top_fvs, lcl_fvs) - go (StgLit lit) = (StgLit lit, emptyVarSet, emptyDVarSet) + go (StgLit lit) = (StgLit lit, emptyVarSet, emptyVarSet, emptyDVarSet) go (StgConApp dc n as tys) - | (top_fvs, lcl_fvs) <- argsFVs env as - = (StgConApp dc n as tys, top_fvs, lcl_fvs) + | (imp_fvs, top_fvs, lcl_fvs) <- argsFVs env as + = (StgConApp dc n as tys, imp_fvs, top_fvs, lcl_fvs) go (StgOpApp op as ty) - | (top_fvs, lcl_fvs) <- argsFVs env as - = (StgOpApp op as ty, top_fvs, lcl_fvs) + | (imp_fvs, top_fvs, lcl_fvs) <- argsFVs env as + = (StgOpApp op as ty, imp_fvs, top_fvs, lcl_fvs) go (StgCase scrut bndr ty alts) - | (scrut',scrut_top_fvs,scrut_lcl_fvs) <- exprFVs env scrut - , (alts',alts_top_fvss,alts_lcl_fvss) - <- mapAndUnzip3 (altFVs (addLocals [bndr] env)) alts + | (scrut',scrut_imp_fvs,scrut_top_fvs,scrut_lcl_fvs) <- exprFVs env scrut + , (alts',alts_imp_fvss,alts_top_fvss,alts_lcl_fvss) + <- mapAndUnzip4 (altFVs (addLocals [bndr] env)) alts , let top_fvs = scrut_top_fvs `unionVarSet` unionVarSets alts_top_fvss + imp_fvs = scrut_imp_fvs `unionVarSet` unionVarSets alts_imp_fvss alts_lcl_fvs = unionDVarSets alts_lcl_fvss lcl_fvs = delDVarSet (unionDVarSet scrut_lcl_fvs alts_lcl_fvs) bndr - = (StgCase scrut' bndr ty alts', top_fvs,lcl_fvs) + = (StgCase scrut' bndr ty alts', imp_fvs, top_fvs, lcl_fvs) go (StgLet ext bind body) = go_bind (StgLet ext) bind body go (StgLetNoEscape ext bind body) = go_bind (StgLetNoEscape ext) bind body go (StgTick tick e) - | (e', top_fvs, lcl_fvs) <- exprFVs env e + | (e', imp_fvs, top_fvs, lcl_fvs) <- exprFVs env e , let lcl_fvs' = unionDVarSet (tickish tick) lcl_fvs - = (StgTick tick e', top_fvs, lcl_fvs') + = (StgTick tick e', imp_fvs, top_fvs, lcl_fvs') where tickish (Breakpoint _ _ ids) = mkDVarSet ids tickish _ = emptyDVarSet - go_bind dc bind body = (dc bind' body', top_fvs, lcl_fvs) + go_bind dc bind body = (dc bind' body', imp_fvs, top_fvs, lcl_fvs) where env' = addLocals (bindersOf bind) env - (body', body_top_fvs, body_lcl_fvs) = exprFVs env' body - (bind', bind_top_fvs, lcl_fvs) = bindingFVs env' body_lcl_fvs bind + (body', body_imp_fvs, body_top_fvs, body_lcl_fvs) = exprFVs env' body + (bind', bind_imp_fvs, bind_top_fvs, lcl_fvs) = bindingFVs env' body_lcl_fvs bind top_fvs = bind_top_fvs `unionVarSet` body_top_fvs + imp_fvs = bind_imp_fvs `unionVarSet` body_imp_fvs -rhsFVs :: Env -> StgRhs -> (CgStgRhs, TopFVs, LocalFVs) -rhsFVs env (StgRhsClosure _ ccs uf bs body) - | (body', top_fvs, lcl_fvs) <- exprFVs (addLocals bs env) body +rhsFVs :: Env -> StgRhs -> (CgStgRhs, ImpFVs, TopFVs, LocalFVs) +rhsFVs env (StgRhsClosure _ ccs uf bs body typ) + | (body', imp_fvs, top_fvs, lcl_fvs) <- exprFVs (addLocals bs env) body , let lcl_fvs' = delDVarSetList lcl_fvs bs - = (StgRhsClosure lcl_fvs' ccs uf bs body', top_fvs, lcl_fvs') -rhsFVs env (StgRhsCon ccs dc mu ts bs) - | (top_fvs, lcl_fvs) <- argsFVs env bs - = (StgRhsCon ccs dc mu ts bs, top_fvs, lcl_fvs) + = (StgRhsClosure lcl_fvs' ccs uf bs body' typ, imp_fvs, top_fvs, lcl_fvs') +rhsFVs env (StgRhsCon ccs dc mu ts bs typ) + | (imp_fvs, top_fvs, lcl_fvs) <- argsFVs env bs + = (StgRhsCon ccs dc mu ts bs typ, imp_fvs, top_fvs, lcl_fvs) -argsFVs :: Env -> [StgArg] -> (TopFVs, LocalFVs) -argsFVs env = foldl' f (emptyVarSet, emptyDVarSet) +argsFVs :: Env -> [StgArg] -> (ImpFVs, TopFVs, LocalFVs) +argsFVs env = foldl' f (emptyVarSet, emptyVarSet, emptyDVarSet) where - f (fvs,ids) StgLitArg{} = (fvs, ids) - f (fvs,ids) (StgVarArg v) = varFVs env v (fvs, ids) + f (imp_fvs,fvs,ids) StgLitArg{} = (imp_fvs, fvs, ids) + f (imp_fvs,fvs,ids) (StgVarArg v) = varFVs env v (imp_fvs, fvs, ids) -altFVs :: Env -> StgAlt -> (CgStgAlt, TopFVs, LocalFVs) +altFVs :: Env -> StgAlt -> (CgStgAlt, ImpFVs, TopFVs, LocalFVs) altFVs env GenStgAlt{alt_con=con, alt_bndrs=bndrs, alt_rhs=e} - | (e', top_fvs, lcl_fvs) <- exprFVs (addLocals bndrs env) e + | (e', imp_fvs, top_fvs, lcl_fvs) <- exprFVs (addLocals bndrs env) e , let lcl_fvs' = delDVarSetList lcl_fvs bndrs , let newAlt = GenStgAlt{alt_con=con, alt_bndrs=bndrs, alt_rhs=e'} - = (newAlt, top_fvs, lcl_fvs') + = (newAlt, imp_fvs, top_fvs, lcl_fvs') 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.Session -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` - Weither or not `x` results in x pointing 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) - | isDeadEndId bnd_id && (notNull) bndrs - -- See Note [Bottom functions are TagTagged] - = (TagSig TagTagged, StgRhsClosure ext cc upd out_bndrs body') - | otherwise - = --pprTrace "inferTagRhsClosure" (ppr (_top, _grp_ids, env,info')) $ - (TagSig info', StgRhsClosure ext cc upd out_bndrs body') - 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) --- 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) - --- 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 - , Levity(..) ) -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 (mkLFImported) - -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 - | Just Unlifted <- typeLevity_maybe (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. - False -- Imported - -> return $! - -- Determine whether it is tagged from the LFInfo of the imported id. - -- See Note [The LFInfo of Imported Ids] - case mkLFImported 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) = {-# 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) - 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) -rewriteRhs _binding (StgRhsClosure fvs ccs flag args body) = do - withBinders NotTopLevel args $ - withClosureLcls fvs $ - StgRhsClosure fvs ccs flag (map fst args) <$> rewriteExpr body - -- 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,76 +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.Utils.Outputable -import GHC.Utils.Binary -import GHC.Utils.Panic.Plain -import Data.Coerce - -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) - -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) - -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,150 +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 instance BinderP 'InferTaggedBinders = (Id, TagSig) -type instance XLet 'InferTaggedBinders = XLet 'CodeGen -type instance XLetNoEscape 'InferTaggedBinders = XLetNoEscape 'CodeGen -type instance XRhsClosure 'InferTaggedBinders = XRhsClosure 'CodeGen - -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.hs b/GHC/Stg/Lift.hs --- a/GHC/Stg/Lift.hs +++ b/GHC/Stg/Lift.hs @@ -198,20 +198,20 @@ -- as lambda binders, discarding all free vars. -> LlStgRhs -> LiftM OutStgRhs -liftRhs mb_former_fvs rhs@(StgRhsCon ccs con mn ts args) +liftRhs mb_former_fvs rhs@(StgRhsCon ccs con mn ts args typ) = assertPpr (isNothing mb_former_fvs) (text "Should never lift a constructor" $$ pprStgRhs panicStgPprOpts rhs) $ - StgRhsCon ccs con mn ts <$> traverse liftArgs args -liftRhs Nothing (StgRhsClosure _ ccs upd infos body) = + StgRhsCon ccs con mn ts <$> traverse liftArgs args <*> pure typ +liftRhs Nothing (StgRhsClosure _ ccs upd infos body typ) = -- This RHS wasn't lifted. withSubstBndrs (map binderInfoBndr infos) $ \bndrs' -> - StgRhsClosure noExtFieldSilent ccs upd bndrs' <$> liftExpr body -liftRhs (Just former_fvs) (StgRhsClosure _ ccs upd infos body) = + StgRhsClosure noExtFieldSilent ccs upd bndrs' <$> liftExpr body <*> pure typ +liftRhs (Just former_fvs) (StgRhsClosure _ ccs upd infos body typ) = -- This RHS was lifted. Insert extra binders for @former_fvs@. withSubstBndrs (map binderInfoBndr infos) $ \bndrs' -> do let bndrs'' = dVarSetElems former_fvs ++ bndrs' - StgRhsClosure noExtFieldSilent ccs upd bndrs'' <$> liftExpr body + StgRhsClosure noExtFieldSilent ccs upd bndrs'' <$> liftExpr body <*> pure typ liftArgs :: InStgArg -> LiftM OutStgArg liftArgs a@(StgLitArg _) = pure a 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 @@ -27,9 +27,13 @@ import GHC.Types.Basic import GHC.Types.Demand import GHC.Types.Id + import GHC.Runtime.Heap.Layout ( WordOff ) + import GHC.Stg.Lift.Config +import GHC.Stg.Lift.Types import GHC.Stg.Syntax + import qualified GHC.StgToCmm.ArgRep as StgToCmm.ArgRep import qualified GHC.StgToCmm.Closure as StgToCmm.Closure import qualified GHC.StgToCmm.Layout as StgToCmm.Layout @@ -110,80 +114,6 @@ llTrace _ _ c = c -- llTrace a b c = pprTrace a b c -type instance BinderP 'LiftLams = BinderInfo -type instance XRhsClosure 'LiftLams = DIdSet -type instance XLet 'LiftLams = Skeleton -type instance XLetNoEscape 'LiftLams = Skeleton - - --- | Captures details of the syntax tree relevant to the cost model, such as --- closures, multi-shot lambdas and case expressions. -data Skeleton - = ClosureSk !Id !DIdSet {- ^ free vars -} !Skeleton - | RhsSk !Card {- ^ how often the RHS was entered -} !Skeleton - | AltSk !Skeleton !Skeleton - | BothSk !Skeleton !Skeleton - | NilSk - -bothSk :: Skeleton -> Skeleton -> Skeleton -bothSk NilSk b = b -bothSk a NilSk = a -bothSk a b = BothSk a b - -altSk :: Skeleton -> Skeleton -> Skeleton -altSk NilSk b = b -altSk a NilSk = a -altSk a b = AltSk a b - -rhsSk :: Card -> Skeleton -> Skeleton -rhsSk _ NilSk = NilSk -rhsSk body_dmd skel = RhsSk body_dmd skel - --- | The type used in binder positions in 'GenStgExpr's. -data BinderInfo - = BindsClosure !Id !Bool -- ^ Let(-no-escape)-bound thing with a flag - -- indicating whether it occurs as an argument - -- or in a nullary application - -- (see "GHC.Stg.Lift.Analysis#arg_occs"). - | BoringBinder !Id -- ^ Every other kind of binder - --- | Gets the bound 'Id' out a 'BinderInfo'. -binderInfoBndr :: BinderInfo -> Id -binderInfoBndr (BoringBinder bndr) = bndr -binderInfoBndr (BindsClosure bndr _) = bndr - --- | Returns 'Nothing' for 'BoringBinder's and 'Just' the flag indicating --- occurrences as argument or in a nullary applications otherwise. -binderInfoOccursAsArg :: BinderInfo -> Maybe Bool -binderInfoOccursAsArg BoringBinder{} = Nothing -binderInfoOccursAsArg (BindsClosure _ b) = Just b - -instance Outputable Skeleton where - ppr NilSk = text "" - ppr (AltSk l r) = vcat - [ text "{ " <+> ppr l - , text "ALT" - , text " " <+> ppr r - , text "}" - ] - ppr (BothSk l r) = ppr l $$ ppr r - ppr (ClosureSk f fvs body) = ppr f <+> ppr fvs $$ nest 2 (ppr body) - ppr (RhsSk card body) = hcat - [ lambda - , ppr card - , dot - , ppr body - ] - -instance Outputable BinderInfo where - ppr = ppr . binderInfoBndr - -instance OutputableBndr BinderInfo where - pprBndr b = pprBndr b . binderInfoBndr - pprPrefixOcc = pprPrefixOcc . binderInfoBndr - pprInfixOcc = pprInfixOcc . binderInfoBndr - bndrIsJoin_maybe = bndrIsJoin_maybe . binderInfoBndr - mkArgOccs :: [StgArg] -> IdSet mkArgOccs = mkVarSet . mapMaybe stg_arg_var where @@ -311,10 +241,10 @@ bndr' = BindsClosure bndr (bndr `elemVarSet` scope_occs) tagSkeletonRhs :: Id -> CgStgRhs -> (Skeleton, IdSet, LlStgRhs) -tagSkeletonRhs _ (StgRhsCon ccs dc mn ts args) - = (NilSk, mkArgOccs args, StgRhsCon ccs dc mn ts args) -tagSkeletonRhs bndr (StgRhsClosure fvs ccs upd bndrs body) - = (rhs_skel, body_arg_occs, StgRhsClosure fvs ccs upd bndrs' body') +tagSkeletonRhs _ (StgRhsCon ccs dc mn ts args typ) + = (NilSk, mkArgOccs args, StgRhsCon ccs dc mn ts args typ) +tagSkeletonRhs bndr (StgRhsClosure fvs ccs upd bndrs body typ) + = (rhs_skel, body_arg_occs, StgRhsClosure fvs ccs upd bndrs' body' typ) where bndrs' = map BoringBinder bndrs (body_skel, body_arg_occs, body') = tagSkeletonExpr body @@ -400,7 +330,7 @@ -- We don't lift updatable thunks or constructors any_memoized = any is_memoized_rhs rhss is_memoized_rhs StgRhsCon{} = True - is_memoized_rhs (StgRhsClosure _ _ upd _ _) = isUpdatable upd + is_memoized_rhs (StgRhsClosure _ _ upd _ _ _) = isUpdatable upd -- Don't lift binders occurring as arguments. This would result in complex -- argument expressions which would have to be given a name, reintroducing @@ -446,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. @@ -469,7 +399,7 @@ rhsLambdaBndrs :: LlStgRhs -> [Id] rhsLambdaBndrs StgRhsCon{} = [] -rhsLambdaBndrs (StgRhsClosure _ _ _ bndrs _) = map binderInfoBndr bndrs +rhsLambdaBndrs (StgRhsClosure _ _ _ bndrs _ _) = map binderInfoBndr bndrs -- | The size in words of a function closure closing over the given 'Id's, -- including the header. @@ -488,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 @@ -548,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 @@ -197,12 +196,12 @@ -- | Omitting this makes for strange closure allocation schemes that crash the -- GC. removeRhsCCCS :: GenStgRhs pass -> GenStgRhs pass -removeRhsCCCS (StgRhsClosure ext ccs upd bndrs body) +removeRhsCCCS (StgRhsClosure ext ccs upd bndrs body typ) | isCurrentCCS ccs - = StgRhsClosure ext dontCareCCS upd bndrs body -removeRhsCCCS (StgRhsCon ccs con mu ts args) + = StgRhsClosure ext dontCareCCS upd bndrs body typ +removeRhsCCCS (StgRhsCon ccs con mu ts args typ) | isCurrentCCS ccs - = StgRhsCon dontCareCCS con mu ts args + = StgRhsCon dontCareCCS con mu ts args typ removeRhsCCCS rhs = rhs -- | The analysis monad consists of the following 'RWST' components: @@ -275,15 +274,13 @@ -- binder and fresh name generation. withLiftedBndr :: DIdSet -> Id -> (Id -> LiftM a) -> LiftM a withLiftedBndr abs_ids bndr inner = do - uniq <- getUniqueM let str = fsLit "$l" `appendFS` occNameFS (getOccName bndr) let ty = mkLamTypes (dVarSetElems abs_ids) (idType bndr) - let bndr' + bndr' <- -- See Note [transferPolyIdInfo] in GHC.Types.Id. We need to do this at least -- for arity information. - = transferPolyIdInfo bndr (dVarSetElems abs_ids) - . mkSysLocal str uniq ManyTy - $ ty + transferPolyIdInfo bndr (dVarSetElems abs_ids) + <$> mkSysLocalM str ManyTy ty LiftM $ RWS.local (\e -> e { e_subst = extendSubst bndr bndr' $ extendInScope bndr' $ e_subst e diff --git a/GHC/Stg/Lift/Types.hs b/GHC/Stg/Lift/Types.hs new file mode 100644 --- /dev/null +++ b/GHC/Stg/Lift/Types.hs @@ -0,0 +1,92 @@ +{-# LANGUAGE TypeFamilies, DataKinds, GADTs, FlexibleInstances #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE ConstraintKinds #-} + +-- This module declares some basic types used by GHC.Stg.Lift +-- We can import this module into GHC.Stg.Syntax, where the +-- type instance declarations for BinderP etc live + +module GHC.Stg.Lift.Types( + Skeleton(..), + bothSk, altSk, rhsSk, + + BinderInfo(..), + binderInfoBndr, binderInfoOccursAsArg + ) where + +import GHC.Prelude + +import GHC.Types.Id +import GHC.Types.Demand +import GHC.Types.Var.Set + +import GHC.Utils.Outputable + +-- | Captures details of the syntax tree relevant to the cost model, such as +-- closures, multi-shot lambdas and case expressions. +data Skeleton + = ClosureSk !Id !DIdSet {- ^ free vars -} !Skeleton + | RhsSk !Card {- ^ how often the RHS was entered -} !Skeleton + | AltSk !Skeleton !Skeleton + | BothSk !Skeleton !Skeleton + | NilSk + +bothSk :: Skeleton -> Skeleton -> Skeleton +bothSk NilSk b = b +bothSk a NilSk = a +bothSk a b = BothSk a b + +altSk :: Skeleton -> Skeleton -> Skeleton +altSk NilSk b = b +altSk a NilSk = a +altSk a b = AltSk a b + +rhsSk :: Card -> Skeleton -> Skeleton +rhsSk _ NilSk = NilSk +rhsSk body_dmd skel = RhsSk body_dmd skel + +-- | The type used in binder positions in 'GenStgExpr's. +data BinderInfo + = BindsClosure !Id !Bool -- ^ Let(-no-escape)-bound thing with a flag + -- indicating whether it occurs as an argument + -- or in a nullary application + -- (see "GHC.Stg.Lift.Analysis#arg_occs"). + | BoringBinder !Id -- ^ Every other kind of binder + +-- | Gets the bound 'Id' out a 'BinderInfo'. +binderInfoBndr :: BinderInfo -> Id +binderInfoBndr (BoringBinder bndr) = bndr +binderInfoBndr (BindsClosure bndr _) = bndr + +-- | Returns 'Nothing' for 'BoringBinder's and 'Just' the flag indicating +-- occurrences as argument or in a nullary applications otherwise. +binderInfoOccursAsArg :: BinderInfo -> Maybe Bool +binderInfoOccursAsArg BoringBinder{} = Nothing +binderInfoOccursAsArg (BindsClosure _ b) = Just b + +instance Outputable Skeleton where + ppr NilSk = text "" + ppr (AltSk l r) = vcat + [ text "{ " <+> ppr l + , text "ALT" + , text " " <+> ppr r + , text "}" + ] + ppr (BothSk l r) = ppr l $$ ppr r + ppr (ClosureSk f fvs body) = ppr f <+> ppr fvs $$ nest 2 (ppr body) + ppr (RhsSk card body) = hcat + [ lambda + , ppr card + , dot + , ppr body + ] + +instance Outputable BinderInfo where + ppr = ppr . binderInfoBndr + +instance OutputableBndr BinderInfo where + pprBndr b = pprBndr b . binderInfoBndr + pprPrefixOcc = pprPrefixOcc . binderInfoBndr + pprInfixOcc = pprInfixOcc . binderInfoBndr + bndrIsJoin_maybe = bndrIsJoin_maybe . binderInfoBndr + diff --git a/GHC/Stg/Lint.hs b/GHC/Stg/Lint.hs --- a/GHC/Stg/Lint.hs +++ b/GHC/Stg/Lint.hs @@ -149,7 +149,7 @@ Nothing -> return () Just msg -> do - logMsg logger Err.MCDump noSrcSpan + logMsg logger Err.MCInfo noSrcSpan -- See Note [MCInfo for Lint] in "GHC.Core.Lint" $ withPprStyle defaultDumpStyle (vcat [ text "*** Stg Lint ErrMsgs: in" <+> text whodunit <+> text "***", @@ -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 () @@ -247,25 +247,25 @@ opts <- getStgPprOpts let rhs' = pprStgRhs opts rhs case rhs of - StgRhsClosure _ ccs _ _ _ + StgRhsClosure _ ccs _ _ _ _ | isCurrentCCS ccs -> addErrL (text "Top-level StgRhsClosure with CurrentCCS" $$ rhs') - StgRhsCon ccs _ _ _ _ + StgRhsCon ccs _ _ _ _ _ | isCurrentCCS ccs -> addErrL (text "Top-level StgRhsCon with CurrentCCS" $$ rhs') _ -> return () lintStgRhs :: (OutputablePass a, BinderP a ~ Id) => GenStgRhs a -> LintM () -lintStgRhs (StgRhsClosure _ _ _ [] expr) +lintStgRhs (StgRhsClosure _ _ _ [] expr _) = lintStgExpr expr -lintStgRhs (StgRhsClosure _ _ _ binders expr) +lintStgRhs (StgRhsClosure _ _ _ binders expr _) = addLoc (LambdaBodyOf binders) $ addInScopeVars binders $ lintStgExpr expr -lintStgRhs rhs@(StgRhsCon _ con _ _ args) = do +lintStgRhs rhs@(StgRhsCon _ con _ _ args _) = do opts <- getStgPprOpts when (isUnboxedTupleDataCon con || isUnboxedSumDataCon con) $ do addErrL (text "StgRhsCon is an unboxed tuple or sum application" $$ @@ -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,8 +31,11 @@ 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 import GHC.Types.Unique.Supply import GHC.Utils.Outputable import GHC.Utils.Logger @@ -40,9 +43,8 @@ import Control.Monad.IO.Class import Control.Monad.Trans.Reader import GHC.Settings (Platform) -import GHC.Stg.InferTags (inferTags) -import GHC.Types.Name.Env (NameEnv) -import GHC.Stg.InferTags.TagSig (TagSig) +import GHC.Stg.EnforceEpt (enforceEpt) +import GHC.Stg.EnforceEpt.TagSig ( StgCgInfos ) data StgPipelineOpts = StgPipelineOpts { stgPipeline_phases :: ![StgToDo] @@ -52,15 +54,17 @@ , 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 } deriving (Functor, Applicative, Monad, MonadIO) --- | Information to be exposed in interface files which is produced --- by the stg2stg passes. -type StgCgInfos = NameEnv TagSig - instance MonadUnique StgM where getUniqueSupplyM = StgM $ do { tag <- ask ; liftIO $! mkSplitUniqSupply tag} @@ -75,9 +79,10 @@ -> StgPipelineOpts -> Module -- ^ module being compiled -> [StgTopBinding] -- ^ input program - -> IO ([CgStgTopBinding], StgCgInfos) -- output program + -> 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' $ @@ -93,12 +98,15 @@ -- sorting pass is necessary. -- This pass will also augment each closure with non-global free variables -- annotations (which is used by code generator to compute offsets into closures) - ; let binds_sorted_with_fvs = depSortWithAnnotStgPgm this_mod binds' + ; let (binds_sorted_with_fvs, imp_fvs) = unzip (depSortWithAnnotStgPgm this_mod binds') -- See Note [Tag inference for interactive contexts] - ; 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 @@ -136,7 +144,7 @@ StgUnarise -> do us <- getUniqueSupplyM liftIO (stg_linter False "Pre-unarise" binds) - let binds' = {-# SCC "StgUnarise" #-} unarise us binds + let binds' = {-# SCC "StgUnarise" #-} unarise us (stgPipeline_allowTopLevelConApp opts this_mod) binds liftIO (dump_when Opt_D_dump_stg_unarised "Unarised STG:" binds') liftIO (stg_linter True "Unarise" binds') return binds' 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) @@ -122,16 +124,17 @@ statRhs :: Bool -> (Id, StgRhs) -> StatEnv -statRhs top (_, StgRhsCon _ _ _ _ _) +statRhs top (_, StgRhsCon _ _ _ _ _ _) = countOne (ConstructorBinds top) -statRhs top (_, StgRhsClosure _ _ u _ body) +statRhs top (_, StgRhsClosure _ _ u _ body _) = statExpr body `combineSE` countOne ( case u of ReEntrant -> ReEntrantBinds top Updatable -> UpdatableBinds top SingleEntry -> SingleEntryBinds top + JumpedTo -> JoinPointBinds top ) {- diff --git a/GHC/Stg/Subst.hs b/GHC/Stg/Subst.hs --- a/GHC/Stg/Subst.hs +++ b/GHC/Stg/Subst.hs @@ -55,7 +55,7 @@ -- | Substitutes an occurrence of an identifier for its counterpart recorded -- in the 'Subst'. -lookupIdSubst :: HasCallStack => Id -> Subst -> Id +lookupIdSubst :: HasDebugCallStack => Id -> Subst -> Id lookupIdSubst id (Subst in_scope env) | not (isLocalId id) = id | Just id' <- lookupVarEnv env id = id' @@ -65,7 +65,7 @@ -- | Substitutes an occurrence of an identifier for its counterpart recorded -- in the 'Subst'. Does not generate a debug warning if the identifier to -- to substitute wasn't in scope. -noWarnLookupIdSubst :: HasCallStack => Id -> Subst -> Id +noWarnLookupIdSubst :: HasDebugCallStack => Id -> Subst -> Id noWarnLookupIdSubst id (Subst in_scope env) | not (isLocalId id) = id | Just id' <- lookupVarEnv env id = id' 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,28 +72,34 @@ import GHC.Prelude -import GHC.Core ( AltCon ) +import GHC.Stg.EnforceEpt.TagSig( TagSig ) +import GHC.Stg.Lift.Types + -- To avoid having an orphan instances for BinderP, XLet etc + import GHC.Types.CostCentre ( CostCentreStack ) -import Data.ByteString ( ByteString ) -import Data.Data ( Data ) -import Data.List ( intersperse ) + +import GHC.Core ( AltCon ) import GHC.Core.DataCon +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.Unit.Module ( Module ) +import GHC.Types.RepType ( typePrimRep, typePrimRep1, typePrimRepU, typePrimRep_maybe ) + import GHC.Utils.Outputable -import GHC.Platform -import GHC.Core.Ppr( {- instances -} ) -import GHC.Builtin.PrimOps ( PrimOp, PrimCall ) -import GHC.Core.TyCon ( PrimRep(..), TyCon ) -import GHC.Core.Type ( Type ) -import GHC.Types.RepType ( typePrimRep1, typePrimRep ) import GHC.Utils.Panic.Plain +import GHC.Builtin.PrimOps ( PrimOp, PrimCall ) + +import Data.ByteString ( ByteString ) +import Data.Data ( Data ) +import Data.List ( intersperse ) + {- ************************************************************************ * * @@ -124,64 +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 LiftedRep = True -isAddrRep UnliftedRep = True -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 @@ -228,6 +213,52 @@ There are specialised forms of application, for constructors, primitives, and literals. + +Note [Constructor applications in STG] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +After the unarisation pass: +* In `StgConApp` and `StgRhsCon` and `StgAlt` we filter out the void arguments, + leaving only non-void ones. +* In `StgApp` and `StgOpApp` we retain void arguments. + +We can do this because we know that `StgConApp` and `StgRhsCon` are saturated applications, +so we lose no information by dropping those void args. In contrast, in `StgApp` we need the + void argument to compare the number of args in the call with the arity of the function. + +This is an open design choice. We could instead choose to treat all these applications +consistently (keeping the void args). But for some reason we don't, and this Note simply +documents that design choice. + +As an example, consider: + + data T a = MkT !Int a Void# + +The wrapper's representation and the worker's representation (i.e. the +datacon's Core representation) are respectively: + + $WMkT :: Int -> a -> Void# -> T a + MkT :: Int# -> a -> Void# -> T a + +T would end up being used in STG post-unarise as: + + let x = MkT 1# y + in ... + case x of + MkT int a -> ... + +The Void# argument is dropped. In essence we only generate binders for runtime +relevant values. + +We also flatten out unboxed tuples in this process. See the unarise +pass for details on how this is done. But as an example consider +`data S = MkS Bool (# Bool | Char #)` which when matched on would +result in an alternative with three binders like this + + MkS bool tag tpl_field -> + +See Note [Translating unboxed sums to unboxed tuples] and Note [Unarisation] +for the details of this transformation. + -} | StgLit Literal @@ -236,8 +267,8 @@ -- which can't be let-bound | StgConApp DataCon ConstructorNumber - [StgArg] -- Saturated. (After Unarisation, [NonVoid StgArg]) - [Type] -- See Note [Types in StgConApp] in GHC.Stg.Unarise + [StgArg] -- Saturated. See Note [Constructor applications in STG] + [[PrimRep]] -- See Note [Representations in StgConApp] in GHC.Stg.Unarise | StgOpApp StgOp -- Primitive op or foreign call [StgArg] -- Saturated. @@ -384,6 +415,7 @@ [BinderP pass] -- ^ arguments; if empty, then not a function; -- as above, order is important. (GenStgExpr pass) -- ^ body + Type -- ^ result type {- An example may be in order. Consider: @@ -412,7 +444,8 @@ -- are not allocated. ConstructorNumber [StgTickish] - [StgArg] -- Args + [StgArg] -- Saturated Args. See Note [Constructor applications in STG] + Type -- Type, for rewriting to an StgRhsClosure -- | Like 'GHC.Hs.Extension.NoExtField', but with an 'Outputable' instance that -- returns 'empty'. @@ -430,14 +463,14 @@ -- implications on build time... stgRhsArity :: StgRhs -> Int -stgRhsArity (StgRhsClosure _ _ _ bndrs _) +stgRhsArity (StgRhsClosure _ _ _ bndrs _ _) = assert (all isId bndrs) $ length bndrs -- The arity never includes type parameters, but they should have gone by now stgRhsArity (StgRhsCon {}) = 0 freeVarsOfRhs :: (XRhsClosure pass ~ DIdSet) => GenStgRhs pass -> DIdSet -freeVarsOfRhs (StgRhsCon _ _ _ _ args) = mkDVarSet [ id | StgVarArg id <- args ] -freeVarsOfRhs (StgRhsClosure fvs _ _ _ _) = fvs +freeVarsOfRhs (StgRhsCon _ _ _ _ args _) = mkDVarSet [ id | StgVarArg id <- args ] +freeVarsOfRhs (StgRhsClosure fvs _ _ _ _ _) = fvs {- ************************************************************************ @@ -577,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. @@ -594,31 +627,40 @@ = 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) -type instance BinderP 'Vanilla = Id -type instance BinderP 'CodeGen = Id -type instance BinderP 'InferTagged = Id +type instance BinderP 'Vanilla = Id +type instance BinderP 'CodeGen = Id +type instance BinderP 'InferTagged = Id +type instance BinderP 'InferTaggedBinders = (Id, TagSig) +type instance BinderP 'LiftLams = BinderInfo type family XRhsClosure (pass :: StgPass) -type instance XRhsClosure 'Vanilla = NoExtFieldSilent -type instance XRhsClosure 'InferTagged = NoExtFieldSilent +type instance XRhsClosure 'Vanilla = NoExtFieldSilent +type instance XRhsClosure 'LiftLams = DIdSet +type instance XRhsClosure 'InferTagged = NoExtFieldSilent +type instance XRhsClosure 'InferTaggedBinders = XRhsClosure 'CodeGen -- | Code gen needs to track non-global free vars type instance XRhsClosure 'CodeGen = DIdSet + type family XLet (pass :: StgPass) -type instance XLet 'Vanilla = NoExtFieldSilent -type instance XLet 'InferTagged = NoExtFieldSilent -type instance XLet 'CodeGen = NoExtFieldSilent +type instance XLet 'Vanilla = NoExtFieldSilent +type instance XLet 'LiftLams = Skeleton +type instance XLet 'InferTagged = NoExtFieldSilent +type instance XLet 'InferTaggedBinders = XLet 'CodeGen +type instance XLet 'CodeGen = NoExtFieldSilent type family XLetNoEscape (pass :: StgPass) -type instance XLetNoEscape 'Vanilla = NoExtFieldSilent -type instance XLetNoEscape 'InferTagged = NoExtFieldSilent -type instance XLetNoEscape 'CodeGen = NoExtFieldSilent +type instance XLetNoEscape 'Vanilla = NoExtFieldSilent +type instance XLetNoEscape 'LiftLams = Skeleton +type instance XLetNoEscape 'InferTagged = NoExtFieldSilent +type instance XLetNoEscape 'InferTaggedBinders = XLetNoEscape 'CodeGen +type instance XLetNoEscape 'CodeGen = NoExtFieldSilent {- @@ -630,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 {- ************************************************************************ @@ -815,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] @@ -874,14 +926,14 @@ pprStgRhs :: OutputablePass pass => StgPprOpts -> GenStgRhs pass -> SDoc pprStgRhs opts rhs = case rhs of - StgRhsClosure ext cc upd_flag args body + StgRhsClosure ext cc upd_flag args body _ -> hang (hsep [ if stgSccEnabled opts then ppr cc else empty , ppUnlessOption sdocSuppressStgExts (ppr ext) , char '\\' <> ppr upd_flag, brackets (interppSP args) ]) 4 (pprStgExpr opts body) - StgRhsCon cc con mid _ticks args + StgRhsCon cc con mid _ticks args _ -> hcat [ if stgSccEnabled opts then ppr cc <> space else empty , case mid of NoNumber -> empty 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,29 +483,59 @@ -------------------------------------------------------------------------------- -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) +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') + -- 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) + | 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)) + 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,2292 +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.Session -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 qualified Data.Map as Map -import qualified Data.IntMap as IntMap -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 - -> Word16 -- ^ 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 = 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 = take (argRepSizeW platform rep) (repeat True) ++ argBits platform args - -non_void :: [ArgRep] -> [ArgRep] -non_void = 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) = ([], 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 breakInfo = dehydrateCgBreakInfo ty_vars 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, Word16)] -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 = - trunc16W $ bytesToWords platform (depth - offset) + 2 - in Just (id, var_depth_ws) - -truncIntegral16 :: Integral a => a -> Word16 -truncIntegral16 w - | w > fromIntegral (maxBound :: Word16) - = panic "stack depth overflow" - | otherwise - = fromIntegral w - -trunc16B :: ByteOff -> Word16 -trunc16B = truncIntegral16 - -trunc16W :: WordOff -> Word16 -trunc16W = truncIntegral16 - -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 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 - `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 - 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)) - 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 = trunc16W . 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] - -> Word16 - -> ProtoBCO Name - -> Word16 - -> Word16 - -> BcM BCInstrList - build_thunk _ [] size bco off arity - = return (PUSH_BCO bco `consOL` unitOL (mkap (off+size) 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 sz - | otherwise = ALLOC_AP sz - mkAlloc sz arity = ALLOC_PAP arity 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 (trunc16W 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 = trunc16W $ 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 `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) - --- 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 = 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 (trunc16W 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 = trunc16W $ 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 = trunc16W $ bytesToWords platform (d - offset) - - bitmap = intsToReverseBitmap platform bitmap_size'{-size-} pointers - - alt_stuff <- mapM codeAlt alts - alt_final0 <- mkMultiBranch maybe_ncons alt_stuff - - let alt_final - | ubx_tuple_frame = mkSlideW 0 2 `mappend` 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) - -- a VanillaReg goes to the same place regardless of whether it - -- contains a pointer - reg_order (VanillaReg n VNonGcPtr) = reg_order (VanillaReg n VGcPtr) - -- if we don't have a position for a FloatReg then they must be passed - -- in the equivalent DoubleReg - reg_order (FloatReg n) = reg_order (DoubleReg n) - -- one-tuples can be passed in other registers, but then we don't need - -- to care about the order - reg_order reg = (0, reg) - - (regs, reg_params) - = unzip $ sortBy (comparing fst) - [(reg_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). - -> (Word16, [StgWord]) -mkStackBitmap platform nptrs_prefix args_info args - = (bitmap_size, bitmap) - where - bitmap_size = trunc16W $ 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) `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 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) (trunc16W 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 = trunc16W $ 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 (trunc16W 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 - LiftedRep -> FFIPointer - UnliftedRep -> 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 - LiftedRep -> LitNullAddr - UnliftedRep -> 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 - [] -> panic "empty typePrimRepArgs" - [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 instr = do - let !off_b = trunc16B $ 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 = trunc16W $ 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 (trunc16W $ 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 = trunc16B $ 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 = take n vals - vals_hi = drop 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) . - 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 -> [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 -> OrdList BCInstr -mkSlideB platform !nb !db = mkSlideW n d - where - !n = trunc16W $ bytesToWords platform nb - !d = bytesToWords platform db - -mkSlideW :: Word16 -> WordOff -> OrdList BCInstr -mkSlideW !n !ws - | ws > fromIntegral limit - -- If the amount to slide doesn't fit in a Word16, generate multiple slide - -- instructions - = SLIDE n limit `consOL` mkSlideW n (ws - fromIntegral limit) - | ws == 0 - = nilOL - | otherwise - = unitOL (SLIDE n $ fromIntegral ws) - where - limit :: Word16 - limit = maxBound - -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 -> [ArgRep] -typeArgReps platform = 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 --------------------------------------------------------------- @@ -199,12 +254,12 @@ cgTopRhs :: StgToCmmConfig -> RecFlag -> Id -> CgStgRhs -> (CgIdInfo, FCode ()) -- The Id is passed along for setting up a binding... -cgTopRhs cfg _rec bndr (StgRhsCon _cc con mn _ts args) +cgTopRhs cfg _rec bndr (StgRhsCon _cc con mn _ts args _typ) = cgTopRhsCon cfg bndr con mn (assertNonVoidStgArgs args) -- con args are always non-void, -- see Note [Post-unarisation invariants] in GHC.Stg.Unarise -cgTopRhs cfg rec bndr (StgRhsClosure fvs cc upd_flag args body) +cgTopRhs cfg rec bndr (StgRhsClosure fvs cc upd_flag args body _typ) = assertPpr (isEmptyDVarSet fvs) (text "fvs:" <> ppr fvs) $ -- There should be no free variables cgTopRhsClosure (stgToCmmPlatform cfg) rec bndr cc upd_flag args body @@ -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 @@ -272,9 +343,10 @@ -- return it. -- NB 2: We don't set CC when entering data (WDP 94/06) do { tickyEnterDynCon - ; ldvEnter (CmmReg nodeReg) + ; let node = CmmReg $ nodeReg platform + ; ldvEnter node ; tickyReturnOldCon (length arg_reps) - ; void $ emitReturn [cmmOffsetB platform (CmmReg nodeReg) (tagForCon platform data_con)] + ; void $ emitReturn [cmmOffsetB platform node (tagForCon platform data_con)] } -- The case continuation code expects a tagged pointer } 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,9 +68,7 @@ toArgRep :: Platform -> PrimRep -> ArgRep toArgRep platform rep = case rep of - VoidRep -> V - LiftedRep -> P - UnliftedRep -> P + BoxedRep _ -> P IntRep -> N WordRep -> N Int8Rep -> N -- Gets widened to native word width for calls @@ -94,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 @@ -113,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 ------------------------------------------------------------------------ @@ -250,14 +269,14 @@ -- (see above) ) -cgRhs id (StgRhsCon cc con mn _ts args) +cgRhs id (StgRhsCon cc con mn _ts args _typ) = withNewTickyCounterCon id con mn $ buildDynCon id mn True cc con (assertNonVoidStgArgs args) -- con args are always non-void, -- see Note [Post-unarisation invariants] in GHC.Stg.Unarise {- See Note [GC recovery] in "GHC.StgToCmm.Closure" -} -cgRhs id (StgRhsClosure fvs cc upd_flag args body) +cgRhs id (StgRhsClosure fvs cc upd_flag args body _typ) = do profile <- getProfile check_tags <- stgToCmmDoTagCheck <$> getStgToCmmConfig @@ -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 @@ -424,7 +443,7 @@ -- BUILD THE OBJECT -- ; (use_cc, blame_cc) <- chooseDynCostCentres cc args body - ; let use_cc = cccsExpr; blame_cc = cccsExpr + ; let use_cc = cccsExpr platform; blame_cc = cccsExpr platform ; emit (mkComment $ mkFastString "calling allocDynClosure") ; let toVarArg (NonVoid a, off) = (NonVoid (StgVarArg a), off) ; let info_tbl = mkCmmInfo closure_info bndr currentCCS @@ -465,7 +484,7 @@ descr -- ; (use_cc, blame_cc) <- chooseDynCostCentres cc [{- no args-}] body - ; let use_cc = cccsExpr; blame_cc = cccsExpr + ; let use_cc = cccsExpr platform; blame_cc = cccsExpr platform -- BUILD THE OBJECT @@ -640,6 +659,7 @@ -> LocalReg -> CgStgExpr -> FCode () thunkCode cl_info fv_details _cc node body = do { profile <- getProfile + ; platform <- getPlatform ; let node_points = nodeMustPointToIt profile (closureLFInfo cl_info) node' = if node_points then Just node else Nothing ; ldvEnterClosure cl_info (CmmLocal node) -- NB: Node always points when profiling @@ -658,7 +678,7 @@ -- that cc of enclosing scope will be recorded -- in update frame CAF/DICT functions will be -- subsumed by this enclosing cc - do { enterCostCentreThunk (CmmReg nodeReg) + do { enterCostCentreThunk (CmmReg $ nodeReg platform) ; let lf_info = closureLFInfo cl_info ; fv_bindings <- mapM bind_fv fv_details ; load_fvs node lf_info fv_bindings @@ -709,11 +729,11 @@ whenUpdRemSetEnabled $ emitUpdRemSetPushThunk node emitAtomicStore platform MemOrderRelease (cmmOffsetW platform node (fixedHdrSizeW profile)) - currentTSOExpr + (currentTSOExpr platform) -- See Note [Heap memory barriers] in SMP.h. emitAtomicStore platform MemOrderRelease node - (CmmReg (CmmGlobal EagerBlackholeInfo)) + (CmmReg (CmmGlobal $ GlobalRegUse EagerBlackholeInfo $ bWord platform)) emitAtomicStore :: Platform -> MemoryOrdering -> CmmExpr -> CmmExpr -> FCode () emitAtomicStore platform mord addr val = @@ -743,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 @@ -751,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} } @@ -767,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 @@ -787,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 @@ -799,13 +861,13 @@ { 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 ; bh <- newTemp (bWord platform) ; emitRtsCallGen [(bh,AddrHint)] newCAF_lbl - [ (baseExpr, AddrHint), + [ (baseExpr platform, AddrHint), (CmmReg (CmmLocal node), AddrHint) ] False 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,23 +29,39 @@ 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 baseRegOffset platform reg = case reg of - VanillaReg 1 _ -> pc_OFFSET_StgRegTable_rR1 constants - VanillaReg 2 _ -> pc_OFFSET_StgRegTable_rR2 constants - VanillaReg 3 _ -> pc_OFFSET_StgRegTable_rR3 constants - VanillaReg 4 _ -> pc_OFFSET_StgRegTable_rR4 constants - VanillaReg 5 _ -> pc_OFFSET_StgRegTable_rR5 constants - VanillaReg 6 _ -> pc_OFFSET_StgRegTable_rR6 constants - VanillaReg 7 _ -> pc_OFFSET_StgRegTable_rR7 constants - VanillaReg 8 _ -> pc_OFFSET_StgRegTable_rR8 constants - VanillaReg 9 _ -> pc_OFFSET_StgRegTable_rR9 constants - VanillaReg 10 _ -> pc_OFFSET_StgRegTable_rR10 constants - VanillaReg n _ -> panic ("Registers above R10 are not supported (tried to use R" ++ show n ++ ")") + VanillaReg 1 -> pc_OFFSET_StgRegTable_rR1 constants + VanillaReg 2 -> pc_OFFSET_StgRegTable_rR2 constants + VanillaReg 3 -> pc_OFFSET_StgRegTable_rR3 constants + VanillaReg 4 -> pc_OFFSET_StgRegTable_rR4 constants + VanillaReg 5 -> pc_OFFSET_StgRegTable_rR5 constants + VanillaReg 6 -> pc_OFFSET_StgRegTable_rR6 constants + VanillaReg 7 -> pc_OFFSET_StgRegTable_rR7 constants + VanillaReg 8 -> pc_OFFSET_StgRegTable_rR8 constants + VanillaReg 9 -> pc_OFFSET_StgRegTable_rR9 constants + VanillaReg 10 -> pc_OFFSET_StgRegTable_rR10 constants + VanillaReg n -> panic ("Registers above R10 are not supported (tried to use R" ++ show n ++ ")") FloatReg 1 -> pc_OFFSET_StgRegTable_rF1 constants FloatReg 2 -> pc_OFFSET_StgRegTable_rF2 constants FloatReg 3 -> pc_OFFSET_StgRegTable_rF3 constants @@ -124,16 +142,16 @@ get_Regtable_addr_from_offset :: Platform -> Int -> CmmExpr get_Regtable_addr_from_offset platform offset = if haveRegBase platform - then cmmRegOff baseReg offset + then cmmRegOff (baseReg platform) offset else regTableOffset platform offset -- | Fixup global registers so that they assign to locations within the -- RegTable if they aren't pinned for the current target. -fixStgRegisters :: Platform -> RawCmmDecl -> RawCmmDecl +fixStgRegisters :: 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 @@ -144,34 +162,38 @@ where fixAssign stmt = case stmt of - CmmAssign (CmmGlobal reg) src + CmmAssign (CmmGlobal reg_use) src -- MachSp isn't an STG register; it's merely here for tracking unwind -- information | reg == MachSp -> stmt | otherwise -> let baseAddr = get_GlobalReg_addr platform reg in case reg `elem` activeStgRegs platform of - True -> CmmAssign (CmmGlobal reg) src + True -> CmmAssign (CmmGlobal reg_use) src False -> CmmStore baseAddr src NaturallyAligned + where reg = globalRegUse_reg reg_use other_stmt -> other_stmt fixExpr expr = case expr of -- MachSp isn't an STG; it's merely here for tracking unwind information - CmmReg (CmmGlobal MachSp) -> expr - CmmReg (CmmGlobal reg) -> + CmmReg (CmmGlobal (GlobalRegUse MachSp _)) -> expr + CmmReg (CmmGlobal reg_use) -> -- Replace register leaves with appropriate StixTrees for -- the given target. MagicIds which map to a reg on this -- arch are left unchanged. For the rest, BaseReg is taken -- to mean the address of the reg table in MainCapability, -- and for all others we generate an indirection to its -- location in the register table. + let reg = globalRegUse_reg reg_use in case reg `elem` activeStgRegs platform of True -> expr False -> let baseAddr = get_GlobalReg_addr platform reg in case reg of BaseReg -> baseAddr - _other -> CmmLoad baseAddr (globalRegType platform reg) NaturallyAligned + _other -> CmmLoad baseAddr + (globalRegUse_type reg_use) + NaturallyAligned CmmRegOff greg@(CmmGlobal reg) offset -> -- RegOf leaves are just a shorthand form. If the reg maps @@ -180,11 +202,11 @@ -- 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 reg `elem` activeStgRegs platform of + case globalRegUse_reg reg `elem` activeStgRegs platform of True -> expr - False -> CmmMachOp (MO_Add (cmmRegWidth platform greg)) [ + False -> CmmMachOp (MO_Add (cmmRegWidth greg)) [ fixExpr (CmmReg greg), CmmLit (CmmInt (fromIntegral offset) - (cmmRegWidth platform greg))] + (cmmRegWidth greg))] other_expr -> other_expr 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, @@ -28,7 +27,7 @@ LambdaFormInfo, -- Abstract StandardFormInfo, -- ...ditto... mkLFThunk, mkLFReEntrant, mkConLFInfo, mkSelectorLFInfo, - mkApLFInfo, mkLFImported, mkLFArgument, mkLFLetNoEscape, + mkApLFInfo, importedIdLFInfo, mkLFArgument, mkLFLetNoEscape, mkLFStringLit, lfDynTag, isLFThunk, isLFReEntrant, lfUpdatable, @@ -94,12 +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 @@ -160,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 @@ -176,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 @@ -254,130 +251,67 @@ (mightBeFunTy (idType id)) ------------- -mkLFImported :: Id -> LambdaFormInfo -mkLFImported id = +-- | The 'LambdaFormInfo' of an imported Id. +-- See Note [The LFInfo of Imported Ids] +importedIdLFInfo :: Id -> LambdaFormInfo +importedIdLFInfo id = -- See Note [Conveying CAF-info and LFInfo between modules] in -- GHC.StgToCmm.Types case idLFInfo_maybe id of Just lf_info -> - -- Use the LambdaFormInfo from the interface + -- Use the existing LambdaFormInfo lf_info Nothing - -- Interface doesn't have a LambdaFormInfo, so make a conservative one from the type. - -- See Note [The LFInfo of Imported Ids]; The order of the guards musn't be changed! + -- Doesn't have a LambdaFormInfo, but we know it must be 'LFReEntrant' from its arity | arity > 0 -> LFReEntrant TopLevel arity True ArgUnknown - | Just con <- isDataConId_maybe id - -- See Note [Imported unlifted nullary datacon wrappers must have correct LFInfo] in GHC.StgToCmm.Types - -- and Note [The LFInfo of Imported Ids] below - -> assert (hasNoNonZeroWidthArgs con) $ - LFCon con -- An imported nullary constructor - -- We assume that the constructor is evaluated so that - -- the id really does point directly to the constructor - + -- We can't be sure of the LambdaFormInfo of this imported Id, + -- so make a conservative one from the type. | otherwise - -> mkLFArgument id -- Not sure of exact arity + -> assert (isNothing (isDataConId_maybe id)) $ -- See Note [LFInfo of DataCon workers and wrappers] in GHC.Types.Id.Make + mkLFArgument id -- Not sure of exact arity where arity = idFunRepArity id - hasNoNonZeroWidthArgs = all (isZeroBitTy . scaledThing) . dataConRepArgTys {- Note [The LFInfo of Imported Ids] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -As explained in Note [Conveying CAF-info and LFInfo between modules] and -Note [Imported unlifted nullary datacon wrappers must have correct LFInfo], the -LambdaFormInfo records the details of a closure representation and is often, -when optimisations are enabled, serialized to the interface of a module. +As explained in Note [Conveying CAF-info and LFInfo between modules] +the LambdaFormInfo records the details of a closure representation and is +often, when optimisations are enabled, serialized to the interface of a module. -In particular, the `lfInfo` field of the `IdInfo` field of an `Id` -* For Ids defined in this module: is `Nothing` -* For imported Ids: +In particular, the `lfInfo` field of the `IdInfo` field of an `Id`: +* For DataCon workers and wrappers is populated as described in +Note [LFInfo of DataCon workers and wrappers] in GHC.Types.Id.Make +* For other Ids defined in the module being compiled: is `Nothing` +* For other imported Ids: * is (Just lf_info) if the LFInfo was serialised into the interface file (typically, when the exporting module was compiled with -O) * is Nothing if it wasn't serialised -However, when an interface doesn't have a LambdaFormInfo for some imported Id -(so that its `lfInfo` field is `Nothing`), we can conservatively create one -using `mkLFImported`. - The LambdaFormInfo we give an Id is used in determining how to tag its pointer -(see `litIdInfo`). Therefore, it's crucial we re-construct a LambdaFormInfo as -faithfully as possible or otherwise risk having pointers incorrectly tagged, -which can lead to performance issues and even segmentation faults (see #23231 -and #23146). In particular, saturated data constructor applications *must* be -unambiguously given `LFCon`, and the invariant - - If the LFInfo (serialised or built with mkLFImported) says LFCon, then it - really is a static data constructor, and similar for LFReEntrant - -must be upheld. - -In `mkLFImported`, we make a conservative approximation to the real -LambdaFormInfo as follows: - -(1) Ids with an `idFunRepArity > 0` are `LFReEntrant` and pointers to them are -tagged (by `litIdInfo`) with the corresponding arity. - - This is also true of data con wrappers and workers with arity > 0, - 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 - -(2) Data constructors with `idFunRepArity == 0` should be given `LFCon` because -they are fully saturated data constructor applications and pointers to them -should be tagged with the constructor index. - -(2.1) 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) - -(2.2) A datacon *worker* with zero arity is trivially fully saturated, it takes -no arguments whatsoever (not even zero-width args) - -To ensure we properly give `LFReEntrant` to data constructors with some arity, -and `LFCon` only to data constructors with zero arity, we must first check for -`arity > 0` and only afterwards `isDataConId` -- the order of the guards in -`mkLFImported` is quite important. - -As an example, consider the following data constructors: - - data T1 a where - TCon1 :: {-# UNPACK #-} !(a :~: True) -> T1 a - - data T2 a where - TCon2 :: {-# UNPACK #-} !() -> T2 a - - data T3 a where - TCon3 :: T3 '[] - -`TCon1`'s wrapper has a lifted equality argument, which is non-zero-width, while -the worker has an unlifted equality argument, which is zero-width. - -`TCon2`'s wrapper has a lifted equality argument, which is non-zero-width, -while the worker has no arguments. - -`TCon3`'s wrapper has no arguments, and the worker has 1 zero-width argument; -their Core representation: - - $WTCon3 :: T3 '[] - $WTCon3 = TCon3 @[] - - TCon3 :: forall (a :: * -> *). (a ~# []) => T a - TCon3 = /\a. \(co :: a~#[]). TCon3 co - -For `TCon1`, both the wrapper and worker will be given `LFReEntrant` since they -both have arity == 1. +(see `litIdInfo` and `lfDynTag`). Therefore, it's crucial we attribute a correct +LambdaFormInfo to imported Ids, or otherwise risk having pointers incorrectly +tagged which can lead to performance issues and even segmentation faults (see +#23231 and Note [Imported unlifted nullary datacon wrappers must have correct LFInfo]). -For `TCon2`, the wrapper will be given `LFReEntrant` since it has arity == 1 -while the worker is `LFCon` since its arity == 0 +In particular, saturated data constructor applications *must* be unambiguously +given `LFCon`, and if the LFInfo says LFCon, then it really is a static data +constructor, and similar for LFReEntrant. -For `TCon3`, the wrapper will be given `LFCon` since its arity == 0 and the -worker `LFReEntrant` since its arity == 1 +In `importedIdLFInfo`, we construct a LambdaFormInfo for imported Ids as follows: -One might think we could give *workers* with only zero-width-args the `LFCon` -LambdaFormInfo, e.g. give `LFCon` to the worker of `TCon1` and `TCon3`. -However, these workers, albeit rarely used, are unambiguously functions --- which makes `LFReEntrant`, the LambdaFormInfo we give them, correct. -See also the discussion in #23158. +(1) If the `lfInfo` field contains an LFInfo, we use that LFInfo which is +correct by construction (the invariant being that if it exists, it is correct): + (1.1) Either it was serialised to the interface we're importing the Id from, + (1.2) Or it's a DataCon worker or wrapper and its LFInfo was constructed + according to Note [LFInfo of DataCon workers and wrappers] +(2) When the `lfInfo` field is `Nothing` + (2.1) If the `idFunRepArity` of the Id is known and is greater than 0, then + the Id is unambiguously a function and is given `LFReEntrant`, and pointers + to this Id will be tagged (by `litIdInfo`) with the corresponding arity. + (2.2) Otherwise, we can make a conservative estimate from the type. -} @@ -574,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 @@ -649,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) @@ -687,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 @@ -11,6 +11,7 @@ import GHC.Utils.Outputable import GHC.Utils.TmpFs +import GHC.Cmm.MachOp ( FMASign(..) ) import GHC.Prelude @@ -45,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 @@ -61,13 +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 @@ -215,11 +212,12 @@ ; checkConArgsDyn (hang (text "TagCheck failed on constructor application.") 4 $ text "On binder:" <> ppr binder $$ text "Constructor:" <> ppr con) con (map fromNonVoid args) ; hp_plus_n <- allocDynClosure ticky_name info_tbl lf_info - use_cc blame_cc args_w_offsets + (use_cc platform) (blame_cc platform) + args_w_offsets ; return (mkRhsInit platform reg lf_info hp_plus_n) } where - use_cc -- cost-centre to stick in the object - | isCurrentCCS ccs = cccsExpr + use_cc platform -- cost-centre to stick in the object + | isCurrentCCS ccs = cccsExpr platform | otherwise = panic "buildDynCon: non-current CCS not implemented" blame_cc = use_cc -- cost-centre on which to blame the alloc (same) @@ -335,7 +333,7 @@ , platformOS platform /= OSMinGW32 || not (stgToCmmPIE cfg || stgToCmmPIC cfg) , Just val <- getClosurePayload arg , inRange val - = let intlike_lbl = mkCmmClosureLabel rtsUnitId (fsLit label) + = let intlike_lbl = mkCmmClosureLabel rtsUnitId label val_int = fromIntegral val :: Int offsetW = (val_int - fromIntegral min_static_range) * (fixedHdrSizeW profile + 1) -- INTLIKE/CHARLIKE closures consist of a header and one word payload @@ -366,8 +364,8 @@ | charClosure = fromIntegral (pc_MAX_CHARLIKE constants) | otherwise = panic "precomputedStaticConInfo_maybe: Unknown closure type" label - | intClosure = "stg_INTLIKE" - | charClosure = "stg_CHARLIKE" + | intClosure = fsLit "stg_INTLIKE" + | charClosure = fsLit "stg_CHARLIKE" | otherwise = panic "precomputedStaticConInfo_maybe: Unknown closure type" precomputedStaticConInfo_maybe _ _ _ _ = Nothing 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) @@ -149,7 +148,7 @@ | otherwise = pprPanic "GHC.StgToCmm.Env: label not found" (ppr id <+> dcolon <+> ppr (idType id)) in return $ - litIdInfo platform id (mkLFImported id) (CmmLabel ext_lbl) + litIdInfo platform id (importedIdLFInfo id) (CmmLabel ext_lbl) else cgLookupPanic id -- Bug, id is neither in local binds nor is external }}} @@ -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) @@ -200,9 +188,9 @@ -> Id -> CgStgRhs -> FCode (CgIdInfo, FCode ()) -cgLetNoEscapeRhsBody local_cc bndr (StgRhsClosure _ cc _upd args body) +cgLetNoEscapeRhsBody local_cc bndr (StgRhsClosure _ cc _upd args body _typ) = cgLetNoEscapeClosure bndr local_cc cc (nonVoidIds args) body -cgLetNoEscapeRhsBody local_cc bndr (StgRhsCon cc con mn _ts args) +cgLetNoEscapeRhsBody local_cc bndr (StgRhsCon cc con mn _ts args _typ) = cgLetNoEscapeClosure bndr local_cc cc [] (StgConApp con mn args (pprPanic "cgLetNoEscapeRhsBody" $ text "StgRhsCon doesn't have type args")) @@ -222,12 +210,11 @@ cgLetNoEscapeClosure bndr cc_slot _unused_cc args body = do platform <- getPlatform + let code = forkLneBody $ withNewTickyCounterLNE bndr args $ do + { restoreCurrentCostCentre platform cc_slot + ; arg_regs <- bindArgsToRegs args + ; void $ noEscapeHeapCheck arg_regs (tickyEnterLNE >> cgExpr body) } return ( lneIdInfo platform bndr args, code ) - where - code = forkLneBody $ withNewTickyCounterLNE bndr args $ do - { restoreCurrentCostCentre cc_slot - ; arg_regs <- bindArgsToRegs args - ; void $ noEscapeHeapCheck arg_regs (tickyEnterLNE >> cgExpr body) } ------------------------------------------------------------------------ @@ -241,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!; @@ -448,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 @@ -500,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] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -519,7 +536,7 @@ ; mb_cc <- maybeSaveCostCentre True ; _ <- withSequel (AssignTo [idToReg platform (NonVoid v)] False) (cgExpr scrut) - ; restoreCurrentCostCentre mb_cc + ; restoreCurrentCostCentre platform mb_cc ; emitComment $ mkFastString "should be unreachable code" ; l <- newBlockId ; emitLabel l @@ -527,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 @@ -568,7 +616,7 @@ ; let sequel = AssignTo alt_regs do_gc{- Note [scrut sequel] -} ; ret_kind <- withSequel sequel (cgExpr scrut) - ; restoreCurrentCostCentre mb_cc + ; restoreCurrentCostCentre platform mb_cc ; _ <- bindArgsToRegs ret_bndrs ; cgAlts (gc_plan,ret_kind) (NonVoid bndr) alt_type alts } @@ -579,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] ~~~~~~~~~~~~~~~~~~~ @@ -640,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 @@ -688,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 @@ -852,6 +894,7 @@ -- Note [alg-alt heap check] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~ -- -- In an algebraic case with more than one alternative, we will have -- code like @@ -1028,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 @@ -1157,7 +1200,7 @@ Return -> do { let entry = entryCode platform $ closureInfoPtr platform align_check - $ CmmReg nodeReg + $ CmmReg (nodeReg platform) ; emit $ mkJump profile NativeNodeCall entry [cmmUntag platform fun] updfr_off ; return AssignedDirectly @@ -1200,12 +1243,13 @@ -- refer to fun via nodeReg after the copyout, to avoid having -- both live simultaneously; this sometimes enables fun to be -- inlined in the RHS of the R1 assignment. - ; let entry = entryCode platform (closureInfoPtr platform align_check (CmmReg nodeReg)) + ; let node = CmmReg $ nodeReg platform + entry = entryCode platform (closureInfoPtr platform align_check node) the_call = toCall entry (Just lret) updfr_off off outArgs regs ; tscope <- getTickScope ; emit $ copyout <*> - mkCbranch (cmmIsTagged platform (CmmReg nodeReg)) + mkCbranch (cmmIsTagged platform node) lret lcall Nothing <*> outOfLine lcall (the_call,tscope) <*> mkLabel lret tscope <*> 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,14 +355,14 @@ 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) close_nursery <- closeNursery profile tso pure $ catAGraphs [ -- tso = CurrentTSO; - mkAssign (CmmLocal tso) currentTSOExpr + mkAssign (CmmLocal tso) (currentTSOExpr platform) , -- tso->stackobj->sp = Sp; mkStore (cmmOffset platform @@ -323,13 +370,14 @@ (CmmReg (CmmLocal tso)) (tso_stackobj profile))) (stack_SP profile)) - spExpr + (spExpr platform) , close_nursery , -- and save the current cost centre stack in the TSO when profiling: if profileIsProfiling profile - then mkStore (cmmOffset platform (CmmReg (CmmLocal tso)) (tso_CCCS profile)) cccsExpr + then mkStore (cmmOffset platform (CmmReg (CmmLocal tso)) (tso_CCCS profile)) + (cccsExpr platform) else mkNop ] @@ -343,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 @@ -380,38 +428,39 @@ -- -- 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 = cmmRegType platform (CmmGlobal reg) width = roundUpToWords platform (widthInBytes $ typeWidth reg_ty) - adj_sp = mkAssign spReg - (cmmOffset platform spExpr (negate width)) - save_reg = mkStore spExpr (CmmReg $ CmmGlobal reg) + adj_sp = mkAssign (spReg platform) + (cmmOffset platform (spExpr platform) (negate width)) + save_reg = mkStore (spExpr platform) (CmmReg $ CmmGlobal $ GlobalRegUse reg reg_ty) in mkCmmIfThen cond $ catAGraphs [adj_sp, save_reg] - emit . catAGraphs =<< mapM save_arg (reverse regs) + 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 = cmmRegType platform (CmmGlobal reg) width = roundUpToWords platform (widthInBytes $ typeWidth reg_ty) - adj_sp = mkAssign spReg - (cmmOffset platform spExpr width) - restore_reg = mkAssign (CmmGlobal reg) (CmmLoad spExpr reg_ty NaturallyAligned) + adj_sp = mkAssign (spReg platform) + (cmmOffset platform (spExpr platform) width) + 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 @@ -422,7 +471,7 @@ let platform = profilePlatform profile tso <- newTemp (bWord platform) code <- closeNursery profile tso - emit $ mkAssign (CmmLocal tso) currentTSOExpr <*> code + emit $ mkAssign (CmmLocal tso) (currentTSOExpr platform) <*> code {- | @closeNursery dflags tso@ produces code to close the nursery. @@ -445,20 +494,20 @@ 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 cnreg <- CmmLocal <$> newTemp (bWord platform) pure $ catAGraphs [ - mkAssign cnreg currentNurseryExpr, + mkAssign cnreg (currentNurseryExpr platform), -- CurrentNursery->free = Hp+1; - mkStore (nursery_bdescr_free platform cnreg) (cmmOffsetW platform hpExpr 1), + mkStore (nursery_bdescr_free platform cnreg) (cmmOffsetW platform (hpExpr platform) 1), let alloc = CmmMachOp (mo_wordSub platform) - [ cmmOffsetW platform hpExpr 1 + [ cmmOffsetW platform (hpExpr platform) 1 , cmmLoadBWord platform (nursery_bdescr_start platform cnreg) ] @@ -478,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) @@ -486,23 +535,23 @@ open_nursery <- openNursery profile tso pure $ catAGraphs [ -- tso = CurrentTSO; - mkAssign (CmmLocal tso) currentTSOExpr, + mkAssign (CmmLocal tso) (currentTSOExpr platform), -- stack = tso->stackobj; mkAssign (CmmLocal stack) (cmmLoadBWord platform (cmmOffset platform (CmmReg (CmmLocal tso)) (tso_stackobj profile))), -- Sp = stack->sp; - mkAssign spReg (cmmLoadBWord platform (cmmOffset platform (CmmReg (CmmLocal stack)) (stack_SP profile))), + mkAssign (spReg platform) (cmmLoadBWord platform (cmmOffset platform (CmmReg (CmmLocal stack)) (stack_SP profile))), -- SpLim = stack->stack + RESERVED_STACK_WORDS; - mkAssign spLimReg (cmmOffsetW platform (cmmOffset platform (CmmReg (CmmLocal stack)) (stack_STACK profile)) + mkAssign (spLimReg platform) (cmmOffsetW platform (cmmOffset platform (CmmReg (CmmLocal stack)) (stack_STACK profile)) (pc_RESERVED_STACK_WORDS (platformConstants platform))), -- HpAlloc = 0; -- HpAlloc is assumed to be set to non-zero only by a failed -- a heap check, see HeapStackCheck.cmm:GC_GENERIC - mkAssign hpAllocReg (zeroExpr platform), + mkAssign (hpAllocReg platform) (zeroExpr platform), open_nursery, -- and load the current cost centre stack from the TSO when profiling: if profileIsProfiling profile then let ccs_ptr = cmmOffset platform (CmmReg (CmmLocal tso)) (tso_CCCS profile) - in storeCurCCS (CmmLoad ccs_ptr (ccsType platform) NaturallyAligned) + in storeCurCCS platform (CmmLoad ccs_ptr (ccsType platform) NaturallyAligned) else mkNop ] @@ -513,7 +562,7 @@ let platform = profilePlatform profile tso <- newTemp (bWord platform) code <- openNursery profile tso - emit $ mkAssign (CmmLocal tso) currentTSOExpr <*> code + emit $ mkAssign (CmmLocal tso) (currentTSOExpr platform) <*> code {- | @openNursery profile tso@ produces code to open the nursery. A local register @@ -543,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 @@ -556,17 +605,17 @@ -- what code we generate, look at the assembly for -- stg_returnToStackTop in rts/StgStartup.cmm. pure $ catAGraphs [ - mkAssign cnreg currentNurseryExpr, + mkAssign cnreg (currentNurseryExpr platform), mkAssign bdfreereg (cmmLoadBWord platform (nursery_bdescr_free platform cnreg)), -- Hp = CurrentNursery->free - 1; - mkAssign hpReg (cmmOffsetW platform (CmmReg bdfreereg) (-1)), + mkAssign (hpReg platform) (cmmOffsetW platform (CmmReg bdfreereg) (-1)), mkAssign bdstartreg (cmmLoadBWord platform (nursery_bdescr_start platform cnreg)), -- HpLim = CurrentNursery->start + -- CurrentNursery->blocks*BLOCK_SIZE_W - 1; - mkAssign hpLimReg + mkAssign (hpLimReg platform) (cmmOffsetExpr platform (CmmReg bdstartreg) (cmmOffset platform @@ -671,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/Heap.hs b/GHC/StgToCmm/Heap.hs --- a/GHC/StgToCmm/Heap.hs +++ b/GHC/StgToCmm/Heap.hs @@ -353,11 +353,12 @@ -> FCode () entryHeapCheck' is_fastf node arity args code = do profile <- getProfile - let is_thunk = arity == 0 + let platform = profilePlatform profile + is_thunk = arity == 0 args' = map (CmmReg . CmmLocal) args - stg_gc_fun = CmmReg (CmmGlobal GCFun) - stg_gc_enter1 = CmmReg (CmmGlobal GCEnter1) + stg_gc_fun = CmmReg (CmmGlobal $ GlobalRegUse GCFun $ bWord platform) + stg_gc_enter1 = CmmReg (CmmGlobal $ GlobalRegUse GCEnter1 $ bWord platform) {- Thunks: jump stg_gc_enter_1 @@ -615,14 +616,14 @@ -- See Note [Single stack check] sp_oflo sp_hwm = CmmMachOp (mo_wordULt platform) - [CmmMachOp (MO_Sub (typeWidth (cmmRegType platform spReg))) + [CmmMachOp (MO_Sub (typeWidth (cmmRegType $ spReg platform))) [CmmStackSlot Old 0, sp_hwm], - CmmReg spLimReg] + CmmReg $ spLimReg platform] -- Hp overflow if (Hp > HpLim) -- (Hp has been incremented by now) -- HpLim points to the LAST WORD of valid allocation space. - hp_oflo = CmmMachOp (mo_wordUGt platform) [hpExpr, hpLimExpr] + hp_oflo = CmmMachOp (mo_wordUGt platform) [hpExpr platform, hpLimExpr platform] case mb_stk_hwm of Nothing -> return () @@ -640,16 +641,16 @@ case mb_alloc_lit of Just alloc_lit -> do - let bump_hp = cmmOffsetExprB platform hpExpr alloc_lit - alloc_n = mkAssign hpAllocReg alloc_lit + let bump_hp = cmmOffsetExprB platform (hpExpr platform) alloc_lit + alloc_n = mkAssign (hpAllocReg platform) alloc_lit tickyHeapCheck - emitAssign hpReg bump_hp + emitAssign (hpReg platform) bump_hp emit =<< mkCmmIfThen' hp_oflo (alloc_n <*> mkBranch gc_id) (Just False) Nothing -> when (checkYield && not omit_yields) $ do -- Yielding if HpLim == 0 let yielding = CmmMachOp (mo_wordEq platform) - [CmmReg hpLimReg, + [CmmReg $ hpLimReg platform, CmmLit (zeroCLit platform)] emit =<< mkCmmIfGoto' yielding gc_id (Just False) 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 @@ -1,89 +1,228 @@ +{-# LANGUAGE CPP #-} + module GHC.StgToCmm.InfoTableProv (emitIpeBufferListNode) where +import Foreign + +#if defined(HAVE_LIBZSTD) +import Foreign.C.Types +import qualified Data.ByteString.Internal as BSI +import GHC.IO (unsafePerformIO) +#endif + 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.Types.SrcLoc (pprUserRealSpan, srcSpanFile) -import GHC.Data.FastString (unpackFS) +import GHC.Data.FastString (fastStringToShortText, unpackFS, LexicalFastString(..)) +import GHC.Cmm import GHC.Cmm.CLabel -import GHC.Cmm.Expr import GHC.Cmm.Utils + import GHC.StgToCmm.Config -import GHC.StgToCmm.Lit (newByteStringCLit) import GHC.StgToCmm.Monad -import GHC.StgToCmm.Utils import GHC.Data.ShortText (ShortText) import qualified GHC.Data.ShortText as ST -import qualified Data.Map.Strict as M import Control.Monad.Trans.State.Strict + import qualified Data.ByteString as BS import qualified Data.ByteString.Builder as BSB import qualified Data.ByteString.Lazy as BSL +import qualified Data.Map.Strict as M -emitIpeBufferListNode :: Module - -> [InfoProvEnt] - -> FCode () -emitIpeBufferListNode _ [] = return () -emitIpeBufferListNode this_mod ents = do +{- +Note [Compression and Decompression of IPE data] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Compiling with `-finfo-table-map` causes build results to include a map from +info tables to source positions called the info table provenance entry (IPE) +map. See Note [Mapping Info Tables to Source Positions]. The IPE information +can grow the size of build results significantly. At the time of writing, a +default build of GHC results in a total of 109M of libHSghc-*.so build results. +A default+ipe build of GHC (see ./hadrian/doc/flavours.md) results in 262M of +libHSghc-*.so build results without compression. + +We reduce the impact of IPE data on the size of build results by compressing +the data before it is emitted using the zstd compression library. See +Note [The Info Table Provenance Entry (IPE) Map] for information on the layout +of IPE data on disk and in the RTS. We cannot simply compress all data held in +the IPE entry buffer, as the pointers to info tables must be converted to +memory addresses during linking. Therefore, we can only compress the strings +table and the IPE entries themselves (which essentially only consist of indices +into the strings table). + +With compression, a default+ipe build of GHC results in a total of 205M of +libHSghc-*.so build results. This is over a 20% reduction from the uncompressed +case. + +Decompression happens lazily, as it only occurs when the IPE map is +constructed (which is also done lazily on first lookup or traversal). During +construction, the 'compressed' field of each IPE buffer list node is examined. +If the field indicates that the data has been compressed, the entry data and +strings table are decompressed before continuing with the normal IPE map +construction. +-} + +emitIpeBufferListNode :: + Module + -> [InfoProvEnt] + -> 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 - let ctx = stgToCmmContext cfg + + let (u1, dus1) = takeUniqueFromDSupply dus0 + (u2, dus2) = takeUniqueFromDSupply dus1 + (u3, dus3) = takeUniqueFromDSupply dus2 + + tables_lbl = mkStringLitLabel u1 + strings_lbl = mkStringLitLabel u2 + entries_lbl = mkStringLitLabel u3 + + ctx = stgToCmmContext cfg platform = stgToCmmPlatform cfg + int n = mkIntCLit platform n - let (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) - let -- Emit the fields of an IpeBufferEntry struct. - toIpeBufferEntry :: CgInfoProvEnt -> [CmmLit] - toIpeBufferEntry cg_ipe = - [ CmmLabel (ipeInfoTablePtr cg_ipe) - , strtab_offset (ipeTableName cg_ipe) - , strtab_offset (ipeClosureDesc cg_ipe) - , strtab_offset (ipeTypeDesc cg_ipe) - , strtab_offset (ipeLabel cg_ipe) - , strtab_offset (ipeModuleName cg_ipe) - , strtab_offset (ipeSrcFile cg_ipe) - , strtab_offset (ipeSrcSpan cg_ipe) - , int32 0 - ] + tables :: [CmmStatic] + tables = map (CmmStaticLit . CmmLabel . ipeInfoTablePtr) cg_ipes - int n = mkIntCLit platform n - int32 n = CmmInt n W32 - strtab_offset (StrTabOffset n) = int32 (fromIntegral n) + uncompressed_strings :: BS.ByteString + uncompressed_strings = getStringTableStrings strtab - strings <- newByteStringCLit (getStringTableStrings strtab) - let lits = [ zeroCLit platform -- 'next' field - , strings -- 'strings' field - , int $ length cg_ipes -- 'count' field - ] ++ concatMap toIpeBufferEntry cg_ipes - emitDataLits (mkIPELabel this_mod) lits + strings_bytes :: BS.ByteString + strings_bytes = compress defaultCompressionLevel uncompressed_strings -toCgIPE :: Platform -> SDocContext -> StrTabOffset -> InfoProvEnt -> State StringTable CgInfoProvEnt -toCgIPE platform ctx module_name ipe = do + strings :: [CmmStatic] + strings = [CmmString strings_bytes] + + uncompressed_entries :: BS.ByteString + uncompressed_entries = toIpeBufferEntries (platformByteOrder platform) cg_ipes + + entries_bytes :: BS.ByteString + entries_bytes = compress defaultCompressionLevel uncompressed_entries + + entries :: [CmmStatic] + entries = [CmmString entries_bytes] + + ipe_buffer_lbl :: CLabel + ipe_buffer_lbl = mkIPELabel this_mod + + ipe_buffer_node :: [CmmStatic] + ipe_buffer_node = map CmmStaticLit + [ -- 'next' field + zeroCLit platform + + -- 'compressed' field + , int do_compress + + -- 'count' field + , int $ length cg_ipes + + -- 'tables' field + , CmmLabel tables_lbl + + -- 'entries' field + , CmmLabel entries_lbl + + -- 'entries_size' field (decompressed size) + , int $ BS.length uncompressed_entries + + -- 'string_table' field + , CmmLabel strings_lbl + + -- '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 + emitDecl $ CmmData + (Section Data tables_lbl) + (CmmStaticsRaw tables_lbl tables) + + -- Emit the strings table + emitDecl $ CmmData + (Section Data strings_lbl) + (CmmStaticsRaw strings_lbl strings) + + -- Emit the list of IPE buffer entries + emitDecl $ CmmData + (Section Data entries_lbl) + (CmmStaticsRaw entries_lbl entries) + + -- Emit the IPE buffer list node + emitDecl $ CmmData + (Section Data ipe_buffer_lbl) + (CmmStaticsRaw ipe_buffer_lbl ipe_buffer_node) + + return dus3 + +-- | Emit the fields of an IpeBufferEntry struct for each entry in a given list. +toIpeBufferEntries :: + ByteOrder -- ^ Byte order to write the data in + -> [CgInfoProvEnt] -- ^ List of IPE buffer entries + -> BS.ByteString +toIpeBufferEntries byte_order cg_ipes = + BSL.toStrict . BSB.toLazyByteString . mconcat + $ map (mconcat . map word32Builder . to_ipe_buf_ent) cg_ipes + where + to_ipe_buf_ent :: CgInfoProvEnt -> [Word32] + to_ipe_buf_ent cg_ipe = + [ ipeTableName cg_ipe + , fromIntegral $ ipeClosureDesc cg_ipe + , ipeTypeDesc cg_ipe + , ipeLabel cg_ipe + , ipeSrcFile cg_ipe + , ipeSrcSpan cg_ipe + ] + + word32Builder :: Word32 -> BSB.Builder + word32Builder = case byte_order of + BigEndian -> BSB.word32BE + LittleEndian -> BSB.word32LE + +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 "" snd (infoTableProv ipe) + let label_str = maybe "" ((\(LexicalFastString s) -> unpackFS s) . snd) (infoTableProv ipe) let (src_loc_file, src_loc_span) = case infoTableProv ipe of - Nothing -> ("", "") + Nothing -> (mempty, "") Just (span, _) -> - let file = unpackFS $ srcSpanFile span + let file = fastStringToShortText $ srcSpanFile span coords = renderWithContext ctx (pprUserRealSpan False span) in (file, coords) - label <- lookupStringTable $ ST.pack label_str - src_file <- lookupStringTable $ ST.pack src_loc_file + label <- lookupStringTable $ ST.pack label_str + src_file <- lookupStringTable src_loc_file 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 } @@ -91,10 +230,9 @@ data CgInfoProvEnt = CgInfoProvEnt { ipeInfoTablePtr :: !CLabel , ipeTableName :: !StrTabOffset - , ipeClosureDesc :: !StrTabOffset + , ipeClosureDesc :: !Word32 , ipeTypeDesc :: !StrTabOffset , ipeLabel :: !StrTabOffset - , ipeModuleName :: !StrTabOffset , ipeSrcFile :: !StrTabOffset , ipeSrcSpan :: !StrTabOffset } @@ -104,7 +242,7 @@ , stLookup :: !(M.Map ShortText StrTabOffset) } -newtype StrTabOffset = StrTabOffset Int +type StrTabOffset = Word32 emptyStringTable :: StringTable emptyStringTable = @@ -129,8 +267,49 @@ , stLength = stLength st + ST.byteLength str + 1 , stLookup = M.insert str res (stLookup st) } - res = StrTabOffset (stLength st) + res = fromIntegral (stLength st) in (res, st') + +do_compress :: Int +compress :: Int -> BS.ByteString -> BS.ByteString +#if !defined(HAVE_LIBZSTD) +do_compress = 0 +compress _ bs = bs +#else +do_compress = 1 + +compress clvl (BSI.PS srcForeignPtr off len) = unsafePerformIO $ + withForeignPtr srcForeignPtr $ \srcPtr -> do + maxCompressedSize <- zstd_compress_bound $ fromIntegral len + dstForeignPtr <- BSI.mallocByteString (fromIntegral maxCompressedSize) + withForeignPtr dstForeignPtr $ \dstPtr -> do + compressedSize <- fromIntegral <$> + zstd_compress + dstPtr + maxCompressedSize + (srcPtr `plusPtr` off) + (fromIntegral len) + (fromIntegral clvl) + BSI.create compressedSize $ \p -> copyBytes p dstPtr compressedSize + +foreign import ccall unsafe "ZSTD_compress" + zstd_compress :: + Ptr dst -- ^ Destination buffer + -> CSize -- ^ Capacity of destination buffer + -> Ptr src -- ^ Source buffer + -> CSize -- ^ Size of source buffer + -> CInt -- ^ Compression level + -> IO CSize + +-- | Compute the maximum compressed size for a given source buffer size +foreign import ccall unsafe "ZSTD_compressBound" + zstd_compress_bound :: + CSize -- ^ Size of source buffer + -> IO CSize +#endif + +defaultCompressionLevel :: Int +defaultCompressionLevel = 3 newtype DList a = DList ([a] -> [a]) 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 @@ -155,9 +154,10 @@ adjust_words = vHp -rHp ; new_hp <- getHpRelOffset vHp + ; platform <- getPlatform ; emit (if adjust_words == 0 then mkNop - else mkAssign hpReg new_hp) -- Generates nothing when vHp==rHp + else mkAssign (hpReg platform) new_hp) -- Generates nothing when vHp==rHp ; tickyAllocHeap False adjust_words -- ...ditto @@ -305,10 +305,11 @@ | otherwise -- Note [over-saturated calls] = do do_scc_prof <- stgToCmmSCCProfiling <$> getStgToCmmConfig + platform <- getPlatform emitCallWithExtraStack (call_conv, NativeReturn) target (nonVArgs fast_args) - (nonVArgs (slowArgs rest_args do_scc_prof)) + (nonVArgs (slowArgs platform rest_args do_scc_prof)) where target = CmmLit (CmmLabel lbl) (fast_args, rest_args) = splitAt real_arity args @@ -327,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 [] = [] @@ -375,20 +376,29 @@ -- | 'slowArgs' takes a list of function arguments and prepares them for -- pushing on the stack for "extra" arguments to a function which requires -- fewer arguments than we currently have. -slowArgs :: [(ArgRep, Maybe CmmExpr)] -> DoSCCProfiling -> [(ArgRep, Maybe CmmExpr)] -slowArgs [] _ = mempty -slowArgs args sccProfilingEnabled -- careful: reps contains voids (V), but args does not - | sccProfilingEnabled = save_cccs ++ this_pat ++ slowArgs rest_args sccProfilingEnabled - | otherwise = this_pat ++ slowArgs rest_args sccProfilingEnabled - where - (arg_pat, n) = slowCallPattern (map fst args) - (call_args, rest_args) = splitAt n args +slowArgs :: Platform -> [(ArgRep, Maybe CmmExpr)] -> DoSCCProfiling -> [(ArgRep, Maybe CmmExpr)] +slowArgs platform args sccProfilingEnabled -- careful: reps contains voids (V), but args does not + = 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)] - 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 ------------------------------------------------------------------------- @@ -404,7 +414,7 @@ getHpRelOffset virtual_offset = do platform <- getPlatform hp_usg <- getHpUsage - return (cmmRegOffW platform hpReg (hpRel (realHp hp_usg) virtual_offset)) + return (cmmRegOffW platform (hpReg platform) (hpRel (realHp hp_usg) virtual_offset)) data FieldOffOrPadding a = FieldOff (NonVoid a) -- Something that needs an offset. @@ -437,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 @@ -519,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) ------------------------------------------------------------------------- -- @@ -554,7 +563,7 @@ argBits :: Platform -> [ArgRep] -> [Bool] -- True for non-ptr, False for ptr argBits _ [] = [] argBits platform (P : args) = False : argBits platform args -argBits platform (arg : args) = take (argRepSizeW platform arg) (repeat True) +argBits platform (arg : args) = replicate (argRepSizeW platform arg) True ++ argBits platform args ---------------------- @@ -602,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,10 +51,8 @@ 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 - LiftedRep -> idInfoToAmode <$> getCgIdInfo unitDataConId - UnliftedRep -> idInfoToAmode <$> getCgIdInfo unitDataConId + case expectOnly prim_reps of -- Note [Post-unarisation invariants] + BoxedRep _ -> idInfoToAmode <$> getCgIdInfo unitDataConId AddrRep -> cgLit LitNullAddr VecRep n elem -> do platform <- getPlatform @@ -99,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,3306 +1,3730 @@ {-# 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, 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, 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 - - MyThreadIdOp -> \[] -> opIntoRegs $ \[res] -> - emitAssign (CmmLocal res) currentTSOExpr - - 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 ] - - platform <- getPlatform - mkdirtyMutVarCCall <- getCode $! emitCCall - [{-no results-}] - (CmmLit (CmmLabel mkDirty_MUT_VAR_Label)) - [(baseExpr, AddrHint), (mutv, AddrHint), (CmmReg old_val, AddrHint)] - emit =<< mkCmmIfThen - (cmmEqWord platform (mkLblExpr mkMUT_VAR_CLEAN_infoLabel) - (closureInfoPtr platform (stgToCmmAlignCheck cfg) mutv)) - mkdirtyMutVarCCall - --- #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 - 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 - SetByteArrayOp -> \[ba,off,len,c] -> opIntoRegs $ \[] -> - doSetByteArrayOp ba off 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) - --- 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) - --- 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 - -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" - ------------------------------------------------------------------------------- --- 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 and x86_64 architecture. --- 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 -> check vecWidth vcat l w -- We are in a compatible backend - Just err -> sorry err -- incompatible backend, do panic - where - platform = stgToCmmPlatform cfg - check :: Width -> PrimOpVecCat -> Length -> Width -> FCode () - check W128 FloatVec 4 W32 | not (isSseEnabled platform) = - sorry $ "128-bit wide single-precision floating point " ++ - "SIMD vector instructions require at least -msse." - check W128 _ _ _ | not (isSse2Enabled platform) = - sorry $ "128-bit wide integer and double precision " ++ - "SIMD vector instructions require at least -msse2." - check W256 FloatVec _ _ | not (stgToCmmAvx cfg) = - sorry $ "256-bit wide floating point " ++ - "SIMD vector instructions require at least -mavx." - check W256 _ _ _ | not (stgToCmmAvx2 cfg) = - sorry $ "256-bit wide integer " ++ - "SIMD vector instructions require at least -mavx2." - check W512 _ _ _ | not (stgToCmmAvx512f cfg) = - sorry $ "512-bit wide " ++ - "SIMD vector instructions require -mavx512f." - check _ _ _ _ = 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 - [ (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 - -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 - --- | Takes a source 'ByteArray#', an offset in the source array, a --- destination 'Addr#', and the number of bytes to copy. Copies the given --- number of bytes from the source array to the destination memory region. -doCopyByteArrayToAddrOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> FCode () -doCopyByteArrayToAddrOp src src_off dst_p bytes = do - -- Use memcpy (we are allowed to assume the arrays aren't overlapping) - profile <- getProfile - platform <- getPlatform - whenCheckBounds $ ifNonZero bytes $ do - emitRangeBoundsCheck src_off bytes (byteArraySize platform profile src) - src_p <- assignTempE $ cmmOffsetExpr platform (cmmOffsetB platform src (arrWordsHdrSize profile)) src_off - emitCheckedMemcpyCall dst_p src_p bytes (mkAlignment 1) - --- | Takes a source 'MutableByteArray#', an offset in the source array, a --- destination 'Addr#', and the number of bytes to copy. Copies the given --- number of bytes from the source array to the destination memory region. -doCopyMutableByteArrayToAddrOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr - -> FCode () -doCopyMutableByteArrayToAddrOp = doCopyByteArrayToAddrOp - --- | Takes a source 'Addr#', 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 memory region to the destination array. -doCopyAddrToByteArrayOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> FCode () -doCopyAddrToByteArrayOp src_p dst dst_off bytes = do - -- Use memcpy (we are allowed to assume the arrays aren't overlapping) - profile <- getProfile - platform <- getPlatform - whenCheckBounds $ ifNonZero bytes $ do - emitRangeBoundsCheck dst_off bytes (byteArraySize platform profile dst) - dst_p <- assignTempE $ cmmOffsetExpr platform (cmmOffsetB platform dst (arrWordsHdrSize profile)) dst_off - emitCheckedMemcpyCall dst_p src_p bytes (mkAlignment 1) - -ifNonZero :: CmmExpr -> FCode () -> FCode () -ifNonZero e it = do - platform <- getPlatform - let pred = cmmNeWord platform e (zeroExpr platform) - code <- getCode it - emit =<< mkCmmIfThen' pred code (Just True) - -- This function is used for range operation bounds-checks; - -- Most calls to those ops will not have range length zero. - - --- ---------------------------------------------------------------------------- --- Setting byte arrays - --- | Takes a 'MutableByteArray#', an offset into the array, a length, --- and a byte, and sets each of the selected bytes in the array to the --- character. -doSetByteArrayOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr - -> FCode () -doSetByteArrayOp ba off len c = do - profile <- getProfile - platform <- getPlatform - - whenCheckBounds $ ifNonZero len $ - emitRangeBoundsCheck off len (byteArraySize platform profile ba) - - let byteArrayAlignment = wordAlignment platform -- known since BA is allocated on heap - offsetAlignment = cmmExprAlignment off - align = min byteArrayAlignment offsetAlignment - - p <- assignTempE $ cmmOffsetExpr platform (cmmOffsetB platform ba (arrWordsHdrSize profile)) off - emitMemsetCall p c len align - --- ---------------------------------------------------------------------------- --- Allocating arrays - --- | Allocate a new array. -doNewArrayOp :: CmmFormal -- ^ return register - -> SMRep -- ^ representation of the array - -> CLabel -- ^ info pointer - -> [(CmmExpr, ByteOff)] -- ^ header payload - -> WordOff -- ^ array size - -> CmmExpr -- ^ initial element - -> FCode () -doNewArrayOp res_r rep info payload n init = do - profile <- getProfile - platform <- getPlatform - - let info_ptr = mkLblExpr info - - tickyAllocPrim (mkIntExpr platform (hdrSize profile rep)) - (mkIntExpr platform (nonHdrSize platform rep)) - (zeroExpr platform) - - base <- allocHeapClosure rep info_ptr cccsExpr payload - - arr <- CmmLocal `fmap` newTemp (bWord platform) - emit $ mkAssign arr base - - -- Initialise all elements of the array - let mkOff off = cmmOffsetW platform (CmmReg arr) (hdrSizeW profile rep + off) - initialization = [ mkStore (mkOff off) init | off <- [0.. n - 1] ] - emit (catAGraphs initialization) - - emit $ mkAssign (CmmLocal res_r) (CmmReg arr) - --- ---------------------------------------------------------------------------- --- Copying pointer arrays - --- EZY: This code has an unusually high amount of assignTemp calls, seen --- nowhere else in the code generator. This is mostly because these --- "primitive" ops result in a surprisingly large amount of code. It --- will likely be worthwhile to optimize what is emitted here, so that --- our optimization passes don't waste time repeatedly optimizing the --- same bits of code. - --- More closely imitates 'assignTemp' from the old code generator, which --- returns a CmmExpr rather than a LocalReg. -assignTempE :: CmmExpr -> FCode CmmExpr -assignTempE e = do - t <- assignTemp e - return (CmmReg (CmmLocal t)) - --- | Takes a source 'Array#', an offset in the source array, a --- destination 'MutableArray#', an offset into the destination array, --- and the number of elements to copy. Copies the given number of --- elements from the source array to the destination array. -doCopyArrayOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> WordOff - -> FCode () -doCopyArrayOp = emitCopyArray 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 = - do platform <- getPlatform - emitCheckedMemcpyCall dst_p src_p (mkIntExpr platform bytes) - (wordAlignment platform) - - --- | Takes a source 'MutableArray#', an offset in the source array, a --- destination 'MutableArray#', an offset into the destination array, --- and the number of elements to copy. Copies the given number of --- elements from the source array to the destination array. -doCopyMutableArrayOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> WordOff - -> FCode () -doCopyMutableArrayOp = emitCopyArray 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 = do - platform <- getPlatform - (moveCall, cpyCall) <- forkAltPair - (getCode $ emitMemmoveCall dst_p src_p (mkIntExpr platform bytes) - (wordAlignment platform)) - (getCode $ emitMemcpyCall dst_p src_p (mkIntExpr platform bytes) - (wordAlignment platform)) - emit =<< mkCmmIfThenElse (cmmEqWord platform src dst) moveCall cpyCall - -emitCopyArray :: (CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> ByteOff - -> FCode ()) -- ^ copy function - -> CmmExpr -- ^ source array - -> CmmExpr -- ^ offset in source array - -> CmmExpr -- ^ destination array - -> CmmExpr -- ^ offset in destination array - -> WordOff -- ^ number of elements to copy - -> FCode () -emitCopyArray copy src0 src_off dst0 dst_off0 n = - when (n /= 0) $ do - profile <- getProfile - platform <- getPlatform - - -- Passed as arguments (be careful) - src <- assignTempE src0 - dst <- assignTempE dst0 - dst_off <- assignTempE dst_off0 - - whenCheckBounds $ do - emitRangeBoundsCheck src_off (mkIntExpr platform n) - (ptrArraySize platform profile src) - emitRangeBoundsCheck dst_off (mkIntExpr platform n) - (ptrArraySize platform profile dst) - - -- Nonmoving collector write barrier - emitCopyUpdRemSetPush platform (arrPtrsHdrSize profile) dst dst_off n - - -- Set the dirty bit in the header. - emit (setInfo dst (CmmLit (CmmLabel mkMAP_DIRTY_infoLabel))) - - dst_elems_p <- assignTempE $ cmmOffsetB platform dst - (arrPtrsHdrSize profile) - dst_p <- assignTempE $ cmmOffsetExprW platform dst_elems_p dst_off - src_p <- assignTempE $ cmmOffsetExprW platform - (cmmOffsetB platform src (arrPtrsHdrSize profile)) src_off - let bytes = wordsToBytes platform n - - copy src dst dst_p src_p bytes - - -- The base address of the destination card table - dst_cards_p <- assignTempE $ cmmOffsetExprW platform dst_elems_p - (ptrArraySize platform profile dst) - - emitSetCards dst_off dst_cards_p n - -doCopySmallArrayOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> WordOff - -> FCode () -doCopySmallArrayOp = emitCopySmallArray 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 = - do platform <- getPlatform - emitCheckedMemcpyCall dst_p src_p (mkIntExpr platform bytes) - (wordAlignment platform) - - -doCopySmallMutableArrayOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> WordOff - -> FCode () -doCopySmallMutableArrayOp = emitCopySmallArray 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 = do - platform <- getPlatform - (moveCall, cpyCall) <- forkAltPair - (getCode $ emitMemmoveCall dst_p src_p (mkIntExpr platform bytes) - (wordAlignment platform)) - (getCode $ emitMemcpyCall dst_p src_p (mkIntExpr platform bytes) - (wordAlignment platform)) - emit =<< mkCmmIfThenElse (cmmEqWord platform src dst) moveCall cpyCall - -emitCopySmallArray :: (CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> ByteOff - -> FCode ()) -- ^ copy function - -> CmmExpr -- ^ source array - -> CmmExpr -- ^ offset in source array - -> CmmExpr -- ^ destination array - -> CmmExpr -- ^ offset in destination array - -> WordOff -- ^ number of elements to copy - -> FCode () -emitCopySmallArray copy src0 src_off dst0 dst_off n = - when (n /= 0) $ do - profile <- getProfile - platform <- getPlatform - - -- Passed as arguments (be careful) - src <- assignTempE src0 - dst <- assignTempE dst0 - - whenCheckBounds $ do - emitRangeBoundsCheck src_off (mkIntExpr platform n) - (smallPtrArraySize platform profile src) - emitRangeBoundsCheck dst_off (mkIntExpr platform n) - (smallPtrArraySize platform profile dst) - - -- Nonmoving collector write barrier - emitCopyUpdRemSetPush platform (smallArrPtrsHdrSize profile) dst dst_off n - - -- Set the dirty bit in the header. - emit (setInfo dst (CmmLit (CmmLabel mkSMAP_DIRTY_infoLabel))) - - dst_p <- assignTempE $ cmmOffsetExprW platform - (cmmOffsetB platform dst (smallArrPtrsHdrSize profile)) dst_off - src_p <- assignTempE $ cmmOffsetExprW platform - (cmmOffsetB platform src (smallArrPtrsHdrSize profile)) src_off - let bytes = wordsToBytes platform n - - copy src dst dst_p src_p bytes - --- | Takes an info table label, a register to return the newly --- allocated array in, a source array, an offset in the source array, --- and the number of elements to copy. Allocates a new array and --- initializes it from the source array. -emitCloneArray :: CLabel -> CmmFormal -> CmmExpr -> CmmExpr -> WordOff - -> FCode () -emitCloneArray info_p res_r src src_off n = do - profile <- getProfile - platform <- getPlatform - - let info_ptr = mkLblExpr info_p - rep = arrPtrsRep platform n - - tickyAllocPrim (mkIntExpr platform (arrPtrsHdrSize profile)) - (mkIntExpr platform (nonHdrSize platform rep)) - (zeroExpr platform) - - let hdr_size = fixedHdrSize profile - constants = platformConstants platform - - base <- allocHeapClosure rep info_ptr cccsExpr - [ (mkIntExpr platform n, - hdr_size + pc_OFFSET_StgMutArrPtrs_ptrs constants) - , (mkIntExpr platform (nonHdrSizeW rep), - hdr_size + pc_OFFSET_StgMutArrPtrs_size constants) - ] - - arr <- CmmLocal `fmap` newTemp (bWord platform) - emit $ mkAssign arr base - - dst_p <- assignTempE $ cmmOffsetB platform (CmmReg arr) - (arrPtrsHdrSize profile) - src_p <- assignTempE $ cmmOffsetExprW platform src - (cmmAddWord platform - (mkIntExpr platform (arrPtrsHdrSizeW profile)) src_off) - - emitMemcpyCall dst_p src_p (mkIntExpr platform (wordsToBytes platform n)) - (wordAlignment platform) - - emit $ mkAssign (CmmLocal res_r) (CmmReg arr) - --- | Takes an info table label, a register to return the newly --- allocated array in, a source array, an offset in the source array, --- and the number of elements to copy. Allocates a new array and --- initializes it from the source array. -emitCloneSmallArray :: CLabel -> CmmFormal -> CmmExpr -> CmmExpr -> WordOff - -> FCode () -emitCloneSmallArray info_p res_r src src_off n = do - profile <- getProfile - platform <- getPlatform - - let info_ptr = mkLblExpr info_p - rep = smallArrPtrsRep n - - tickyAllocPrim (mkIntExpr platform (smallArrPtrsHdrSize profile)) - (mkIntExpr platform (nonHdrSize platform rep)) - (zeroExpr platform) - - let hdr_size = fixedHdrSize profile - - base <- allocHeapClosure rep info_ptr cccsExpr - [ (mkIntExpr platform n, - hdr_size + pc_OFFSET_StgSmallMutArrPtrs_ptrs (platformConstants platform)) - ] - - arr <- CmmLocal `fmap` newTemp (bWord platform) - emit $ mkAssign arr base - - dst_p <- assignTempE $ cmmOffsetB platform (CmmReg arr) - (smallArrPtrsHdrSize profile) - src_p <- assignTempE $ cmmOffsetExprW platform src - (cmmAddWord platform - (mkIntExpr platform (smallArrPtrsHdrSizeW profile)) src_off) - - emitMemcpyCall dst_p src_p (mkIntExpr platform (wordsToBytes platform n)) - (wordAlignment platform) - - emit $ mkAssign (CmmLocal res_r) (CmmReg arr) - --- | Takes an offset in the destination array, the base address of --- the card table, and the number of elements affected (*not* the --- number of cards). The number of elements may not be zero. --- Marks the relevant cards as dirty. -emitSetCards :: CmmExpr -> CmmExpr -> WordOff -> FCode () -emitSetCards dst_start dst_cards_start n = do - platform <- getPlatform - start_card <- assignTempE $ cardCmm platform dst_start - let end_card = cardCmm platform - (cmmSubWord platform - (cmmAddWord platform dst_start (mkIntExpr platform n)) - (mkIntExpr platform 1)) - emitMemsetCall (cmmAddWord platform dst_cards_start start_card) - (mkIntExpr platform 1) - (cmmAddWord platform (cmmSubWord platform end_card start_card) (mkIntExpr platform 1)) - (mkAlignment 1) -- no alignment (1 byte) - --- Convert an element index to a card index -cardCmm :: Platform -> CmmExpr -> CmmExpr -cardCmm platform i = - cmmUShrWord platform i (mkIntExpr platform (pc_MUT_ARR_PTRS_CARD_BITS (platformConstants platform))) - ------------------------------------------------------------------------------- --- SmallArray PrimOp implementations - -doReadSmallPtrArrayOp :: LocalReg - -> CmmExpr - -> CmmExpr - -> FCode () -doReadSmallPtrArrayOp res addr idx = do - profile <- getProfile - platform <- getPlatform - doSmallPtrArrayBoundsCheck idx addr - mkBasicIndexedRead True NaturallyAligned (smallArrPtrsHdrSize profile) Nothing (gcWord platform) res addr - (gcWord platform) idx - -doWriteSmallPtrArrayOp :: CmmExpr - -> CmmExpr - -> CmmExpr - -> FCode () -doWriteSmallPtrArrayOp addr idx val = do - profile <- getProfile - platform <- getPlatform - let ty = cmmExprType platform val - - doSmallPtrArrayBoundsCheck idx addr - - -- Update remembered set for non-moving collector - tmp <- newTemp ty - mkBasicIndexedRead False NaturallyAligned (smallArrPtrsHdrSize profile) Nothing ty tmp addr ty idx - whenUpdRemSetEnabled $ emitUpdRemSetPush (CmmReg (CmmLocal tmp)) - - -- Write barrier needed due to #12469 - mkBasicIndexedWrite True (smallArrPtrsHdrSize profile) addr ty idx val - emit (setInfo addr (CmmLit (CmmLabel mkSMAP_DIRTY_infoLabel))) - ------------------------------------------------------------------------------- --- Atomic read-modify-write - --- | Emit an atomic modification to a byte array element. The result --- reg contains that previous value of the element. Implies a full --- memory barrier. -doAtomicByteArrayRMW - :: LocalReg -- ^ Result reg - -> AtomicMachOp -- ^ Atomic op (e.g. add) - -> CmmExpr -- ^ MutableByteArray# - -> CmmExpr -- ^ Index - -> CmmType -- ^ Type of element by which we are indexing - -> CmmExpr -- ^ Op argument (e.g. amount to add) - -> FCode () -doAtomicByteArrayRMW res amop mba idx idx_ty n = do - profile <- getProfile - platform <- getPlatform - doByteArrayBoundsCheck idx mba idx_ty idx_ty - let width = typeWidth idx_ty - addr = cmmIndexOffExpr platform (arrWordsHdrSize profile) - width mba idx - doAtomicAddrRMW res amop addr idx_ty n - -doAtomicAddrRMW - :: LocalReg -- ^ Result reg - -> AtomicMachOp -- ^ Atomic op (e.g. add) - -> CmmExpr -- ^ Addr# - -> CmmType -- ^ Pointed value type - -> CmmExpr -- ^ Op argument (e.g. amount to add) - -> FCode () -doAtomicAddrRMW res amop addr ty n = - emitPrimCall - [ res ] - (MO_AtomicRMW (typeWidth ty) amop) - [ addr, n ] - --- | Emit an atomic read to a byte array that acts as a memory barrier. -doAtomicReadByteArray - :: LocalReg -- ^ Result reg - -> CmmExpr -- ^ MutableByteArray# - -> CmmExpr -- ^ Index - -> CmmType -- ^ Type of element by which we are indexing - -> FCode () -doAtomicReadByteArray res mba idx idx_ty = do - profile <- getProfile - platform <- getPlatform - doByteArrayBoundsCheck idx mba idx_ty idx_ty - let width = typeWidth idx_ty - addr = cmmIndexOffExpr platform (arrWordsHdrSize profile) - width mba idx - doAtomicReadAddr res addr idx_ty - --- | Emit an atomic read to an address that acts as a memory barrier. -doAtomicReadAddr - :: LocalReg -- ^ Result reg - -> CmmExpr -- ^ Addr# - -> CmmType -- ^ Type of element by which we are indexing - -> FCode () -doAtomicReadAddr res addr ty = - emitPrimCall - [ res ] - (MO_AtomicRead (typeWidth ty) MemOrderSeqCst) - [ addr ] - --- | Emit an atomic write to a byte array that acts as a memory barrier. -doAtomicWriteByteArray - :: CmmExpr -- ^ MutableByteArray# - -> CmmExpr -- ^ Index - -> CmmType -- ^ Type of element by which we are indexing - -> CmmExpr -- ^ Value to write - -> FCode () -doAtomicWriteByteArray mba idx idx_ty val = do - profile <- getProfile - platform <- getPlatform - doByteArrayBoundsCheck idx mba idx_ty idx_ty - let width = typeWidth idx_ty - addr = cmmIndexOffExpr platform (arrWordsHdrSize profile) - width mba idx - doAtomicWriteAddr addr idx_ty val - --- | Emit an atomic write to an address that acts as a memory barrier. -doAtomicWriteAddr - :: CmmExpr -- ^ Addr# - -> CmmType -- ^ Type of element by which we are indexing - -> CmmExpr -- ^ Value to write - -> FCode () -doAtomicWriteAddr addr ty val = - emitPrimCall - [ {- no results -} ] - (MO_AtomicWrite (typeWidth ty) MemOrderSeqCst) - [ addr, val ] - -doCasByteArray - :: LocalReg -- ^ Result reg - -> CmmExpr -- ^ MutableByteArray# - -> CmmExpr -- ^ Index - -> CmmType -- ^ Type of element by which we are indexing - -> CmmExpr -- ^ Old value - -> CmmExpr -- ^ New value - -> FCode () -doCasByteArray res mba idx idx_ty old new = do - profile <- getProfile - platform <- getPlatform - doByteArrayBoundsCheck idx mba idx_ty idx_ty - let width = typeWidth idx_ty - addr = cmmIndexOffExpr platform (arrWordsHdrSize profile) - width mba idx - emitPrimCall - [ res ] - (MO_Cmpxchg width) - [ addr, old, new ] - ------------------------------------------------------------------------------- --- Helpers for emitting function calls - --- | Emit a call to @memcpy@. -emitMemcpyCall :: CmmExpr -> CmmExpr -> CmmExpr -> Alignment -> FCode () -emitMemcpyCall dst src n align = - emitPrimCall - [ {-no results-} ] - (MO_Memcpy (alignmentBytes align)) - [ dst, src, n ] - --- | Emit a call to @memcpy@, but check for range --- overlap when -fcheck-prim-bounds is on. -emitCheckedMemcpyCall :: CmmExpr -> CmmExpr -> CmmExpr -> Alignment -> FCode () -emitCheckedMemcpyCall dst src n align = do - whenCheckBounds (getPlatform >>= doCheck) - emitMemcpyCall dst src n align - where - doCheck platform = do - overlapCheckFailed <- getCode $ - emitCCallNeverReturns [] (mkLblExpr mkMemcpyRangeOverlapLabel) [] - emit =<< mkCmmIfThen' rangesOverlap overlapCheckFailed (Just False) - where - rangesOverlap = (checkDiff dst src `or` checkDiff src dst) `ne` zero - checkDiff p q = (p `minus` q) `uLT` n - or = cmmOrWord platform - minus = cmmSubWord platform - uLT = cmmULtWord platform - ne = cmmNeWord platform - zero = zeroExpr platform - --- | Emit a call to @memmove@. -emitMemmoveCall :: CmmExpr -> CmmExpr -> CmmExpr -> Alignment -> FCode () -emitMemmoveCall dst src n align = - emitPrimCall - [ {- no results -} ] - (MO_Memmove (alignmentBytes align)) - [ dst, src, n ] - --- | Emit a call to @memset@. The second argument must fit inside an --- unsigned char. -emitMemsetCall :: CmmExpr -> CmmExpr -> CmmExpr -> Alignment -> FCode () -emitMemsetCall dst c n align = - emitPrimCall - [ {- no results -} ] - (MO_Memset (alignmentBytes align)) - [ dst, c, n ] - -emitMemcmpCall :: LocalReg -> CmmExpr -> CmmExpr -> CmmExpr -> Int -> FCode () -emitMemcmpCall res ptr1 ptr2 n align = do - -- 'MO_Memcmp' is assumed to return an 32bit 'CInt' because all - -- code-gens currently call out to the @memcmp(3)@ C function. - -- This was easier than moving the sign-extensions into - -- all the code-gens. - platform <- getPlatform - let is32Bit = typeWidth (localRegType res) == W32 - - cres <- if is32Bit - then return res - else newTemp b32 - - emitPrimCall - [ cres ] - (MO_Memcmp align) - [ ptr1, ptr2, n ] - - unless is32Bit $ - emit $ mkAssign (CmmLocal res) - (CmmMachOp - (mo_s_32ToWord platform) - [(CmmReg (CmmLocal cres))]) - -emitBSwapCall :: LocalReg -> CmmExpr -> Width -> FCode () -emitBSwapCall res x width = - emitPrimCall - [ res ] - (MO_BSwap width) - [ x ] - -emitBRevCall :: LocalReg -> CmmExpr -> Width -> FCode () -emitBRevCall res x width = - emitPrimCall - [ res ] - (MO_BRev width) - [ x ] - -emitPopCntCall :: LocalReg -> CmmExpr -> Width -> FCode () -emitPopCntCall res x width = - emitPrimCall - [ res ] - (MO_PopCnt width) - [ x ] - -emitPdepCall :: LocalReg -> CmmExpr -> CmmExpr -> Width -> FCode () -emitPdepCall res x y width = - emitPrimCall - [ res ] - (MO_Pdep width) - [ x, y ] - -emitPextCall :: LocalReg -> CmmExpr -> CmmExpr -> Width -> FCode () -emitPextCall res x y width = - emitPrimCall - [ res ] - (MO_Pext width) - [ x, y ] - -emitClzCall :: LocalReg -> CmmExpr -> Width -> FCode () -emitClzCall res x width = - emitPrimCall - [ res ] - (MO_Clz width) - [ x ] - -emitCtzCall :: LocalReg -> CmmExpr -> Width -> FCode () -emitCtzCall res x width = - emitPrimCall - [ res ] - (MO_Ctz width) - [ x ] - ---------------------------------------------------------------------------- --- Array bounds checking ---------------------------------------------------------------------------- - -whenCheckBounds :: FCode () -> FCode () -whenCheckBounds a = do - config <- getStgToCmmConfig - case stgToCmmDoBoundsCheck config of - False -> pure () - True -> a - -emitBoundsCheck :: CmmExpr -- ^ accessed index - -> CmmExpr -- ^ array size (in elements) - -> FCode () -emitBoundsCheck idx sz = do - assertM (stgToCmmDoBoundsCheck <$> getStgToCmmConfig) - platform <- getPlatform - boundsCheckFailed <- getCode $ - emitCCallNeverReturns [] (mkLblExpr mkOutOfBoundsAccessLabel) [] - let isOutOfBounds = cmmUGeWord platform idx sz - emit =<< mkCmmIfThen' isOutOfBounds boundsCheckFailed (Just False) - -emitRangeBoundsCheck :: CmmExpr -- ^ first accessed index - -> CmmExpr -- ^ number of accessed indices (non-zero) - -> CmmExpr -- ^ array size (in elements) - -> FCode () -emitRangeBoundsCheck idx len arrSizeExpr = do - assertM (stgToCmmDoBoundsCheck <$> getStgToCmmConfig) - config <- getStgToCmmConfig - platform <- getPlatform - arrSize <- assignTempE arrSizeExpr - -- arrSizeExpr is probably a load we don't want to duplicate - rangeTooLargeReg <- newTemp (bWord platform) - lastSafeIndexReg <- newTemp (bWord platform) - _ <- withSequel (AssignTo [lastSafeIndexReg, rangeTooLargeReg] False) $ - cmmPrimOpApp config WordSubCOp [arrSize, len] Nothing - boundsCheckFailed <- getCode $ - emitCCallNeverReturns [] (mkLblExpr mkOutOfBoundsAccessLabel) [] - let - rangeTooLarge = CmmReg (CmmLocal rangeTooLargeReg) - lastSafeIndex = CmmReg (CmmLocal lastSafeIndexReg) - badStartIndex = (idx `uGT` lastSafeIndex) - isOutOfBounds = (rangeTooLarge `or` badStartIndex) `neq` zero - uGT = cmmUGtWord platform - or = cmmOrWord platform - neq = cmmNeWord platform - zero = zeroExpr platform - emit =<< mkCmmIfThen' isOutOfBounds boundsCheckFailed (Just False) - -doPtrArrayBoundsCheck - :: CmmExpr -- ^ accessed index (in bytes) - -> CmmExpr -- ^ pointer to @StgMutArrPtrs@ - -> FCode () -doPtrArrayBoundsCheck idx arr = whenCheckBounds $ do - profile <- getProfile - platform <- getPlatform - emitBoundsCheck idx (ptrArraySize platform profile arr) - -doSmallPtrArrayBoundsCheck - :: CmmExpr -- ^ accessed index (in bytes) - -> CmmExpr -- ^ pointer to @StgMutArrPtrs@ - -> FCode () -doSmallPtrArrayBoundsCheck idx arr = whenCheckBounds $ do - profile <- getProfile - platform <- getPlatform - emitBoundsCheck idx (smallPtrArraySize platform profile arr) - -doByteArrayBoundsCheck - :: CmmExpr -- ^ accessed index (in elements) - -> CmmExpr -- ^ pointer to @StgArrBytes@ - -> CmmType -- ^ indexing type - -> CmmType -- ^ element type - -> FCode () -doByteArrayBoundsCheck idx arr idx_ty elem_ty = whenCheckBounds $ do - profile <- getProfile - platform <- getPlatform - let elem_w = typeWidth elem_ty - idx_w = typeWidth idx_ty - elem_sz = mkIntExpr platform $ widthInBytes elem_w - arr_sz = byteArraySize platform profile arr - effective_arr_sz = - cmmUShrWord platform arr_sz (mkIntExpr platform (widthInLog idx_w)) - if elem_w == idx_w - then emitBoundsCheck idx effective_arr_sz -- aligned => simpler check - else assert (idx_w == W8) (emitRangeBoundsCheck idx elem_sz arr_sz) +{-# 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 + +-- | Takes a source 'ByteArray#', an offset in the source array, a +-- destination 'Addr#', and the number of bytes to copy. Copies the given +-- number of bytes from the source array to the destination memory region. +doCopyByteArrayToAddrOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> FCode () +doCopyByteArrayToAddrOp src src_off dst_p bytes = do + -- Use memcpy (we are allowed to assume the arrays aren't overlapping) + profile <- getProfile + platform <- getPlatform + whenCheckBounds $ ifNonZero bytes $ do + emitRangeBoundsCheck src_off bytes (byteArraySize platform profile src) + src_p <- assignTempE $ cmmOffsetExpr platform (cmmOffsetB platform src (arrWordsHdrSize profile)) src_off + emitCheckedMemcpyCall dst_p src_p bytes (mkAlignment 1) + +-- | Takes a source 'MutableByteArray#', an offset in the source array, a +-- destination 'Addr#', and the number of bytes to copy. Copies the given +-- number of bytes from the source array to the destination memory region. +doCopyMutableByteArrayToAddrOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr + -> FCode () +doCopyMutableByteArrayToAddrOp = doCopyByteArrayToAddrOp + +-- | Takes a source 'Addr#', 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 memory region to the destination array. +doCopyAddrToByteArrayOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> FCode () +doCopyAddrToByteArrayOp src_p dst dst_off bytes = do + -- Use memcpy (we are allowed to assume the arrays aren't overlapping) + profile <- getProfile + platform <- getPlatform + whenCheckBounds $ ifNonZero bytes $ do + emitRangeBoundsCheck dst_off bytes (byteArraySize platform profile dst) + dst_p <- assignTempE $ cmmOffsetExpr platform (cmmOffsetB platform dst (arrWordsHdrSize profile)) dst_off + emitCheckedMemcpyCall dst_p src_p bytes (mkAlignment 1) + +-- | Takes a source 'Addr#', a destination 'Addr#', and the number of +-- bytes to copy. Copies the given number of bytes from the source +-- memory region to the destination array. +doCopyAddrToAddrOp :: CmmExpr -> CmmExpr -> CmmExpr -> FCode () +doCopyAddrToAddrOp src_p dst_p bytes = do + -- Use memmove; the ranges may overlap + emitMemmoveCall dst_p src_p bytes (mkAlignment 1) + +-- | Takes a source 'Addr#', a destination 'Addr#', and the number of +-- bytes to copy. Copies the given number of bytes from the source +-- memory region to the destination region. The regions may not overlap. +doCopyAddrToAddrNonOverlappingOp :: CmmExpr -> CmmExpr -> CmmExpr -> FCode () +doCopyAddrToAddrNonOverlappingOp src_p dst_p bytes = do + -- Use memcpy; the ranges may not overlap + emitCheckedMemcpyCall dst_p src_p bytes (mkAlignment 1) + +ifNonZero :: CmmExpr -> FCode () -> FCode () +ifNonZero e it = do + platform <- getPlatform + let pred = cmmNeWord platform e (zeroExpr platform) + code <- getCode it + emit =<< mkCmmIfThen' pred code (Just True) + -- This function is used for range operation bounds-checks; + -- Most calls to those ops will not have range length zero. + + +-- ---------------------------------------------------------------------------- +-- Setting byte arrays + +-- | Takes a 'MutableByteArray#', an offset into the array, a length, +-- and a byte, and sets each of the selected bytes in the array to the +-- given byte. +doSetByteArrayOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr + -> FCode () +doSetByteArrayOp ba off len c = do + profile <- getProfile + platform <- getPlatform + + whenCheckBounds $ ifNonZero len $ + emitRangeBoundsCheck off len (byteArraySize platform profile ba) + + let byteArrayAlignment = wordAlignment platform -- known since BA is allocated on heap + offsetAlignment = cmmExprAlignment off + align = min byteArrayAlignment offsetAlignment + + p <- assignTempE $ cmmOffsetExpr platform (cmmOffsetB platform ba (arrWordsHdrSize profile)) off + emitMemsetCall p c len align + +-- | Takes an 'Addr#', a length, and a byte, and sets each of the +-- selected bytes in memory to the given byte. +doSetAddrRangeOp :: CmmExpr -> CmmExpr -> CmmExpr + -> FCode () +doSetAddrRangeOp dst len c = do + emitMemsetCall dst c len (mkAlignment 1) + + +-- ---------------------------------------------------------------------------- +-- Allocating arrays + +-- | Allocate a new array. +doNewArrayOp :: CmmFormal -- ^ return register + -> SMRep -- ^ representation of the array + -> CLabel -- ^ info pointer + -> [(CmmExpr, ByteOff)] -- ^ header payload + -> WordOff -- ^ array size + -> CmmExpr -- ^ initial element + -> FCode () +doNewArrayOp res_r rep info payload n init = do + profile <- getProfile + platform <- getPlatform + + let info_ptr = mkLblExpr info + + tickyAllocPrim (mkIntExpr platform (hdrSize profile rep)) + (mkIntExpr platform (nonHdrSize platform rep)) + (zeroExpr platform) + + base <- allocHeapClosure rep info_ptr (cccsExpr platform) payload + + arr <- CmmLocal `fmap` newTemp (bWord platform) + emit $ mkAssign arr base + + -- Initialise all elements of the array + let mkOff off = cmmOffsetW platform (CmmReg arr) (hdrSizeW profile rep + off) + initialization = [ mkStore (mkOff off) init | off <- [0.. n - 1] ] + emit (catAGraphs initialization) + + emit $ mkAssign (CmmLocal res_r) (CmmReg arr) + +-- ---------------------------------------------------------------------------- +-- Copying pointer arrays + +-- EZY: This code has an unusually high amount of assignTemp calls, seen +-- nowhere else in the code generator. This is mostly because these +-- "primitive" ops result in a surprisingly large amount of code. It +-- will likely be worthwhile to optimize what is emitted here, so that +-- our optimization passes don't waste time repeatedly optimizing the +-- same bits of code. + +-- More closely imitates 'assignTemp' from the old code generator, which +-- returns a CmmExpr rather than a LocalReg. +assignTempE :: CmmExpr -> FCode CmmExpr +assignTempE e = do + t <- assignTemp e + return (CmmReg (CmmLocal t)) + +-- | Takes a source 'Array#', an offset in the source array, a +-- destination 'MutableArray#', an offset into the destination array, +-- and the number of elements to copy. Copies the given number of +-- elements from the source array to the destination array. +doCopyArrayOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> WordOff + -> FCode () +doCopyArrayOp = emitCopyArray 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 = + do platform <- getPlatform + emitCheckedMemcpyCall dst_p src_p (mkIntExpr platform bytes) + (wordAlignment platform) + + +-- | Takes a source 'MutableArray#', an offset in the source array, a +-- destination 'MutableArray#', an offset into the destination array, +-- and the number of elements to copy. Copies the given number of +-- elements from the source array to the destination array. +doCopyMutableArrayOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> WordOff + -> FCode () +doCopyMutableArrayOp = emitCopyArray 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 = do + platform <- getPlatform + (moveCall, cpyCall) <- forkAltPair + (getCode $ emitMemmoveCall dst_p src_p (mkIntExpr platform bytes) + (wordAlignment platform)) + (getCode $ emitMemcpyCall dst_p src_p (mkIntExpr platform bytes) + (wordAlignment platform)) + emit =<< mkCmmIfThenElse (cmmEqWord platform src dst) moveCall cpyCall + +emitCopyArray :: (CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> ByteOff + -> FCode ()) -- ^ copy function + -> CmmExpr -- ^ source array + -> CmmExpr -- ^ offset in source array + -> CmmExpr -- ^ destination array + -> CmmExpr -- ^ offset in destination array + -> WordOff -- ^ number of elements to copy + -> FCode () +emitCopyArray copy src0 src_off dst0 dst_off0 n = + when (n /= 0) $ do + profile <- getProfile + platform <- getPlatform + + -- Passed as arguments (be careful) + src <- assignTempE src0 + dst <- assignTempE dst0 + dst_off <- assignTempE dst_off0 + + whenCheckBounds $ do + emitRangeBoundsCheck src_off (mkIntExpr platform n) + (ptrArraySize platform profile src) + emitRangeBoundsCheck dst_off (mkIntExpr platform n) + (ptrArraySize platform profile dst) + + -- Nonmoving collector write barrier + emitCopyUpdRemSetPush platform (arrPtrsHdrSize profile) dst dst_off n + + -- Set the dirty bit in the header. + emit (setInfo dst (CmmLit (CmmLabel mkMAP_DIRTY_infoLabel))) + + dst_elems_p <- assignTempE $ cmmOffsetB platform dst + (arrPtrsHdrSize profile) + dst_p <- assignTempE $ cmmOffsetExprW platform dst_elems_p dst_off + src_p <- assignTempE $ cmmOffsetExprW platform + (cmmOffsetB platform src (arrPtrsHdrSize profile)) src_off + let bytes = wordsToBytes platform n + + copy src dst dst_p src_p bytes + + -- The base address of the destination card table + dst_cards_p <- assignTempE $ cmmOffsetExprW platform dst_elems_p + (ptrArraySize platform profile dst) + + emitSetCards dst_off dst_cards_p n + +doCopySmallArrayOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> WordOff + -> FCode () +doCopySmallArrayOp = emitCopySmallArray 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 = + do platform <- getPlatform + emitCheckedMemcpyCall dst_p src_p (mkIntExpr platform bytes) + (wordAlignment platform) + + +doCopySmallMutableArrayOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> WordOff + -> FCode () +doCopySmallMutableArrayOp = emitCopySmallArray 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 = do + platform <- getPlatform + (moveCall, cpyCall) <- forkAltPair + (getCode $ emitMemmoveCall dst_p src_p (mkIntExpr platform bytes) + (wordAlignment platform)) + (getCode $ emitMemcpyCall dst_p src_p (mkIntExpr platform bytes) + (wordAlignment platform)) + emit =<< mkCmmIfThenElse (cmmEqWord platform src dst) moveCall cpyCall + +emitCopySmallArray :: (CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> ByteOff + -> FCode ()) -- ^ copy function + -> CmmExpr -- ^ source array + -> CmmExpr -- ^ offset in source array + -> CmmExpr -- ^ destination array + -> CmmExpr -- ^ offset in destination array + -> WordOff -- ^ number of elements to copy + -> FCode () +emitCopySmallArray copy src0 src_off dst0 dst_off n = + when (n /= 0) $ do + profile <- getProfile + platform <- getPlatform + + -- Passed as arguments (be careful) + src <- assignTempE src0 + dst <- assignTempE dst0 + + whenCheckBounds $ do + emitRangeBoundsCheck src_off (mkIntExpr platform n) + (smallPtrArraySize platform profile src) + emitRangeBoundsCheck dst_off (mkIntExpr platform n) + (smallPtrArraySize platform profile dst) + + -- Nonmoving collector write barrier + emitCopyUpdRemSetPush platform (smallArrPtrsHdrSize profile) dst dst_off n + + -- Set the dirty bit in the header. + emit (setInfo dst (CmmLit (CmmLabel mkSMAP_DIRTY_infoLabel))) + + dst_p <- assignTempE $ cmmOffsetExprW platform + (cmmOffsetB platform dst (smallArrPtrsHdrSize profile)) dst_off + src_p <- assignTempE $ cmmOffsetExprW platform + (cmmOffsetB platform src (smallArrPtrsHdrSize profile)) src_off + let bytes = wordsToBytes platform n + + copy src dst dst_p src_p bytes + +-- | Takes an info table label, a register to return the newly +-- allocated array in, a source array, an offset in the source array, +-- and the number of elements to copy. Allocates a new array and +-- initializes it from the source array. +emitCloneArray :: CLabel -> CmmFormal -> CmmExpr -> CmmExpr -> WordOff + -> FCode () +emitCloneArray info_p res_r src src_off n = do + profile <- getProfile + platform <- getPlatform + + let info_ptr = mkLblExpr info_p + rep = arrPtrsRep platform n + + tickyAllocPrim (mkIntExpr platform (arrPtrsHdrSize profile)) + (mkIntExpr platform (nonHdrSize platform rep)) + (zeroExpr platform) + + let hdr_size = fixedHdrSize profile + constants = platformConstants platform + + base <- allocHeapClosure rep info_ptr (cccsExpr platform) + [ (mkIntExpr platform n, + hdr_size + pc_OFFSET_StgMutArrPtrs_ptrs constants) + , (mkIntExpr platform (nonHdrSizeW rep), + hdr_size + pc_OFFSET_StgMutArrPtrs_size constants) + ] + + arr <- CmmLocal `fmap` newTemp (bWord platform) + emit $ mkAssign arr base + + dst_p <- assignTempE $ cmmOffsetB platform (CmmReg arr) + (arrPtrsHdrSize profile) + src_p <- assignTempE $ cmmOffsetExprW platform src + (cmmAddWord platform + (mkIntExpr platform (arrPtrsHdrSizeW profile)) src_off) + + emitMemcpyCall dst_p src_p (mkIntExpr platform (wordsToBytes platform n)) + (wordAlignment platform) + + emit $ mkAssign (CmmLocal res_r) (CmmReg arr) + +-- | Takes an info table label, a register to return the newly +-- allocated array in, a source array, an offset in the source array, +-- and the number of elements to copy. Allocates a new array and +-- initializes it from the source array. +emitCloneSmallArray :: CLabel -> CmmFormal -> CmmExpr -> CmmExpr -> WordOff + -> FCode () +emitCloneSmallArray info_p res_r src src_off n = do + profile <- getProfile + platform <- getPlatform + + let info_ptr = mkLblExpr info_p + rep = smallArrPtrsRep n + + tickyAllocPrim (mkIntExpr platform (smallArrPtrsHdrSize 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_StgSmallMutArrPtrs_ptrs (platformConstants platform)) + ] + + arr <- CmmLocal `fmap` newTemp (bWord platform) + emit $ mkAssign arr base + + dst_p <- assignTempE $ cmmOffsetB platform (CmmReg arr) + (smallArrPtrsHdrSize profile) + src_p <- assignTempE $ cmmOffsetExprW platform src + (cmmAddWord platform + (mkIntExpr platform (smallArrPtrsHdrSizeW profile)) src_off) + + emitMemcpyCall dst_p src_p (mkIntExpr platform (wordsToBytes platform n)) + (wordAlignment platform) + + emit $ mkAssign (CmmLocal res_r) (CmmReg arr) + +-- | Takes an offset in the destination array, the base address of +-- the card table, and the number of elements affected (*not* the +-- number of cards). The number of elements may not be zero. +-- Marks the relevant cards as dirty. +emitSetCards :: CmmExpr -> CmmExpr -> WordOff -> FCode () +emitSetCards dst_start dst_cards_start n = do + platform <- getPlatform + start_card <- assignTempE $ cardCmm platform dst_start + let end_card = cardCmm platform + (cmmSubWord platform + (cmmAddWord platform dst_start (mkIntExpr platform n)) + (mkIntExpr platform 1)) + emitMemsetCall (cmmAddWord platform dst_cards_start start_card) + (mkIntExpr platform 1) + (cmmAddWord platform (cmmSubWord platform end_card start_card) (mkIntExpr platform 1)) + (mkAlignment 1) -- no alignment (1 byte) + +-- Convert an element index to a card index +cardCmm :: Platform -> CmmExpr -> CmmExpr +cardCmm platform i = + cmmUShrWord platform i (mkIntExpr platform (pc_MUT_ARR_PTRS_CARD_BITS (platformConstants platform))) + +------------------------------------------------------------------------------ +-- SmallArray PrimOp implementations + +doReadSmallPtrArrayOp :: LocalReg + -> CmmExpr + -> CmmExpr + -> FCode () +doReadSmallPtrArrayOp res addr idx = do + profile <- getProfile + platform <- getPlatform + doSmallPtrArrayBoundsCheck idx addr + mkBasicIndexedRead True NaturallyAligned (smallArrPtrsHdrSize profile) Nothing (gcWord platform) res addr + (gcWord platform) idx + +doWriteSmallPtrArrayOp :: CmmExpr + -> CmmExpr + -> CmmExpr + -> FCode () +doWriteSmallPtrArrayOp addr idx val = do + profile <- getProfile + platform <- getPlatform + let ty = cmmExprType platform val + + doSmallPtrArrayBoundsCheck idx addr + + -- Update remembered set for non-moving collector + tmp <- newTemp ty + mkBasicIndexedRead False NaturallyAligned (smallArrPtrsHdrSize profile) Nothing ty tmp addr ty idx + whenUpdRemSetEnabled $ emitUpdRemSetPush (CmmReg (CmmLocal tmp)) + + -- Write barrier needed due to #12469 + mkBasicIndexedWrite True (smallArrPtrsHdrSize profile) addr ty idx val + emit (setInfo addr (CmmLit (CmmLabel mkSMAP_DIRTY_infoLabel))) + +------------------------------------------------------------------------------ +-- Atomic read-modify-write + +-- | Emit an atomic modification to a byte array element. The result +-- reg contains that previous value of the element. Implies a full +-- memory barrier. +doAtomicByteArrayRMW + :: LocalReg -- ^ Result reg + -> AtomicMachOp -- ^ Atomic op (e.g. add) + -> CmmExpr -- ^ MutableByteArray# + -> CmmExpr -- ^ Index + -> CmmType -- ^ Type of element by which we are indexing + -> CmmExpr -- ^ Op argument (e.g. amount to add) + -> FCode () +doAtomicByteArrayRMW res amop mba idx idx_ty n = do + profile <- getProfile + platform <- getPlatform + doByteArrayBoundsCheck idx mba idx_ty idx_ty + let width = typeWidth idx_ty + addr = cmmIndexOffExpr platform (arrWordsHdrSize profile) + width mba idx + doAtomicAddrRMW res amop addr idx_ty n + +doAtomicAddrRMW + :: LocalReg -- ^ Result reg + -> AtomicMachOp -- ^ Atomic op (e.g. add) + -> CmmExpr -- ^ Addr# + -> CmmType -- ^ Pointed value type + -> CmmExpr -- ^ Op argument (e.g. amount to add) + -> FCode () +doAtomicAddrRMW res amop addr ty n = + emitPrimCall + [ res ] + (MO_AtomicRMW (typeWidth ty) amop) + [ addr, n ] + +-- | Emit an atomic read to a byte array that acts as a memory barrier. +doAtomicReadByteArray + :: LocalReg -- ^ Result reg + -> CmmExpr -- ^ MutableByteArray# + -> CmmExpr -- ^ Index + -> CmmType -- ^ Type of element by which we are indexing + -> FCode () +doAtomicReadByteArray res mba idx idx_ty = do + profile <- getProfile + platform <- getPlatform + doByteArrayBoundsCheck idx mba idx_ty idx_ty + let width = typeWidth idx_ty + addr = cmmIndexOffExpr platform (arrWordsHdrSize profile) + width mba idx + doAtomicReadAddr res addr idx_ty + +-- | Emit an atomic read to an address that acts as a memory barrier. +doAtomicReadAddr + :: LocalReg -- ^ Result reg + -> CmmExpr -- ^ Addr# + -> CmmType -- ^ Type of element by which we are indexing + -> FCode () +doAtomicReadAddr res addr ty = + emitPrimCall + [ res ] + (MO_AtomicRead (typeWidth ty) MemOrderSeqCst) + [ addr ] + +-- | Emit an atomic write to a byte array that acts as a memory barrier. +doAtomicWriteByteArray + :: CmmExpr -- ^ MutableByteArray# + -> CmmExpr -- ^ Index + -> CmmType -- ^ Type of element by which we are indexing + -> CmmExpr -- ^ Value to write + -> FCode () +doAtomicWriteByteArray mba idx idx_ty val = do + profile <- getProfile + platform <- getPlatform + doByteArrayBoundsCheck idx mba idx_ty idx_ty + let width = typeWidth idx_ty + addr = cmmIndexOffExpr platform (arrWordsHdrSize profile) + width mba idx + doAtomicWriteAddr addr idx_ty val + +-- | Emit an atomic write to an address that acts as a memory barrier. +doAtomicWriteAddr + :: CmmExpr -- ^ Addr# + -> CmmType -- ^ Type of element by which we are indexing + -> CmmExpr -- ^ Value to write + -> FCode () +doAtomicWriteAddr addr ty val = + emitPrimCall + [ {- no results -} ] + (MO_AtomicWrite (typeWidth ty) MemOrderSeqCst) + [ addr, val ] + +doCasByteArray + :: LocalReg -- ^ Result reg + -> CmmExpr -- ^ MutableByteArray# + -> CmmExpr -- ^ Index + -> CmmType -- ^ Type of element by which we are indexing + -> CmmExpr -- ^ Old value + -> CmmExpr -- ^ New value + -> FCode () +doCasByteArray res mba idx idx_ty old new = do + profile <- getProfile + platform <- getPlatform + doByteArrayBoundsCheck idx mba idx_ty idx_ty + let width = typeWidth idx_ty + addr = cmmIndexOffExpr platform (arrWordsHdrSize profile) + width mba idx + emitPrimCall + [ res ] + (MO_Cmpxchg width) + [ addr, old, new ] + +------------------------------------------------------------------------------ +-- Helpers for emitting function calls + +-- | Emit a call to @memcpy@. +emitMemcpyCall :: CmmExpr -> CmmExpr -> CmmExpr -> Alignment -> FCode () +emitMemcpyCall dst src n align = + emitPrimCall + [ {-no results-} ] + (MO_Memcpy (alignmentBytes align)) + [ dst, src, n ] + +-- | Emit a call to @memcpy@, but check for range +-- overlap when -fcheck-prim-bounds is on. +emitCheckedMemcpyCall :: CmmExpr -> CmmExpr -> CmmExpr -> Alignment -> FCode () +emitCheckedMemcpyCall dst src n align = do + whenCheckBounds (getPlatform >>= doCheck) + emitMemcpyCall dst src n align + where + doCheck platform = do + overlapCheckFailed <- getCode $ + emitCCallNeverReturns [] (mkLblExpr mkMemcpyRangeOverlapLabel) [] + emit =<< mkCmmIfThen' rangesOverlap overlapCheckFailed (Just False) + where + rangesOverlap = (checkDiff dst src `or` checkDiff src dst) `ne` zero + checkDiff p q = (p `minus` q) `uLT` n + or = cmmOrWord platform + minus = cmmSubWord platform + uLT = cmmULtWord platform + ne = cmmNeWord platform + zero = zeroExpr platform + +-- | Emit a call to @memmove@. +emitMemmoveCall :: CmmExpr -> CmmExpr -> CmmExpr -> Alignment -> FCode () +emitMemmoveCall dst src n align = + emitPrimCall + [ {- no results -} ] + (MO_Memmove (alignmentBytes align)) + [ dst, src, n ] + +-- | Emit a call to @memset@. The second argument must fit inside an +-- unsigned char. +emitMemsetCall :: CmmExpr -> CmmExpr -> CmmExpr -> Alignment -> FCode () +emitMemsetCall dst c n align = + emitPrimCall + [ {- no results -} ] + (MO_Memset (alignmentBytes align)) + [ dst, c, n ] + +emitMemcmpCall :: LocalReg -> CmmExpr -> CmmExpr -> CmmExpr -> Int -> FCode () +emitMemcmpCall res ptr1 ptr2 n align = do + -- 'MO_Memcmp' is assumed to return an 32bit 'CInt' because all + -- code-gens currently call out to the @memcmp(3)@ C function. + -- This was easier than moving the sign-extensions into + -- all the code-gens. + platform <- getPlatform + let is32Bit = typeWidth (localRegType res) == W32 + + cres <- if is32Bit + then return res + else newTemp b32 + + emitPrimCall + [ cres ] + (MO_Memcmp align) + [ ptr1, ptr2, n ] + + unless is32Bit $ + emit $ mkAssign (CmmLocal res) + (CmmMachOp + (mo_s_32ToWord platform) + [(CmmReg (CmmLocal cres))]) + +emitBSwapCall :: LocalReg -> CmmExpr -> Width -> FCode () +emitBSwapCall res x width = + emitPrimCall + [ res ] + (MO_BSwap width) + [ x ] + +emitBRevCall :: LocalReg -> CmmExpr -> Width -> FCode () +emitBRevCall res x width = + emitPrimCall + [ res ] + (MO_BRev width) + [ x ] + +emitPopCntCall :: LocalReg -> CmmExpr -> Width -> FCode () +emitPopCntCall res x width = + emitPrimCall + [ res ] + (MO_PopCnt width) + [ x ] + +emitPdepCall :: LocalReg -> CmmExpr -> CmmExpr -> Width -> FCode () +emitPdepCall res x y width = + emitPrimCall + [ res ] + (MO_Pdep width) + [ x, y ] + +emitPextCall :: LocalReg -> CmmExpr -> CmmExpr -> Width -> FCode () +emitPextCall res x y width = + emitPrimCall + [ res ] + (MO_Pext width) + [ x, y ] + +emitClzCall :: LocalReg -> CmmExpr -> Width -> FCode () +emitClzCall res x width = + emitPrimCall + [ res ] + (MO_Clz width) + [ x ] + +emitCtzCall :: LocalReg -> CmmExpr -> Width -> FCode () +emitCtzCall res x width = + emitPrimCall + [ res ] + (MO_Ctz width) + [ x ] + +--------------------------------------------------------------------------- +-- Array bounds checking +--------------------------------------------------------------------------- + +whenCheckBounds :: FCode () -> FCode () +whenCheckBounds a = do + config <- getStgToCmmConfig + case stgToCmmDoBoundsCheck config of + False -> pure () + True -> a + +emitBoundsCheck :: CmmExpr -- ^ accessed index + -> CmmExpr -- ^ array size (in elements) + -> FCode () +emitBoundsCheck idx sz = do + assertM (stgToCmmDoBoundsCheck <$> getStgToCmmConfig) + platform <- getPlatform + boundsCheckFailed <- getCode $ + emitCCallNeverReturns [] (mkLblExpr mkOutOfBoundsAccessLabel) [] + let isOutOfBounds = cmmUGeWord platform idx sz + emit =<< mkCmmIfThen' isOutOfBounds boundsCheckFailed (Just False) + +emitRangeBoundsCheck :: CmmExpr -- ^ first accessed index + -> CmmExpr -- ^ number of accessed indices (non-zero) + -> CmmExpr -- ^ array size (in elements) + -> FCode () +emitRangeBoundsCheck idx len arrSizeExpr = do + assertM (stgToCmmDoBoundsCheck <$> getStgToCmmConfig) + config <- getStgToCmmConfig + platform <- getPlatform + arrSize <- assignTempE arrSizeExpr + -- arrSizeExpr is probably a load we don't want to duplicate + rangeTooLargeReg <- newTemp (bWord platform) + lastSafeIndexReg <- newTemp (bWord platform) + _ <- withSequel (AssignTo [lastSafeIndexReg, rangeTooLargeReg] False) $ + cmmPrimOpApp config WordSubCOp [arrSize, len] Nothing + boundsCheckFailed <- getCode $ + emitCCallNeverReturns [] (mkLblExpr mkOutOfBoundsAccessLabel) [] + let + rangeTooLarge = CmmReg (CmmLocal rangeTooLargeReg) + lastSafeIndex = CmmReg (CmmLocal lastSafeIndexReg) + badStartIndex = (idx `uGT` lastSafeIndex) + isOutOfBounds = (rangeTooLarge `or` badStartIndex) `neq` zero + uGT = cmmUGtWord platform + or = cmmOrWord platform + neq = cmmNeWord platform + zero = zeroExpr platform + emit =<< mkCmmIfThen' isOutOfBounds boundsCheckFailed (Just False) + +doPtrArrayBoundsCheck + :: CmmExpr -- ^ accessed index (in bytes) + -> CmmExpr -- ^ pointer to @StgMutArrPtrs@ + -> FCode () +doPtrArrayBoundsCheck idx arr = whenCheckBounds $ do + profile <- getProfile + platform <- getPlatform + emitBoundsCheck idx (ptrArraySize platform profile arr) + +doSmallPtrArrayBoundsCheck + :: CmmExpr -- ^ accessed index (in bytes) + -> CmmExpr -- ^ pointer to @StgMutArrPtrs@ + -> FCode () +doSmallPtrArrayBoundsCheck idx arr = whenCheckBounds $ do + profile <- getProfile + platform <- getPlatform + emitBoundsCheck idx (smallPtrArraySize platform profile arr) + +doByteArrayBoundsCheck + :: CmmExpr -- ^ accessed index (in elements) + -> CmmExpr -- ^ pointer to @StgArrBytes@ + -> CmmType -- ^ indexing type + -> CmmType -- ^ element type + -> FCode () +doByteArrayBoundsCheck idx arr idx_ty elem_ty = whenCheckBounds $ do + profile <- getProfile + platform <- getPlatform + let elem_w = typeWidth elem_ty + idx_w = typeWidth idx_ty + elem_sz = mkIntExpr platform $ widthInBytes elem_w + arr_sz = byteArraySize platform profile arr + effective_arr_sz = + cmmUShrWord platform arr_sz (mkIntExpr platform (widthInLog idx_w)) + if elem_w == idx_w + then emitBoundsCheck idx effective_arr_sz -- aligned => simpler check + else assert (idx_w == W8) (emitRangeBoundsCheck idx elem_sz arr_sz) + +-- | Write barrier for @MUT_VAR@ modification. +emitDirtyMutVar :: CmmExpr -> CmmExpr -> FCode () +emitDirtyMutVar mutvar old_val = do + cfg <- getStgToCmmConfig + platform <- getPlatform + mkdirtyMutVarCCall <- getCode $! emitCCall + [{-no results-}] + (CmmLit (CmmLabel mkDirty_MUT_VAR_Label)) + [(baseExpr platform, AddrHint), (mutvar, AddrHint), (old_val, AddrHint)] + + emit =<< mkCmmIfThen + (cmmEqWord platform (mkLblExpr mkMUT_VAR_CLEAN_infoLabel) + (closureInfoPtr platform (stgToCmmAlignCheck cfg) mutvar)) + mkdirtyMutVarCCall --------------------------------------------------------------------------- -- Pushing to the update remembered set 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 @@ -71,8 +72,8 @@ ccType :: Platform -> CmmType -- Type of a cost centre ccType = bWord -storeCurCCS :: CmmExpr -> CmmAGraph -storeCurCCS = mkAssign cccsReg +storeCurCCS :: Platform -> CmmExpr -> CmmAGraph +storeCurCCS platform = mkAssign (cccsReg platform) mkCCostCentre :: CostCentre -> CmmLit mkCCostCentre cc = CmmLabel (mkCCLabel cc) @@ -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 @@ -103,7 +104,7 @@ initUpdFrameProf frame = ifProfiling $ -- frame->header.prof.ccs = CCCS do platform <- getPlatform - emitStore (cmmOffset platform frame (pc_OFFSET_StgHeader_ccs (platformConstants platform))) cccsExpr + emitStore (cmmOffset platform frame (pc_OFFSET_StgHeader_ccs (platformConstants platform))) (cccsExpr platform) -- frame->header.prof.hp.rs = NULL (or frame-header.prof.hp.ldvw = 0) -- is unnecessary because it is not used anyhow. @@ -144,14 +145,14 @@ if not sccProfilingEnabled then return Nothing else do local_cc <- newTemp (ccType platform) - emitAssign (CmmLocal local_cc) cccsExpr + emitAssign (CmmLocal local_cc) (cccsExpr platform) return (Just local_cc) -restoreCurrentCostCentre :: Maybe LocalReg -> FCode () -restoreCurrentCostCentre Nothing +restoreCurrentCostCentre :: Platform -> Maybe LocalReg -> FCode () +restoreCurrentCostCentre _ Nothing = return () -restoreCurrentCostCentre (Just local_cc) - = emit (storeCurCCS (CmmReg (CmmLocal local_cc))) +restoreCurrentCostCentre platform (Just local_cc) + = emit (storeCurCCS platform (CmmReg (CmmLocal local_cc))) ------------------------------------------------------------------------------- @@ -191,7 +192,7 @@ enterCostCentreThunk closure = ifProfiling $ do platform <- getPlatform - emit $ storeCurCCS (costCentreFrom platform closure) + emit $ storeCurCCS platform (costCentreFrom platform closure) enterCostCentreFun :: CostCentreStack -> CmmExpr -> FCode () enterCostCentreFun ccs closure = ifProfiling $ @@ -200,7 +201,7 @@ emitRtsCall rtsUnitId (fsLit "enterFunCCS") - [(baseExpr, AddrHint), (costCentreFrom platform closure, AddrHint)] + [(baseExpr platform, AddrHint), (costCentreFrom platform closure, AddrHint)] False -- otherwise we have a top-level function, nothing to do @@ -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 @@ -303,9 +304,9 @@ emitSetCCC cc tick push = ifProfiling $ do platform <- getPlatform tmp <- newTemp (ccsType platform) - pushCostCentre tmp cccsExpr cc + pushCostCentre tmp (cccsExpr platform) cc when tick $ emit (bumpSccCount platform (CmmReg (CmmLocal tmp))) - when push $ emit (storeCurCCS (CmmReg (CmmLocal tmp))) + when push $ emit (storeCurCCS platform (CmmReg (CmmLocal tmp))) pushCostCentre :: LocalReg -> CmmExpr -> CostCentre -> FCode () pushCostCentre result ccs cc @@ -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 @@ -810,7 +809,7 @@ bumpTickyAllocd :: CLabel -> Int -> FCode () bumpTickyAllocd lbl bytes = do platform <- getPlatform - bumpTickyLitBy (cmmLabelOffB lbl (pc_OFFSET_StgEntCounter_entry_count (platformConstants platform))) bytes + bumpTickyLitBy (cmmLabelOffB lbl (pc_OFFSET_StgEntCounter_allocd (platformConstants platform))) bytes bumpTickyTagSkip :: CLabel -> FCode () bumpTickyTagSkip lbl = do @@ -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] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -53,7 +52,7 @@ #16559, #15155, and wiki: commentary/rts/haskell-execution/pointer-tagging Conservative assumption here is made when we import an Id without a - LambdaFormInfo in the interface, in GHC.StgToCmm.Closure.mkLFImported. + LambdaFormInfo in the interface, in GHC.StgToCmm.Closure.importedIdLFInfo. So we arrange to always serialise this information into the interface file. The moving parts are: @@ -75,10 +74,26 @@ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ As described in `Note [Conveying CAF-info and LFInfo between modules]`, imported unlifted nullary datacons must have their LambdaFormInfo set to -reflect the fact that they are evaluated . This is necessary as otherwise +reflect the fact that they are evaluated. This is necessary as otherwise references to them may be passed untagged to code that expects tagged -references. +references because of the unlifted nature of the argument. +For example, in + + type T :: UnliftedType + data T = T1 + | T2 + + f :: T -> Int + f x = case x of T1 -> 1; T2 -> 2 + +`f` expects `x` to be evaluated and properly tagged due to its unliftedness. +We can guarantee all occurrences of `T1` and `T2` are considered evaluated and +are properly tagged by giving them the `LFCon` LambdaFormInfo which indicates +they are fully saturated constructor applications. +(The LambdaFormInfo is used to tag the pointer with the tag of the +constructor, in `litIdInfo`) + What may be less obvious is that this must be done for not only datacon workers but also *wrappers*. The reason is found in this program from #23146: @@ -109,11 +124,9 @@ of the unlifted nature of its arguments by omitting handling of the zero tag when scrutinising them. -The fix is straightforward: extend the logic in `mkLFImported` to cover -(nullary) datacon wrappers as well as workers. This is safe because we -know that the wrapper of a nullary datacon will be in WHNF, even if it -includes equalities evidence (since such equalities are not runtime -relevant). This fixed #23146. +The fix is straightforward: ensure we always construct a /correct/ LFInfo for +datacon workers and wrappers, and populate the `lfInfo` with it. See +Note [LFInfo of DataCon workers and wrappers]. This fixed #23146. See also Note [The LFInfo of Imported Ids] -} 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,23 +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 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 reg) - (CmmLoad (get_GlobalReg_addr platform reg) - (globalRegType platform reg) - NaturallyAligned) - + = let reg_ty = globalRegSpillType platform reg + ru = GlobalRegUse reg reg_ty + in mkAssign (CmmGlobal ru) + (CmmLoad (get_GlobalReg_addr platform reg) + reg_ty NaturallyAligned) ------------------------------------------------------------------------- -- @@ -583,21 +609,23 @@ -- remembered set. emitUpdRemSetPush :: CmmExpr -- ^ value of pointer which was overwritten -> FCode () -emitUpdRemSetPush ptr = +emitUpdRemSetPush ptr = do + platform <- getPlatform emitRtsCall rtsUnitId (fsLit "updateRemembSetPushClosure_") - [(CmmReg (CmmGlobal BaseReg), AddrHint), + [(CmmReg $ baseReg platform, AddrHint), (ptr, AddrHint)] False emitUpdRemSetPushThunk :: CmmExpr -- ^ the thunk -> FCode () -emitUpdRemSetPushThunk ptr = +emitUpdRemSetPushThunk ptr = do + platform <- getPlatform emitRtsCall rtsUnitId (fsLit "updateRemembSetPushThunk_") - [(CmmReg (CmmGlobal BaseReg), AddrHint), + [(CmmReg $ baseReg platform, AddrHint), (ptr, AddrHint)] False @@ -645,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]) @@ -658,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 @@ -666,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,1152 +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.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.CoreUtils -import GHC.StgToJS.Utils -import GHC.StgToJS.Rts.Types -import GHC.StgToJS.Stack -import GHC.StgToJS.Ids - -import GHC.Types.Literal -import GHC.Types.Id -import GHC.Types.Id.Info -import GHC.Types.CostCentre - -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.Encoding -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 - - -- Case: unpackCStringAppend# "some string"# str - -- - -- Generates h$appendToHsStringA(str, "some string"), which has a faster - -- decoding loop. - | [StgLitArg (LitString bs), x] <- args - , [top] <- concatMap typex_expr (ctxTarget ctx) - , getUnique i == unpackCStringAppendIdKey - , d <- utf8DecodeByteString bs - = do - prof <- csProf <$> getSettings - let profArg = if prof then [jCafCCS] else [] - a <- genArg x - return ( top |= app "h$appendToHsStringA" ([toJExpr d, toJExpr a] ++ profArg) - , ExprInline Nothing - ) - - -- 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 (might_be_a_function (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 [] $ jVar \i -> mconcat - [ i |= zero_ - , WhileStat False (i .<. Int 65536) $ mconcat - [ var "h$apply" .! i |= var "h$ap_gen" - , preIncrS i - ] - , i |= zero_ - , WhileStat False (i .<. Int 128) $ mconcat - [ var "h$paps" .! i |= var "h$pap_gen" - , preIncrS i - ] - , 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 = - TxtI "h$ap_gen_fast" ||= jLam \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 = func ||= body0 - where - -- special case for h$ap_0_0_fast - body0 = if nargs == 0 && nvars == 0 - then jLam (enter s r1) - else toJExpr (JFunc 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 - [ TxtI "h$e" ||= jLam (\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 - [TxtI createName ||= jLam \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)) - ] - , TxtI resName ||= jLam \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 = TxtI "h$moveRegs2" ||= jLam 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,23 +22,21 @@ , genIdArgI , genIdStackArgI , allocConStatic - , allocUnboxedConStatic - , allocateStaticList - , jsStaticArg , jsStaticArgs ) where import GHC.Prelude -import GHC.JS.Syntax +import GHC.JS.JStg.Syntax +import GHC.JS.Ident import GHC.JS.Make import GHC.StgToJS.DataCon import GHC.StgToJS.Types import GHC.StgToJS.Monad import GHC.StgToJS.Literal -import GHC.StgToJS.CoreUtils +import GHC.StgToJS.Utils import GHC.StgToJS.Profiling import GHC.StgToJS.Ids @@ -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 @@ -10,6 +10,15 @@ , assignClosure , CopyCC (..) , copyClosure + , mkClosure + -- $names + , allocData + , allocClsA + , dataName + , clsName + , dataFieldName + , varName + , jsClosureCount ) where @@ -18,27 +27,36 @@ import GHC.StgToJS.Heap import GHC.StgToJS.Types -import GHC.StgToJS.CoreUtils -import GHC.StgToJS.Regs (stack,sp) +import GHC.StgToJS.Utils import GHC.JS.Make -import GHC.JS.Syntax +import GHC.JS.JStg.Syntax +import GHC.JS.JStg.Monad +import GHC.JS.Ident +import GHC.Types.Unique.Map + +import Data.Array 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 @@ -55,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 @@ -65,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 @@ -77,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 @@ -98,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 = (ciVar ci ||= jLam 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) @@ -133,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 @@ -145,12 +175,88 @@ 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 ] <> case copy_cc of DontCopyCC -> mempty CopyCC -> closureCC t |= closureCC s + +mkClosure :: JStgExpr -> [JStgExpr] -> JStgExpr -> Maybe JStgExpr -> Closure +mkClosure info fields meta cc = Closure + { clInfo = info + , clField1 = x1 + , clField2 = x2 + , clMeta = meta + , clCC = cc + } + where + x1 = case fields of + [] -> null_ + x:_ -> x + x2 = case fields of + [] -> null_ + [_] -> null_ + [_,x] -> x + _:x:xs -> ValExpr . JHash . listToUniqMap $ zip (fmap dataFieldName [1..]) (x:xs) + + +------------------------------------------------------------------------------- +-- Name Caches +------------------------------------------------------------------------------- +-- $names + +-- | Cache "dXXX" field names +dataFieldCache :: Array Int FastString +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 +nFieldCache = 255 + +-- | We use this in the RTS to determine the number of generated closures. These closures use the names +-- cached here, so we bind them to the same number. +jsClosureCount :: Int +jsClosureCount = 24 + +dataFieldName :: Int -> FastString +dataFieldName i + | i < 0 || i > nFieldCache = mkFastString ('d' : show i) + | otherwise = dataFieldCache ! i + +-- | Cache "h$dXXX" names +dataCache :: Array Int FastString +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 -> JStgExpr +allocData i = toJExpr (global (dataName i)) + +-- | Cache "h$cXXX" names +clsCache :: Array Int FastString +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 -> JStgExpr +allocClsA i = toJExpr (global (clsName i)) + +-- | Cache "xXXX" names +varCache :: Array Int Ident +varCache = listArray (0,jsClosureCount) (fmap (name . mkFastString . ('x':) . show) [(0::Int)..jsClosureCount]) + +varName :: Int -> Ident +varName 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,19 +11,20 @@ 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.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.StgUtils -import GHC.StgToJS.CoreUtils +import GHC.StgToJS.Utils import GHC.StgToJS.Deps import GHC.StgToJS.Expr import GHC.StgToJS.ExprCtx @@ -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 @@ -90,11 +95,11 @@ -- Doc to dump when -ddump-js is enabled when (logHasDumpFlag logger Opt_D_dump_js) $ do putDumpFileMaybe logger Opt_D_dump_js "JavaScript code" FormatJS - $ vcat (fmap (docToSDoc . jsToDoc . oiStat . luObjUnit) lus) + $ vcat (fmap (jsToDoc . oiStat . luObjBlock) lus) -- Write the object file - bh <- openBinMem (4 * 1024 * 1000) -- a bit less than 4kB - Object.putObject bh (moduleName this_mod) deps (map luObjUnit lus) + bh <- openBinMem (4 * 1000) -- a bit less than 4kB + Object.putObject bh (moduleName this_mod) deps (map luObjBlock lus) createDirectoryIfMissing True (takeDirectory output_fn) writeBinMem bh output_fn @@ -133,21 +138,21 @@ glbl <- State.gets gsGlobal staticInit <- initStaticPtrs spt_entries - let stat = ( -- O.optimize . - jsSaturate (Just $ modulePrefix m 1) + let stat = ( jStgStatToJS $ mconcat (reverse glbl) <> staticInit) + let opt_stat = jsOptimize stat let syms = [moduleGlobalSymbol m] - let oi = ObjUnit + let oi = ObjBlock { oiSymbols = syms , oiClInfo = [] , oiStatic = [] - , oiStat = stat + , oiStat = opt_stat , oiRaw = mempty , oiFExports = [] , oiFImports = [] } let lu = LinkableUnit - { luObjUnit = oi + { luObjBlock = oi , luIdExports = [] , luOtherExports = syms , luIdDeps = [] @@ -169,7 +174,7 @@ let syms = [moduleExportsSymbol m] let raw = utf8EncodeByteString $ renderWithContext defaultSDocContext f_c - let oi = ObjUnit + let oi = ObjBlock { oiSymbols = syms , oiClInfo = [] , oiStatic = [] @@ -179,7 +184,7 @@ , oiFImports = [] } let lu = LinkableUnit - { luObjUnit = oi + { luObjBlock = oi , luIdExports = [] , luOtherExports = syms , luIdDeps = [] @@ -196,31 +201,27 @@ => 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 = jsSaturate (Just $ modulePrefix m n) body let ids = [bnd] - syms <- (\(TxtI i) -> [i]) <$> identForId bnd - let oi = ObjUnit + syms <- (\(identFS -> i) -> [i]) <$> identForId bnd + let oi = ObjBlock { oiSymbols = syms , oiClInfo = [] , oiStatic = si - , oiStat = stat + , oiStat = mempty , oiRaw = "" , oiFExports = [] , oiFImports = [] } let lu = LinkableUnit - { luObjUnit = oi + { luObjBlock = oi , luIdExports = ids , luOtherExports = [] , luIdDeps = [] @@ -244,21 +245,21 @@ let allDeps = collectIds unf decl topDeps = collectTopIds decl required = hasExport decl - stat = -- Opt.optimize . - jsSaturate (Just $ modulePrefix m n) - $ mconcat (reverse extraTl) <> tl - syms <- mapM (fmap (\(TxtI i) -> i) . identForId) topDeps - let oi = ObjUnit + stat = jStgStatToJS + $ mconcat (reverse extraTl) <> tl + 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 } let lu = LinkableUnit - { luObjUnit = oi + { luObjBlock = oi , luIdExports = topDeps , luOtherExports = [] , luIdDeps = allDeps @@ -270,60 +271,54 @@ 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 + StgRhsCon _cc con _mu _ts _args _typ | isDataConWorkId i -> genSetConInfo i con (stgRhsLive rhs) -- NoSRT - StgRhsClosure _ _cc _upd_flag _args _body + 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 (ei ||= mkDataEntry) - 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 :: JExpr -mkDataEntry = ValExpr $ JFunc [] returnStack +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 -> do + StgRhsCon cc con _mu _tys args _typ -> do ii <- identForId i allocConStatic ii cc con args return mempty - StgRhsClosure _ext cc _upd_flag {- srt -} args body -> do + StgRhsClosure _ext cc _upd_flag {- srt -} args body typ -> do {- algorithm: - collect all Id refs that are in the global id cache @@ -331,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 - body <- genBody (initExprCtx i) i R2 args body - global_occs <- globalOccs (jsSaturate (Just "ghcjs_tmp_sat_") body) - let lidents = map global_ident global_occs - let lids = map global_id global_occs + eid <- identForEntryId i + idt <- identFS <$> identForId i + body <- genBody (initExprCtx i) R2 args body typ + 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 - return $ (eid ||= toJExpr (JFunc [] (ll <> upd <> setcc <> body))) + 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/CoreUtils.hs b/GHC/StgToJS/CoreUtils.hs deleted file mode 100644 --- a/GHC/StgToJS/CoreUtils.hs +++ /dev/null @@ -1,282 +0,0 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} - --- | Core utils -module GHC.StgToJS.CoreUtils where - -import GHC.Prelude - -import GHC.JS.Syntax - -import GHC.StgToJS.Types - -import GHC.Stg.Syntax - -import GHC.Tc.Utils.TcType - -import GHC.Builtin.Types -import GHC.Builtin.Types.Prim - -import GHC.Core.DataCon -import GHC.Core.TyCo.Rep -import GHC.Core.TyCon -import GHC.Core.Type - -import GHC.Types.RepType -import GHC.Types.Var -import GHC.Types.Id - -import GHC.Utils.Misc -import GHC.Utils.Outputable -import GHC.Utils.Panic - -import qualified Data.Bits as Bits - --- | can we unbox C x to x, only if x is represented as a Number -isUnboxableCon :: DataCon -> Bool -isUnboxableCon dc - | [t] <- dataConRepArgTys dc - , [t1] <- typeVt (scaledThing t) - = isUnboxable t1 && - dataConTag dc == 1 && - length (tyConDataCons $ dataConTyCon dc) == 1 - | otherwise = False - --- | one-constructor types with one primitive field represented as a JS Number --- can be unboxed -isUnboxable :: VarType -> Bool -isUnboxable DoubleV = True -isUnboxable IntV = True -- includes Char# -isUnboxable _ = False - --- | Number of slots occupied by a PrimRep -data SlotCount - = NoSlot - | OneSlot - | TwoSlots - deriving (Show,Eq,Ord) - -instance Outputable SlotCount where - ppr = text . show - --- | Return SlotCount as an Int -slotCount :: SlotCount -> Int -slotCount = \case - NoSlot -> 0 - OneSlot -> 1 - TwoSlots -> 2 - - --- | Number of slots occupied by a value with the given VarType -varSize :: VarType -> Int -varSize = slotCount . varSlotCount - -varSlotCount :: VarType -> SlotCount -varSlotCount VoidV = NoSlot -varSlotCount LongV = TwoSlots -- hi, low -varSlotCount AddrV = TwoSlots -- obj/array, offset -varSlotCount _ = OneSlot - -typeSize :: Type -> Int -typeSize t = sum . map varSize . typeVt $ t - -isVoid :: VarType -> 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 - 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 - -typeVt :: HasDebugCallStack => Type -> [VarType] -typeVt t | isRuntimeRepKindedTy t = [] -typeVt t = map primRepVt (typePrimRep t)-- map uTypeVt (repTypeArgs 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 LiftedRep = PtrV -- fixme does ByteArray# ever map to this? -primRepVt UnliftedRep = RtsObjV -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) - -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 -> RtsObjV - | tc == statePrimTyCon -> VoidV - | tc == proxyPrimTyCon -> VoidV - | tc == realWorldTyCon -> VoidV - | tc == threadIdPrimTyCon -> RtsObjV - | tc == weakPrimTyCon -> RtsObjV - | 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 -> RtsObjV - | tc == mVarPrimTyCon -> RtsObjV - | tc == tVarPrimTyCon -> RtsObjV - | tc == bcoPrimTyCon -> RtsObjV -- unsupported? - | tc == stackSnapshotPrimTyCon -> RtsObjV - | tc == ioPortPrimTyCon -> RtsObjV -- unsupported? - | tc == anyTyCon -> PtrV - | tc == compactPrimTyCon -> ObjV -- unsupported? - | tc == eqPrimTyCon -> VoidV -- coercion token? - | tc == eqReprPrimTyCon -> VoidV -- role - | tc == unboxedUnitTyCon -> VoidV -- Void# - | otherwise -> PtrV -- anything else must be some boxed thing - -argVt :: StgArg -> VarType -argVt a = uTypeVt . stgArgType $ a - -dataConType :: DataCon -> Type -dataConType dc = idType (dataConWrapId dc) - -isBoolDataCon :: DataCon -> Bool -isBoolDataCon dc = isBoolTy (dataConType dc) - --- standard fixed layout: payload types --- payload starts at .d1 for heap objects, entry closest to Sp for stack frames -fixedLayout :: [VarType] -> 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 i - | OneSlot <- varSlotCount otype = otype - | otherwise = DoubleV - where otype = uTypeVt (idType i) - -idPrimReps :: Id -> [PrimRep] -idPrimReps = typePrimReps . idType - -typePrimReps :: Type -> [PrimRep] -typePrimReps = typePrimRep . unwrapType - -primRepSize :: PrimRep -> SlotCount -primRepSize p = varSlotCount (primRepVt p) - --- | Associate the given values to each RrimRep in the given order, taking into --- account the number of slots per PrimRep -assocPrimReps :: Outputable a => [PrimRep] -> [a] -> [(PrimRep, [a])] -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 err) - --- | Associate the given values to the Id's PrimReps, taking into account the --- number of slots per PrimRep -assocIdPrimReps :: Outputable a => Id -> [a] -> [(PrimRep, [a])] -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 i es = fmap (uncurry TypedExpr) (assocIdPrimReps i es) - --- | Return False only if we are *sure* it's a data type --- Look through newtypes etc as much as possible -might_be_a_function :: HasDebugCallStack => Type -> Bool -might_be_a_function ty - | [LiftedRep] <- typePrimRep ty - , Just tc <- tyConAppTyCon_maybe (unwrapType ty) - , isDataTyCon tc - = False - | otherwise - = True - -mkArityTag :: Int -> Int -> Int -mkArityTag arity registers = arity Bits..|. (registers `Bits.shiftL` 8) - -toTypeList :: [VarType] -> [Int] -toTypeList = concatMap (\x -> replicate (varSize x) (fromEnum x)) diff --git a/GHC/StgToJS/DataCon.hs b/GHC/StgToJS/DataCon.hs --- a/GHC/StgToJS/DataCon.hs +++ b/GHC/StgToJS/DataCon.hs @@ -27,14 +27,15 @@ import GHC.Prelude -import GHC.JS.Syntax +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 import GHC.StgToJS.Types import GHC.StgToJS.Monad -import GHC.StgToJS.CoreUtils import GHC.StgToJS.Profiling import GHC.StgToJS.Utils import GHC.StgToJS.Ids @@ -42,32 +43,33 @@ import GHC.Core.DataCon import GHC.Types.CostCentre -import GHC.Types.Unique.Map import GHC.Utils.Outputable import GHC.Utils.Panic -import GHC.Data.FastString 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, args, xs)) + = pprPanic "genCon: unhandled DataCon" (ppr (con + , 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) -} @@ -81,44 +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,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 > 24 = newClosure $ Closure - { clEntry = entry - , clField1 = fillObj1 - , clField2 = fillObj2 - , clMeta = ValExpr (JInt 0) - , clCC = cc - } - | otherwise = ApplExpr allocFun (toJExpr entry : free ++ maybeToList cc) + | inline_alloc || length free > jsClosureCount + = newClosure $ mkClosure entry free zero_ cc + | otherwise = ApplExpr allocFun (entry : free ++ maybeToList cc) where allocFun = allocClsA (length free) - (fillObj1,fillObj2) - = case free of - [] -> (null_, null_) - [x] -> (x,null_) - [x,y] -> (x,y) - (x:xs) -> (x,toJExpr (JHash $ listToUniqMap (zip dataFields xs))) - dataFields = map (mkFastString . ('d':) . show) [(1::Int)..] -- | 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 @@ -22,11 +22,11 @@ import GHC.Prelude -import GHC.StgToJS.Object as Object +import GHC.StgToJS.Object import GHC.StgToJS.Types import GHC.StgToJS.Ids -import GHC.JS.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 @@ -57,8 +56,8 @@ data DependencyDataCache = DDC { ddcModule :: !(Word64Map Unit) -- ^ Unique Module -> Unit - , ddcId :: !(Word64Map Object.ExportedFun) -- ^ Unique Id -> Object.ExportedFun (only to other modules) - , ddcOther :: !(Map OtherSymb Object.ExportedFun) + , ddcId :: !(Word64Map ExportedFun) -- ^ Unique Id -> ExportedFun (only to other modules) + , ddcOther :: !(Map OtherSymb ExportedFun) } -- | Generate module dependency data @@ -69,24 +68,16 @@ :: HasDebugCallStack => Module -> [LinkableUnit] - -> G Object.Deps + -> G BlockInfo genDependencyData mod units = do - -- [(blockindex, blockdeps, required, exported)] ds <- evalStateT (mapM (uncurry oneDep) blocks) (DDC WM.empty WM.empty M.empty) - return $ Object.Deps - { depsModule = mod - , depsRequired = IS.fromList [ n | (n, _, True, _) <- ds ] - , depsHaskellExported = M.fromList $ (\(n,_,_,es) -> map (,n) es) =<< ds - , depsBlocks = listArray (0, length blocks-1) (map (\(_,deps,_,_) -> deps) ds) + return $ BlockInfo + { bi_module = mod + , bi_must_link = IS.fromList [ n | (n, _, True, _) <- ds ] + , bi_exports = M.fromList $ (\(n,_,_,es) -> map (,n) es) =<< ds + , bi_block_deps = listArray (0, length blocks-1) (map (\(_,deps,_,_) -> deps) ds) } - -- XXX - -- return $ BlockInfo - -- { bi_module = mod - -- , bi_must_link = IS.fromList [ n | (n, _, True, _) <- ds ] - -- , bi_exports = M.fromList $ (\(n,_,_,es) -> map (,n) es) =<< ds - -- , bi_block_deps = listArray (0, length blocks-1) (map (\(_,deps,_,_) -> deps) ds) - -- } where -- Id -> Block unitIdExports :: UniqFM Id Int @@ -107,17 +98,18 @@ -- generate the list of exports and set of dependencies for one unit oneDep :: LinkableUnit -> Int - -> StateT DependencyDataCache G (Int, Object.BlockDeps, Bool, [Object.ExportedFun]) + -> 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! - let bdeps = Object.BlockDeps - (IS.toList . IS.fromList . filter (/=n) $ bdi++bdo++bdp) - (S.toList . S.fromList $ edi++edo++edp) + let bdeps = BlockDeps + { blockBlockDeps = IS.toList . IS.fromList . filter (/=n) $ bdi++bdo++bdp + , blockFunDeps = S.toList . S.fromList $ edi++edo++edp + } return (n, bdeps, req, expi++expo) idModule :: Id -> Maybe Module @@ -125,7 +117,7 @@ guard (m /= mod) >> return m lookupPseudoIdFun :: Int -> Unique - -> StateT DependencyDataCache G (Either Object.ExportedFun Int) + -> StateT DependencyDataCache G (Either ExportedFun Int) lookupPseudoIdFun _n u = case lookupUFM_Directly unitIdExports u of Just k -> return (Right k) @@ -138,16 +130,16 @@ -- assumes function is internal to the current block if it's -- from teh current module and not in the unitIdExports map. lookupIdFun :: Int -> Id - -> StateT DependencyDataCache G (Either Object.ExportedFun Int) + -> StateT DependencyDataCache G (Either ExportedFun Int) lookupIdFun n i = case lookupUFM unitIdExports i of Just k -> return (Right k) Nothing -> case idModule i of Nothing -> return (Right n) Just m -> let k = getKey . getUnique $ i - addEntry :: StateT DependencyDataCache G Object.ExportedFun + 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) @@ -157,30 +149,30 @@ -- get the function for an OtherSymb from the cache, add it if necessary lookupOtherFun :: OtherSymb - -> StateT DependencyDataCache G (Either Object.ExportedFun Int) + -> StateT DependencyDataCache G (Either ExportedFun Int) lookupOtherFun od@(OtherSymb m idTxt) = case M.lookup od unitOtherExports of Just n -> return (Right n) - Nothing | m == mod -> panic ("genDependencyData.lookupOtherFun: unknown local other id: " ++ unpackFS idTxt) + Nothing | m == mod -> pprPanic "genDependencyData.lookupOtherFun: unknown local other id:" (ftext idTxt) Nothing -> Left <$> (maybe (lookupExternalFun Nothing od) return =<< gets (M.lookup od . ddcOther)) - lookupExportedId :: Id -> StateT DependencyDataCache G Object.ExportedFun + 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 Object.ExportedFun + lookupExportedOther :: FastString -> StateT DependencyDataCache G ExportedFun lookupExportedOther = lookupExternalFun Nothing . OtherSymb mod -- lookup a dependency to another module, add to the id cache if there's -- an id key, otherwise add to other cache lookupExternalFun :: Maybe Word64 - -> OtherSymb -> StateT DependencyDataCache G Object.ExportedFun + -> OtherSymb -> StateT DependencyDataCache G ExportedFun lookupExternalFun mbIdKey od@(OtherSymb m idTxt) = do let mk = getKey . getUnique $ m mpk = moduleUnit m - exp_fun = Object.ExportedFun m (LexicalFastString idTxt) + exp_fun = ExportedFun m (LexicalFastString idTxt) addCache = do ms <- gets ddcModule let !cache' = WM.insert mk mpk ms 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,41 +31,46 @@ import GHC.Prelude -import GHC.JS.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.StgUtils -import GHC.StgToJS.CoreUtils -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.Basic import GHC.Types.CostCentre import GHC.Types.Tickish import GHC.Types.Var.Set import GHC.Types.Id import GHC.Types.Unique.FM import GHC.Types.RepType +import GHC.Types.Literal import GHC.Stg.Syntax import GHC.Stg.Utils 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) @@ -73,16 +79,17 @@ import GHC.Utils.Misc import GHC.Utils.Monad import GHC.Utils.Panic -import GHC.Utils.Panic.Plain 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 @@ -90,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 @@ -130,24 +137,24 @@ 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 b (StgRhsClosure _ _ccs {-[the_fv]-} _upd [] expr) + 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 , StgApp selectee [] <- strip sel_expr @@ -165,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) - | snd (isInlineExpr (ctxEvaluatedIds ctx) expr) = do + assign b (StgRhsClosure _ext _ccs _upd [] expr _typ) + | isInlineExpr expr = do d <- declVarsForId b tgt <- varsForId b let ctx' = ctx { ctxTarget = assocIdExprs b tgt } @@ -177,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 @@ -222,7 +223,7 @@ -- is initially set to null, changed to h$blackhole when the thunk is being evaluated. -- genEntryLne :: HasDebugCallStack => ExprCtx -> Id -> CgStgRhs -> G () -genEntryLne ctx i rhs@(StgRhsClosure _ext _cc update args body) = +genEntryLne ctx i rhs@(StgRhsClosure _ext _cc update args body typ) = resetSlots $ do let payloadSize = ctxLneFrameSize ctx vars = ctxLneFrameVars ctx @@ -230,83 +231,84 @@ 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 i R1 args body - 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 = JFunc [] (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 (ei ||= toJExpr f) -genEntryLne ctx i (StgRhsCon cc con _mu _ticks args) = resetSlots $ do + 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 (ei ||= toJExpr (JFunc [] - (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) = 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 - body <- genBody entryCtx i R2 args body - ei@(TxtI eii) <- identForEntryId i + let entryCtx = ctxSetTarget [] (ctxClearLneFrame ctx) + body <- genBody entryCtx R2 args body typ 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 (ei ||= toJExpr (JFunc [] (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 => ExprCtx - -> Id -> StgReg -> [Id] -> CgStgExpr - -> G JStat -genBody ctx i startReg args e = do + -> Type + -> G JStgStat +genBody ctx startReg args e typ = do -- load arguments into local variables la <- do args' <- concatMapM genIdArgI args @@ -317,7 +319,7 @@ -- compute PrimReps and their number of slots required to return the result of -- i applied to args. - let res_vars = resultSize args i + let res_vars = resultSize typ -- compute typed expressions for each slot and assign registers let go_var regs = \case @@ -352,32 +354,22 @@ -- -- 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 -- probably what it is. -- -resultSize :: HasDebugCallStack => [Id] -> Id -> [(PrimRep, Int)] -resultSize args i = result +resultSize :: HasDebugCallStack => Type -> [(PrimRep, Int)] +resultSize ty = result where result = result_reps `zip` result_slots result_slots = fmap (slotCount . primRepSize) result_reps - result_reps = trim_args (unwrapType (idType i)) (length args) - - trim_args t 0 = typePrimRep t - trim_args t n - | Just (_af, _mult, arg, res) <- splitFunTy_maybe t - , nargs <- length (typePrimRepArgs arg) - , assert (n >= nargs) True - = trim_args (unwrapType res) (n - nargs) - | otherwise - = pprTrace "result_type: not a function type, assume LiftedRep" (ppr t) - [LiftedRep] + result_reps = typePrimRep ty -- | 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 @@ -386,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 @@ -395,17 +387,16 @@ go _ _ = pprPanic "verifyRuntimeReps: inconsistent sizes" (ppr xs) ver j PtrV = v "h$verify_rep_heapobj" [j] ver j IntV = v "h$verify_rep_int" [j] - ver j RtsObjV = v "h$verify_rep_rtsobj" [j] 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 @@ -427,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 @@ -447,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 @@ -467,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 @@ -484,14 +475,14 @@ | otherwise = do unfloated <- State.gets gsUnfloated let xs = filter (\x -> not (elemUFM x unfloated || - typeLevity_maybe (idType x) == Just Unlifted)) + definitelyUnliftedType (idType x))) (dVarSetElems sv) CIStaticRefs . catMaybes <$> mapM getStaticRef xs where 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 @@ -505,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 @@ -523,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 @@ -539,19 +531,19 @@ toCl (i, StgRhsCon cc con []) = do ii <- identForId i Left <$> (return (decl ii) <> allocCon ii con cc []) -} - toCl (i, StgRhsCon cc con _mui _ticjs [a]) | isUnboxableCon con = do + toCl (i, StgRhsCon cc con _mui _ticjs [a] _typ) | isUnboxableCon con = do ii <- identForId i ac <- allocCon ii con cc =<< genArg a pure (Left (decl ii <> ac)) -- dynamics - toCl (i, StgRhsCon cc con _mu _ticks ar) = + toCl (i, StgRhsCon cc con _mu _ticks ar _typ) = -- fixme do we need to handle unboxed? Right <$> ((,,,) <$> identForId i <*> varForDataConWorker con <*> concatMapM genArg ar <*> pure cc) - toCl (i, cl@(StgRhsClosure _ext cc _upd_flag _args _body)) = + toCl (i, cl@(StgRhsClosure _ext cc _upd_flag _args _body _typ)) = let live = stgLneLiveExpr cl in Right <$> ((,,,) <$> identForId i <*> varForEntryId i @@ -568,20 +560,94 @@ -> AltType -> [CgStgAlt] -> LiveVars - -> G (JStat, ExprResult) + -> G (JStgStat, ExprResult) genCase ctx bnd e at alts l - | snd (isInlineExpr (ctxEvaluatedIds ctx) e) = do + -- For: unpackCStringAppend# "some string"# str + -- Generate: h$appendToHsStringA(str, "some string") + -- + -- The latter has a faster decoding loop. + -- + -- Since #23270 and 7e0c8b3bab30, literals strings aren't STG atoms and we + -- need to match the following instead: + -- + -- case "some string"# of b { + -- DEFAULT -> unpackCStringAppend# b str + -- } + -- + -- Wrinkle: it doesn't kick in when literals are floated out to the top level. + -- + | StgLit (LitString bs) <- e + , [GenStgAlt DEFAULT _ rhs] <- alts + , StgApp i args <- rhs + , getUnique i == unpackCStringAppendIdKey + , [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$appendToHsStringA" (toJExpr d : a ++ profArg) + , ExprInline + ) + | StgLit (LitString bs) <- e + , [GenStgAlt DEFAULT _ rhs] <- alts + , StgApp i args <- rhs + , getUnique i == unpackCStringAppendUtf8IdKey + , [StgVarArg b',x] <- args + , bnd == b' + , Just d <- decodeModifiedUTF8 bs + , [top] <- concatMap typex_expr (ctxTarget ctx) + = do + prof <- csProf <$> getSettings + let profArg = if prof then [jCafCCS] else [] + a <- genArg x + return ( top |= app "h$appendToHsString" (toJExpr d : a ++ profArg) + , ExprInline + ) + + -- The latter has a faster decoding loop. + -- + -- case "some string"# of b { + -- DEFAULT -> unpackCString# b + -- } + -- + -- + Utf8 version below + | StgLit (LitString bs) <- e + , [GenStgAlt DEFAULT _ rhs] <- alts + , StgApp i args <- rhs + , idName i == unpackCStringName + , [StgVarArg b'] <- args + , bnd == b' + , Just d <- decodeModifiedUTF8 bs + , [top] <- concatMap typex_expr (ctxTarget ctx) + = return + ( top |= app "h$toHsStringA" [toJExpr d] + , ExprInline + ) + | StgLit (LitString bs) <- e + , [GenStgAlt DEFAULT _ rhs] <- alts + , StgApp i args <- rhs + , idName i == unpackCStringUtf8Name + , [StgVarArg b'] <- args + , bnd == b' + , Just d <- decodeModifiedUTF8 bs + , [top] <- concatMap typex_expr (ctxTarget ctx) + = return + ( top |= app "h$toHsString" [toJExpr d] + , ExprInline + ) + + | isInlineExpr e = do bndi <- identsForId bnd let ctx' = ctxSetTop bnd $ 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 @@ -597,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 @@ -610,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 @@ -631,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 $ r ||= toJExpr (JFunc [] 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 @@ -670,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 @@ -681,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 @@ -704,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) @@ -722,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 @@ -768,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 @@ -776,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) @@ -799,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 @@ -846,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 @@ -855,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 @@ -891,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 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' @@ -948,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 dataFieldNames 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,29 +5,27 @@ module GHC.StgToJS.FFI ( genPrimCall , genForeignCall - , saturateFFI ) where import GHC.Prelude -import GHC.JS.Syntax +import GHC.JS.JStg.Syntax import GHC.JS.Make -import GHC.JS.Transform 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.CoreUtils -import GHC.StgToJS.Ids +import GHC.StgToJS.Symbols +import GHC.StgToJS.Types +import GHC.StgToJS.Utils import GHC.Types.RepType import GHC.Types.ForeignCall import GHC.Types.Unique.Map -import GHC.Types.Unique.FM import GHC.Stg.Syntax @@ -37,22 +35,17 @@ import GHC.Core.Type hiding (typeSize) import GHC.Utils.Misc -import GHC.Utils.Panic -import GHC.Utils.Outputable (renderWithContext, defaultSDocContext, ppr, vcat, text) +import GHC.Utils.Outputable (renderWithContext, defaultSDocContext, ppr) import GHC.Data.FastString import Data.Char import Data.Monoid -import Data.Maybe import qualified Data.List as L -import Control.Monad -import Control.Applicative -import qualified Text.ParserCombinators.ReadP as P -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 {- @@ -74,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 @@ -86,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 @@ -105,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) ]) ] @@ -127,41 +119,17 @@ -- 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 = - if True - then mkApply pat - else do - u <- freshUnique - case parseFfiJME pat u of - Right (ValExpr (JVar (TxtI _ident))) -> mkApply pat - Right expr | not async && length tgt < 2 -> do - (statPre, ap) <- argPlaceholders javascriptCc args - let rp = resultPlaceholders async t ret - env = addListToUFM emptyUFM (rp ++ ap) - if length tgt == 1 - then return $ statPre <> (mapStatIdent (replaceIdent env) (var "$r" |= expr)) - else return $ statPre <> (mapStatIdent (replaceIdent env) (toStat expr)) - Right _ -> p $ "invalid expression FFI pattern. Expression FFI patterns can only be used for synchronous FFI " ++ - " imports with result size 0 or 1.\n" ++ pat - Left _ -> case parseFfiJM pat u of - Left err -> p (show err) - Right stat -> do - let rp = resultPlaceholders async t ret - let cp = callbackPlaceholders callback - (statPre, ap) <- argPlaceholders javascriptCc args - let env = addListToUFM emptyUFM (rp ++ ap ++ cp) - return $ statPre <> (mapStatIdent (replaceIdent env) stat) -- fixme trace? + | otherwise = mkApply pat where - async = isJust callback tgt = take (typeSize t) ret -- automatic apply, build call and result copy mkApply f @@ -182,38 +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 - p e = error ("Parse error in FFI pattern: " ++ pat ++ "\n" ++ e) - replaceIdent :: UniqFM Ident JExpr -> Ident -> JExpr - replaceIdent env i - | isFFIPlaceholder i = fromMaybe err (lookupUFM env i) - | otherwise = ValExpr (JVar i) - where - (TxtI i') = i - err = pprPanic "parseFFIPattern': invalid placeholder, check function type" - (vcat [text pat, ppr i', ppr args, ppr t]) traceCall cs as - | csTraceForeign cs = ApplStat (var "h$traceForeign") [toJExpr pat, toJExpr as] + | csTraceForeign cs = ApplStat hdTraceForeign [toJExpr pat, toJExpr as] | otherwise = mempty --- ident is $N, $N_R, $rN, $rN_R or $r or $c -isFFIPlaceholder :: Ident -> Bool -isFFIPlaceholder (TxtI x) = not (null (P.readP_to_S parser (unpackFS x))) - where - digit = P.satisfy (`elem` ("0123456789" :: String)) - parser = void (P.string "$r" >> P.eof) <|> - void (P.string "$c" >> P.eof) <|> do - _ <- P.char '$' - P.optional (P.char 'r') - _ <- P.many1 digit - P.optional (P.char '_' >> P.many1 digit) - P.eof - --- 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 && @@ -226,69 +172,15 @@ where tycon = tyConAppTyCon (unwrapType arg_ty) arg_ty = stgArgType a - r = uTypeVt arg_ty - --- $1, $2, $3 for single, $1_1, $1_2 etc for dual --- void args not counted -argPlaceholders :: Bool -> [StgArg] -> G (JStat, [(Ident,JExpr)]) -argPlaceholders isJavaScriptCc args = do - (stats, idents0) <- unzip <$> mapM (genFFIArg isJavaScriptCc) args - let idents = filter (not . null) idents0 - return $ (mconcat stats, concat - (zipWith (\is n -> mkPlaceholder True ("$"++show n) is) idents [(1::Int)..])) - -mkPlaceholder :: Bool -> String -> [JExpr] -> [(Ident, JExpr)] -mkPlaceholder undersc prefix aids = - case aids of - [] -> [] - [x] -> [(TxtI . mkFastString $ prefix, x)] - xs@(x:_) -> (TxtI . mkFastString $ prefix, x) : - zipWith (\x m -> (TxtI . mkFastString $ prefix ++ u ++ show m,x)) xs [(1::Int)..] - where u = if undersc then "_" else "" - --- $r for single, $r1,$r2 for dual --- $r1, $r2, etc for ubx tup, void args not counted -resultPlaceholders :: Bool -> Type -> [JExpr] -> [(Ident,JExpr)] -- ident, replacement -resultPlaceholders True _ _ = [] -- async has no direct resuls, use callback -resultPlaceholders False t rs = - case typeVt (unwrapType t) of - [t'] -> mkUnary (varSize t') - uts -> - let sizes = filter (>0) (map varSize uts) - f _ 0 = [] - f n 1 = [["$r" ++ show n]] - f n k = ["$r" ++ sn, "$r" ++ sn ++ "_1"] : map (\x -> ["$r" ++ sn ++ "_" ++ show x]) [2..k] - where sn = show n - phs = zipWith (\size n -> f n size) sizes [(1::Int)..] - in case sizes of - [n] -> mkUnary n - _ -> concat $ zipWith (\phs' r -> map (\i -> (TxtI (mkFastString i), r)) phs') (concat phs) rs - where - mkUnary 0 = [] - mkUnary 1 = [(TxtI "$r",head rs)] -- single - mkUnary n = [(TxtI "$r",head rs),(TxtI "$r1", head rs)] ++ - zipWith (\n r -> (TxtI . mkFastString $ "$r" ++ show n, toJExpr r)) [2..n] (tail rs) - -callbackPlaceholders :: Maybe JExpr -> [(Ident,JExpr)] -callbackPlaceholders Nothing = [] -callbackPlaceholders (Just e) = [((TxtI "$c"), e)] - -parseFfiJME :: String -> Int -> Either String JExpr -parseFfiJME _xs _u = Left "parseFfiJME not yet implemented" - -parseFfiJM :: String -> Int -> Either String JStat -parseFfiJM _xs _u = Left "parseFfiJM not yet implemented" - -saturateFFI :: JMacro a => Int -> a -> a -saturateFFI u = jsSaturate (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 @@ -296,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 @@ -329,7 +222,7 @@ tgt' | async = take (length tgt) jsRegsFromR1 | otherwise = tgt - wrapperPrefix = "ghczuwrapperZC" + wrapperPrefix = unpackFS wrapperColonStr getObjectKeyValuePairs :: [StgArg] -> Maybe [(FastString, StgArg)] getObjectKeyValuePairs [] = Just [] @@ -349,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.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 @@ -40,10 +40,11 @@ import GHC.StgToJS.Types import GHC.StgToJS.Monad -import GHC.StgToJS.CoreUtils +import GHC.StgToJS.Utils import GHC.StgToJS.Symbols -import GHC.JS.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 (occNameFS (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,945 +1,1294 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE LambdaCase #-} - ------------------------------------------------------------------------------ --- | --- Module : GHC.StgToJS.Linker.Linker --- 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 --- --- GHCJS linker, collects dependencies from the object files --- which contain linkable units with dependency information --- ------------------------------------------------------------------------------ - -module GHC.StgToJS.Linker.Linker - ( jsLinkBinary - , embedJsFile - ) -where - -import Prelude - -import GHC.Platform.Host (hostPlatformArchOS) - -import GHC.JS.Make -import GHC.JS.Syntax - -import GHC.Driver.Session (DynFlags(..)) -import Language.Haskell.Syntax.Module.Name -import GHC.SysTools.Cpp -import GHC.SysTools - -import GHC.Linker.Static.Utils (exeFileName) - -import GHC.StgToJS.Linker.Types -import GHC.StgToJS.Linker.Utils -import GHC.StgToJS.Rts.Rts -import GHC.StgToJS.Object -import GHC.StgToJS.Types hiding (LinkableUnit) -import GHC.StgToJS.Symbols -import GHC.StgToJS.Printer -import GHC.StgToJS.Arg -import GHC.StgToJS.Closure - -import GHC.Unit.State -import GHC.Unit.Env -import GHC.Unit.Home -import GHC.Unit.Types -import GHC.Unit.Module (moduleStableString) - -import GHC.Utils.Outputable hiding ((<>)) -import GHC.Utils.Panic -import GHC.Utils.Error -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 - -import qualified GHC.SysTools.Ar as Ar - -import qualified GHC.Data.ShortText as ST -import GHC.Data.FastString - -import Control.Concurrent.MVar -import Control.Monad - -import Data.Array -import qualified Data.ByteString as B -import qualified Data.ByteString.Char8 as BC -import qualified Data.ByteString.Lazy.Char8 as BLC -import qualified Data.ByteString.Lazy as BL -import qualified Data.ByteString as BS -import Data.Function (on) -import Data.IntSet (IntSet) -import qualified Data.IntSet as IS -import Data.IORef -import Data.List ( partition, nub, intercalate, group, sort - , 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 System.IO -import System.FilePath ((<.>), (), dropExtension, takeDirectory) -import System.Directory ( createDirectoryIfMissing - , doesFileExist - , getCurrentDirectory - , Permissions(..) - , setPermissions - , getPermissions - ) - -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) } - -emptyArchiveState :: IO ArchiveState -emptyArchiveState = ArchiveState <$> newIORef M.empty - -jsLinkBinary - :: JSLinkConfig - -> StgToJSConfig - -> [FilePath] - -> Logger - -> DynFlags - -> UnitEnv - -> [FilePath] - -> [UnitId] - -> IO () -jsLinkBinary lc_cfg cfg js_srcs logger dflags u_env objs dep_pkgs - | 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 - let - objs' = map ObjFile (objs ++ cmdline_js_objs) - js_srcs' = js_srcs ++ cmdline_js_srcs - isRoot _ = True - exe = jsExeFileName dflags - - void $ link lc_cfg cfg logger u_env exe mempty dep_pkgs objs' js_srcs' isRoot mempty - --- | link and write result to disk (jsexe directory) -link :: JSLinkConfig - -> StgToJSConfig - -> Logger - -> UnitEnv - -> FilePath -- ^ output file/directory - -> [FilePath] -- ^ include path for home package - -> [UnitId] -- ^ packages to link - -> [LinkedObj] -- ^ the object files we're linking - -> [FilePath] -- ^ extra js files to include - -> (ExportedFun -> Bool) -- ^ functions from the objects to use as roots (include all their deps) - -> Set ExportedFun -- ^ extra symbols to link in - -> IO () -link lc_cfg cfg logger unit_env out _include units objFiles jsFiles isRootFun extraStaticDeps = do - - -- create output directory - createDirectoryIfMissing False out - - ------------------------------------------------------------- - -- link all Haskell code (program + dependencies) into out.js - - -- compute dependencies - (dep_map, dep_units, all_deps, _rts_wired_functions, dep_archives) - <- computeLinkDependencies cfg logger out unit_env units objFiles extraStaticDeps isRootFun - - -- retrieve code for dependencies - mods <- collectDeps dep_map dep_units all_deps - - -- LTO + rendering of JS code - link_stats <- withBinaryFile (out "out.js") WriteMode $ \h -> - renderLinker h mods jsFiles - - ------------------------------------------------------------- - - -- dump foreign references file (.frefs) - unless (lcOnlyOut lc_cfg) $ do - let frefsFile = "out.frefs" - -- frefs = concatMap mc_frefs mods - jsonFrefs = mempty -- FIXME: toJson frefs - - BL.writeFile (out frefsFile <.> "json") jsonFrefs - BL.writeFile (out frefsFile <.> "js") - ("h$checkForeignRefs(" <> jsonFrefs <> ");") - - -- dump stats - unless (lcNoStats lc_cfg) $ do - let statsFile = "out.stats" - writeFile (out statsFile) (renderLinkerStats link_stats) - - -- link generated RTS parts into rts.js - unless (lcNoRts lc_cfg) $ do - BL.writeFile (out "rts.js") ( BLC.pack rtsDeclsText - <> BLC.pack (rtsText cfg)) - - -- link dependencies' JS files into lib.js - withBinaryFile (out "lib.js") WriteMode $ \h -> do - forM_ dep_archives $ \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 - hPutChar h '\n' - - -- link everything together into all.js - when (generateAllJs lc_cfg) $ do - _ <- combineFiles lc_cfg out - writeHtml out - writeRunMain out - writeRunner lc_cfg out - writeExterns out - - -computeLinkDependencies - :: StgToJSConfig - -> Logger - -> String - -> UnitEnv - -> [UnitId] - -> [LinkedObj] - -> Set ExportedFun - -> (ExportedFun -> Bool) - -> IO (Map Module (Deps, DepsLocation), [UnitId], Set LinkableUnit, Set ExportedFun, [FilePath]) -computeLinkDependencies cfg logger target unit_env units objFiles extraStaticDeps isRootFun = do - - (objDepsMap, objRequiredUnits) <- loadObjDeps objFiles - - let roots = S.fromList . filter isRootFun $ concatMap (M.keys . depsHaskellExported . fst) (M.elems objDepsMap) - rootMods = map (moduleNameString . moduleName . head) . group . sort . map funModule . S.toList $ roots - objPkgs = map moduleUnitId $ nub (M.keys objDepsMap) - - when (logVerbAtLeast logger 2) $ void $ do - compilationProgressMsg logger $ hcat - [ text "Linking ", text target, text " (", text (intercalate "," rootMods), char ')' ] - compilationProgressMsg logger $ hcat - [ text "objDepsMap ", ppr objDepsMap ] - compilationProgressMsg logger $ hcat - [ text "objFiles ", ppr objFiles ] - - let (rts_wired_units, rts_wired_functions) = rtsDeps units - - -- all the units we want to link together, without their dependencies - let root_units = filter (/= mainUnitId) - $ nub - $ rts_wired_units ++ reverse objPkgs ++ reverse units - - -- all the units we want to link together, including their dependencies, - -- preload units, and backpack instantiations - all_units_infos <- mayThrowUnitErr (preloadUnitsInfo' unit_env root_units) - - let all_units = fmap unitId all_units_infos - - dep_archives <- getPackageArchives cfg unit_env all_units - env <- newGhcjsEnv - (archsDepsMap, archsRequiredUnits) <- loadArchiveDeps env dep_archives - - when (logVerbAtLeast logger 2) $ - logInfo logger $ hang (text "Linking with archives:") 2 (vcat (fmap text dep_archives)) - - -- compute dependencies - let dep_units = all_units ++ [homeUnitId (ue_unsafeHomeUnit $ unit_env)] - dep_map = objDepsMap `M.union` archsDepsMap - excluded_units = S.empty - dep_fun_roots = roots `S.union` rts_wired_functions `S.union` extraStaticDeps - dep_unit_roots = archsRequiredUnits ++ objRequiredUnits - - all_deps <- getDeps (fmap fst dep_map) excluded_units dep_fun_roots dep_unit_roots - - when (logVerbAtLeast logger 2) $ - logInfo logger $ hang (text "Units to link:") 2 (vcat (fmap ppr dep_units)) - -- logInfo logger $ hang (text "All deps:") 2 (vcat (fmap ppr (S.toList all_deps))) - - return (dep_map, dep_units, all_deps, rts_wired_functions, dep_archives) - - --- | Compiled module -data ModuleCode = ModuleCode - { mc_module :: !Module - , mc_js_code :: !JStat - , mc_exports :: !B.ByteString -- ^ rendered exports - , mc_closures :: ![ClosureInfo] - , mc_statics :: ![StaticInfo] - , mc_frefs :: ![ForeignJSRef] - } - --- | 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 :: !JStat - , cmc_exports :: !B.ByteString -- ^ rendered exports - } - --- | Link modules and pretty-print them into the given Handle -renderLinker - :: Handle - -> [ModuleCode] -- ^ linked code per module - -> [FilePath] -- ^ additional JS files - -> IO LinkerStats -renderLinker h mods jsFiles = do - - -- link modules - let (compacted_mods, meta) = linkModules mods - - let - putBS = B.hPut h - putJS x = do - before <- hTell h - Ppr.printLeftRender h (pretty x) - hPutChar h '\n' - after <- hTell h - pure $! (after - before) - - --------------------------------------------------------- - -- Pretty-print JavaScript code for all the dependencies. - -- - -- We have to pretty-print at link time because we want to be able to perform - -- global link-time optimisations (e.g. renamings) on the whole generated JS - -- file. - - -- modules themselves - mod_sizes <- forM compacted_mods $ \m -> do - !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 meta - - -- module exports - mapM_ (putBS . cmc_exports) compacted_mods - - -- explicit additional JS files - mapM_ (\i -> B.readFile i >>= putBS) jsFiles - - -- stats - let link_stats = LinkerStats - { bytesPerModule = M.fromList mod_sizes - , packedMetaDataSize = meta_length - } - - pure link_stats - --- | Render linker stats -renderLinkerStats :: LinkerStats -> String -renderLinkerStats s = - intercalate "\n\n" [meta_stats, package_stats, module_stats] <> "\n\n" - where - meta = packedMetaDataSize s - meta_stats = "number of modules: " <> show (length bytes_per_mod) - <> "\npacked metadata: " <> show meta - - bytes_per_mod = M.toList $ bytesPerModule s - - show_unit (UnitId fs) = unpackFS fs - - ps :: Map UnitId Word64 - ps = M.fromListWith (+) . map (\(m,s) -> (moduleUnitId m,s)) $ bytes_per_mod - - pad :: Int -> String -> String - pad n t = let l = length t - in if l < n then t <> replicate (n-l) ' ' else t - - pkgMods :: [[(Module,Word64)]] - pkgMods = groupBy ((==) `on` (moduleUnitId . fst)) bytes_per_mod - - showMod :: (Module, Word64) -> String - showMod (m,s) = pad 40 (" " <> moduleStableString m <> ":") <> show s <> "\n" - - package_stats :: String - package_stats = "code size summary per package (in bytes):\n\n" - <> concatMap (\(p,s) -> pad 25 (show_unit p <> ":") <> show s <> "\n") (M.toList ps) - - module_stats :: String - module_stats = "code size per module (in bytes):\n\n" <> unlines (map (concatMap showMod) pkgMods) - - -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 - ] - where - ue_state = ue_units unit_env - - -- XXX the profiling library name is probably wrong now - profSuff | csProf cfg = "_p" - | otherwise = "" - - --- | Combine rts.js, lib.js, out.js to all.js that can be run --- directly with node.js or SpiderMonkey jsshell -combineFiles :: JSLinkConfig - -> 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 - --- | write the index.html file that loads the program if it does not exit -writeHtml - :: FilePath -- ^ output directory - -> IO () -writeHtml out = do - let htmlFile = out "index.html" - e <- doesFileExist htmlFile - unless e $ - B.writeFile htmlFile templateHtml - - -templateHtml :: B.ByteString -templateHtml = - "\n\ - \\n\ - \ \n\ - \ \n\ - \ \n\ - \ \n\ - \ \n\ - \" - --- | write the runmain.js file that will be run with defer so that it runs after --- index.html is loaded -writeRunMain - :: FilePath -- ^ output directory - -> IO () -writeRunMain out = do - let runMainFile = out "runmain.js" - e <- doesFileExist runMainFile - unless e $ - B.writeFile runMainFile runMainJS - -runMainJS :: B.ByteString -runMainJS = "h$main(h$mainZCZCMainzimain);\n" - -writeRunner :: JSLinkConfig -- ^ Settings - -> FilePath -- ^ Output directory - -> IO () -writeRunner _settings out = do - cd <- getCurrentDirectory - let arch_os = hostPlatformArchOS - let runner = cd exeFileName arch_os False (Just (dropExtension out)) - srcFile = out "all" <.> "js" - nodePgm :: B.ByteString - nodePgm = "node" - src <- B.readFile (cd srcFile) - B.writeFile runner ("#!/usr/bin/env " <> nodePgm <> "\n" <> src) - perms <- getPermissions runner - setPermissions runner (perms {executable = True}) - -rtsExterns :: FastString -rtsExterns = - "// GHCJS RTS externs for closure compiler ADVANCED_OPTIMIZATIONS\n\n" <> - mconcat (map (\x -> "/** @type {*} */\nObject.d" <> mkFastString (show x) <> ";\n") - [(7::Int)..16384]) - -writeExterns :: FilePath -> IO () -writeExterns out = writeFile (out "all.js.externs") - $ unpackFS rtsExterns - --- | get all dependencies for a given set of roots -getDeps :: Map Module Deps -- ^ loaded deps - -> Set LinkableUnit -- ^ don't link these blocks - -> Set ExportedFun -- ^ start here - -> [LinkableUnit] -- ^ and also link these - -> IO (Set LinkableUnit) -getDeps loaded_deps base fun startlu = go' S.empty (S.fromList startlu) (S.toList fun) - where - go :: Set LinkableUnit - -> Set LinkableUnit - -> IO (Set LinkableUnit) - go result open = case S.minView open of - Nothing -> return result - Just (lu@(lmod,n), open') -> - case M.lookup lmod loaded_deps of - Nothing -> pprPanic "getDeps.go: object file not loaded for: " (pprModule lmod) - Just (Deps _ _ _ b) -> - let block = b!n - result' = S.insert lu result - in go' result' - (addOpen result' open' $ - map (lmod,) (blockBlockDeps block)) (blockFunDeps block) - - go' :: Set LinkableUnit - -> Set LinkableUnit - -> [ExportedFun] - -> IO (Set LinkableUnit) - go' result open [] = go result open - go' result open (f:fs) = - let key = funModule f - in case M.lookup key loaded_deps of - Nothing -> pprPanic "getDeps.go': object file not loaded for: " $ pprModule key - Just (Deps _m _r e _b) -> - let lun :: Int - lun = fromMaybe (pprPanic "exported function not found: " $ ppr f) - (M.lookup f e) - lu = (key, lun) - in go' result (addOpen result open [lu]) fs - - addOpen :: Set LinkableUnit -> Set LinkableUnit -> [LinkableUnit] - -> Set LinkableUnit - addOpen result open newUnits = - let alreadyLinked s = S.member s result || - S.member s open || - S.member s base - in open `S.union` S.fromList (filter (not . alreadyLinked) newUnits) - --- | collect dependencies for a set of roots -collectDeps :: Map Module (Deps, DepsLocation) -- ^ Dependency map - -> [UnitId] -- ^ packages, code linked in this order - -> Set LinkableUnit -- ^ All dependencides - -> IO [ModuleCode] -collectDeps mod_deps packages all_deps = do - - -- read ghc-prim first, since we depend on that for static initialization - let packages' = uncurry (++) $ partition (== primUnitId) (nub packages) - - units_by_module :: Map Module IntSet - units_by_module = M.fromListWith IS.union $ - map (\(m,n) -> (m, IS.singleton n)) (S.toList all_deps) - - mod_deps_bypkg :: Map UnitId [(Deps, DepsLocation)] - mod_deps_bypkg = M.fromListWith (++) - (map (\(m,v) -> (moduleUnitId m,[v])) (M.toList mod_deps)) - - ar_state <- emptyArchiveState - fmap (catMaybes . concat) . forM packages' $ \pkg -> - mapM (uncurry $ extractDeps ar_state units_by_module) - (fromMaybe [] $ M.lookup pkg mod_deps_bypkg) - -extractDeps :: ArchiveState - -> Map Module IntSet - -> Deps - -> DepsLocation - -> IO (Maybe ModuleCode) -extractDeps ar_state units deps loc = - case M.lookup mod units of - Nothing -> return Nothing - Just mod_units -> Just <$> do - let selector n _ = fromIntegral n `IS.member` mod_units || isGlobalUnit (fromIntegral n) - case loc of - ObjectFile fp -> do - us <- readObjectUnits fp selector - pure (collectCode us) - ArchiveFile a -> do - obj <- readArObject ar_state mod a - us <- getObjectUnits obj selector - pure (collectCode us) - InMemory _n obj -> do - us <- getObjectUnits obj selector - pure (collectCode us) - where - mod = depsModule deps - newline = BC.pack "\n" - mk_exports = mconcat . intersperse newline . filter (not . BS.null) . map oiRaw - mk_js_code = mconcat . map oiStat - collectCode l = ModuleCode - { mc_module = mod - , mc_js_code = mk_js_code l - , mc_exports = mk_exports l - , mc_closures = concatMap oiClInfo l - , mc_statics = concatMap oiStatic l - , 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 - Just a -> pure a - Nothing -> do - a <- Ar.loadAr ar_file - modifyIORef (loadedArchives ar_state) (M.insert ar_file a) - pure a - - -- look for the right object in archive - let go_entries = \case - -- XXX this shouldn't be an exception probably - [] -> panic $ "could not find object for module " - ++ moduleNameString (moduleName mod) - ++ " in " - ++ ar_file - - (e:es) -> do - let bs = Ar.filedata e - bh <- unsafeUnpackBinBuffer bs - getObjectHeader bh >>= \case - Left _ -> go_entries es -- not a valid object entry - Right mod_name - | mod_name /= moduleName mod - -> go_entries es -- not the module we're looking for - | otherwise - -> getObjectBody bh mod_name -- found it - - 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] - , S.fromList $ concat - [ mkBaseFuns "GHC.Conc.Sync" - ["reportError"] - , mkBaseFuns "Control.Exception.Base" - ["nonTermination"] - , mkBaseFuns "GHC.Exception.Type" - [ "SomeException" - , "underflowException" - , "overflowException" - , "divZeroException" - ] - , mkBaseFuns "GHC.TopHandler" - [ "runMainIO" - , "topHandler" - ] - , mkBaseFuns "GHC.Base" - ["$fMonadIO"] - , mkBaseFuns "GHC.Maybe" - [ "Nothing" - , "Just" - ] - , mkBaseFuns "GHC.Ptr" - ["Ptr"] - , mkBaseFuns "GHC.JS.Prim" - [ "JSVal" - , "JSException" - , "$fShowJSException" - , "$fExceptionJSException" - , "resolve" - , "resolveIO" - , "toIO" - ] - , mkBaseFuns "GHC.JS.Prim.Internal" - [ "wouldBlock" - , "blockedIndefinitelyOnMVar" - , "blockedIndefinitelyOnSTM" - , "ignoreException" - , "setCurrentThreadResultException" - , "setCurrentThreadResultValue" - ] - , mkPrimFuns "GHC.Types" - [ ":" - , "[]" - ] - , mkPrimFuns "GHC.Tuple.Prim" - [ "(,)" - , "(,,)" - , "(,,,)" - , "(,,,,)" - , "(,,,,,)" - , "(,,,,,,)" - , "(,,,,,,,)" - , "(,,,,,,,,)" - , "(,,,,,,,,,)" - ] - ] - ) - --- | Export the functions in base -mkBaseFuns :: FastString -> [FastString] -> [ExportedFun] -mkBaseFuns = mkExportedFuns baseUnitId - --- | Export the Prim functions -mkPrimFuns :: FastString -> [FastString] -> [ExportedFun] -mkPrimFuns = mkExportedFuns primUnitId - --- | Given a @UnitId@, a module name, and a set of symbols in the module, --- package these into an @ExportedFun@. -mkExportedFuns :: UnitId -> FastString -> [FastString] -> [ExportedFun] -mkExportedFuns uid mod_name symbols = map mk_fun symbols - where - mod = mkModule (RealUnit (Definite uid)) (mkModuleNameFS mod_name) - mk_fun sym = ExportedFun mod (LexicalFastString (mkJsSymbol True mod sym)) - --- | read all dependency data from the to-be-linked files -loadObjDeps :: [LinkedObj] -- ^ object files to link - -> IO (Map Module (Deps, DepsLocation), [LinkableUnit]) -loadObjDeps objs = (prepareLoadedDeps . catMaybes) <$> mapM readDepsFromObj objs - --- | Load dependencies for the Linker from Ar -loadArchiveDeps :: GhcjsEnv - -> [FilePath] - -> IO ( Map Module (Deps, DepsLocation) - , [LinkableUnit] - ) -loadArchiveDeps env archives = modifyMVar (linkerArchiveDeps env) $ \m -> - case M.lookup archives' m of - Just r -> return (m, r) - Nothing -> loadArchiveDeps' archives >>= \r -> return (M.insert archives' r m, r) - where - archives' = S.fromList archives - -loadArchiveDeps' :: [FilePath] - -> IO ( Map Module (Deps, DepsLocation) - , [LinkableUnit] - ) -loadArchiveDeps' archives = do - archDeps <- forM archives $ \file -> do - (Ar.Archive entries) <- Ar.loadAr file - catMaybes <$> mapM (readEntry file) entries - return (prepareLoadedDeps $ concat archDeps) - where - readEntry :: FilePath -> Ar.ArchiveEntry -> IO (Maybe (Deps, DepsLocation)) - readEntry ar_file ar_entry = do - let bs = Ar.filedata ar_entry - bh <- unsafeUnpackBinBuffer bs - getObjectHeader bh >>= \case - Left _ -> pure Nothing -- not a valid object entry - Right mod_name -> do - obj <- getObjectBody bh mod_name - let !deps = objDeps obj - pure $ Just (deps, ArchiveFile ar_file) - --- | 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 :: [(Deps, DepsLocation)] - -> ( Map Module (Deps, DepsLocation) - , [LinkableUnit] - ) -prepareLoadedDeps deps = - let req = concatMap (requiredUnits . fst) deps - depsMap = M.fromList $ map (\d -> (depsModule (fst d), d)) deps - in (depsMap, req) - -requiredUnits :: Deps -> [LinkableUnit] -requiredUnits d = map (depsModule d,) (IS.toList $ depsRequired d) - --- | read dependencies from an object that might have already been into memory --- pulls in all Deps from an archive -readDepsFromObj :: LinkedObj -> IO (Maybe (Deps, DepsLocation)) -readDepsFromObj = \case - ObjLoaded name obj -> do - let !deps = objDeps obj - pure $ Just (deps,InMemory name obj) - ObjFile file -> do - readObjectDeps file >>= \case - Nothing -> pure Nothing - Just deps -> pure $ Just (deps,ObjectFile file) - - --- | 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. --- --- 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. -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 - - createDirectoryIfMissing True (takeDirectory output_fn) - - -- 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 - - -- append common CPP definitions to the .js file. - -- They define macros that avoid directly wiring zencoded names - -- in RTS JS files - pp_fn <- newTempName logger tmpfs (tmpDir dflags) TFL_CurrentModule "js" - payload <- B.readFile input_fn - B.writeFile pp_fn (commonCppDefs profiling <> payload) - - -- run CPP on the input JS file - js_fn <- newTempName logger tmpfs (tmpDir dflags) TFL_CurrentModule "js" - let - cpp_opts = CppOpts - { cppUseCc = True - , cppLinePragmas = False -- LINE pragmas aren't JS compatible - } - doCpp logger - tmpfs - dflags - unit_env - cpp_opts - pp_fn - js_fn - -- add header to recognize the object as a JS file - copyWithHeader header js_fn output_fn - -jsFileNeedsCpp :: FilePath -> IO Bool -jsFileNeedsCpp fn = do - opts <- getOptionsFromJsFile fn - pure (CPP `elem` opts) - --- | Link module codes. --- --- Performs link time optimizations and produces one JStat per module plus some --- commoned up initialization code. -linkModules :: [ModuleCode] -> ([CompactedModuleCode], JStat) -linkModules mods = (compact_mods, meta) - where - compact_mods = map compact mods - - -- here GHCJS used to: - -- - deduplicate declarations - -- - rename local variables into shorter ones - -- - compress initialization data - -- but we haven't ported it (yet). - compact m = CompactedModuleCode - { cmc_js_code = mc_js_code m - , cmc_module = mc_module m - , cmc_exports = mc_exports m - } - - -- common up statics: different bindings may reference the same statics, we - -- filter them here to initialize them once - statics = nubStaticInfo (concatMap mc_statics mods) - - infos = concatMap mc_closures mods - debug = False -- TODO: this could be enabled in a debug build. - -- It adds debug info to heap objects - meta = mconcat - -- render metadata as individual statements - [ mconcat (map staticDeclStat statics) - , mconcat (map staticInitStat statics) - , mconcat (map (closureInfoStat debug) infos) - ] - --- | Only keep a single StaticInfo with a given name -nubStaticInfo :: [StaticInfo] -> [StaticInfo] -nubStaticInfo = go emptyUniqSet - where - go us = \case - [] -> [] - (x:xs) -> - -- only match on siVar. There is no reason for the initializing value to - -- be different for the same global name. - let name = siVar x - in if elementOfUniqSet name us - then go us xs - else x : go (addOneToUniqSet us name) xs - --- | Initialize a global object. --- --- All global objects have to be declared (staticInfoDecl) first. -staticInitStat :: StaticInfo -> JStat -staticInitStat (StaticInfo i sv mcc) = - 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 - where - -- add optional cost-center argument - add_cc_arg as = case mcc of - Nothing -> as - 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 - where - global_ident = TxtI 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" []) - - 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)] - StaticUnboxedStringOffset {} -> 0 - - to_byte_list = JList . map (Int . fromIntegral) . BS.unpack +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE MultiWayIf #-} + +----------------------------------------------------------------------------- +-- | +-- Module : GHC.StgToJS.Linker.Linker +-- 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 +-- +-- GHCJS linker, collects dependencies from the object files +-- which contain linkable units with dependency information +-- +----------------------------------------------------------------------------- + +module GHC.StgToJS.Linker.Linker + ( jsLinkBinary + , jsLink + , embedJsFile + , mkExportedFuns + , mkExportedModFuns + , computeLinkDependencies + , LinkSpec (..) + , LinkPlan (..) + , emptyLinkPlan + , incrementLinkPlan + , ArchiveCache + , newArchiveCache + ) +where + +import GHC.Prelude + +import GHC.Platform.Host (hostPlatformArchOS) + +import GHC.JS.Make +import GHC.JS.Optimizer +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(..)) +import Language.Haskell.Syntax.Module.Name +import GHC.SysTools.Cpp +import GHC.SysTools + +import GHC.Linker.Static.Utils (exeFileName) +import GHC.Linker.Types (linkableObjs) +import GHC.Linker.External + +import GHC.StgToJS.Linker.Types +import GHC.StgToJS.Linker.Utils +import GHC.StgToJS.Linker.Opt +import GHC.StgToJS.Rts.Rts +import GHC.StgToJS.Object +import GHC.StgToJS.Types hiding (LinkableUnit) +import GHC.StgToJS.Symbols +import GHC.StgToJS.Arg +import GHC.StgToJS.Closure + +import GHC.Unit.State +import GHC.Unit.Env +import GHC.Unit.Home.ModInfo +import GHC.Unit.Types +import GHC.Unit.Module (moduleStableString) + +import GHC.Utils.Outputable hiding ((<>)) +import GHC.Utils.BufHandle +import GHC.Utils.Panic +import GHC.Utils.Error +import GHC.Utils.Logger (Logger, logVerbAtLeast) +import GHC.Utils.Binary +import qualified GHC.Utils.Ppr as Ppr +import GHC.Utils.TmpFs + +import GHC.Types.Unique.Set + +import qualified GHC.SysTools.Ar as Ar + +import qualified GHC.Data.ShortText as ST +import GHC.Data.FastString + +import Control.Monad + +import Data.Array +import qualified Data.ByteString as B +import qualified Data.ByteString.Char8 as BC +import qualified Data.ByteString.Lazy as BL +import qualified Data.ByteString as BS +import Data.Function (on) +import qualified Data.IntSet as IS +import Data.IORef +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) +import System.Directory ( createDirectoryIfMissing + , doesFileExist + , getCurrentDirectory + , Permissions(..) + , setPermissions + , getPermissions + ) + +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 ArchiveCache = ArchiveCache { loadedArchives :: IORef (Map FilePath Ar.Archive) } + +newArchiveCache :: IO ArchiveCache +newArchiveCache = ArchiveCache <$> newIORef M.empty + +defaultJsContext :: SDocContext +defaultJsContext = defaultSDocContext{sdocStyle = PprCode} + +jsLinkBinary + :: FinderCache + -> JSLinkConfig + -> StgToJSConfig + -> Logger + -> TmpFs + -> DynFlags + -> UnitEnv + -> [FilePath] + -> [UnitId] + -> IO () +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 ] + + -- 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 + 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_root_filter = is_root + , lks_extra_roots = mempty + , 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 ar_cache + + 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 tmpfs ar_cache out link_plan = do + + -- create output directory + createDirectoryIfMissing False out + + when (logVerbAtLeast logger 2) $ + logInfo logger $ hang (text "jsLink:") 2 (ppr link_plan) + + ------------------------------------------------------------- + -- link all Haskell code (program + dependencies) into out.js + + -- retrieve code for Haskell dependencies + mods <- collectModuleCodes ar_cache link_plan + + -- LTO + rendering of JS code + link_stats <- withBinaryFile (out "out.js") WriteMode $ \h -> + renderModules h (csPrettyRender cfg) mods + + ------------------------------------------------------------- + + -- dump foreign references file (.frefs) + when (lcForeignRefs lc_cfg) $ do + let frefsFile = "out.frefs" + -- frefs = concatMap mc_frefs mods + jsonFrefs = mempty -- FIXME: toJson frefs + + BL.writeFile (out frefsFile <.> "json") jsonFrefs + BL.writeFile (out frefsFile <.> "js") + ("h$checkForeignRefs(" <> jsonFrefs <> ");") + + -- dump stats + unless (lcNoStats lc_cfg) $ do + let statsFile = "out.stats" + writeFile (out statsFile) (renderLinkerStats link_stats) + + -- link generated RTS parts into rts.js + unless (lcNoRts lc_cfg) $ do + jsm <- initJSM + withFile (out "rts.js") WriteMode $ \h -> do + let opt = jsOptimize (runJSM jsm $ jStgStatToJS <$> rts cfg) + void $ + hPutJS (csPrettyRender cfg) h opt + + + -- 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 + writeRunMain out use_emcc_rts + _ <- combineFiles lc_cfg link_c_sources out + writeHtml out + writeRunner lc_cfg out + writeExterns out + +data LinkSpec = LinkSpec + { lks_unit_ids :: [UnitId] + , 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 "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)] + ] + +emptyLinkPlan :: LinkPlan +emptyLinkPlan = LinkPlan + { lkp_block_info = mempty + , lkp_dep_blocks = mempty + , lkp_archives = mempty + , lkp_objs_js = mempty + , lkp_objs_cc = mempty + } + +-- | Given a `base` link plan (assumed to be already linked) and a `new` link +-- plan, compute `(diff, total)` link plans. +-- +-- - `diff` is the incremental link plan to get from `base` to `total` +-- - `total` is the total link plan as if `base` and `new` were linked at once +incrementLinkPlan :: LinkPlan -> LinkPlan -> (LinkPlan, LinkPlan) +incrementLinkPlan base new = (diff,total) + where + total = LinkPlan + { 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_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_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) + } + + +computeLinkDependencies + :: StgToJSConfig + -> UnitEnv + -> LinkSpec + -> FinderOpts + -> FinderCache + -> ArchiveCache + -> IO LinkPlan +computeLinkDependencies cfg unit_env link_spec finder_opts finder_cache ar_cache = do + + let units = lks_unit_ids 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 + + -- Process: + -- 1) Find new required linkables (object files, libraries, etc.) for all + -- transitive dependencies + -- 2) Load ObjBlockInfo from them and cache them + -- 3) Compute ObjBlock dependencies and return the link plan + + -- TODO (#23013): currently we directly compute the ObjBlock dependencies and + -- find/load linkable on-demand when a module is missing. + + + (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 + + -- 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 + + -- all the units we want to link together, including their dependencies, + -- preload units, and backpack instantiations + all_units_infos <- mayThrowUnitErr (preloadUnitsInfo' unit_env root_units) + + let all_units = fmap unitId all_units_infos + + dep_archives <- getPackageArchives cfg unit_env all_units + (archives_block_info, archives_required_blocks) <- loadArchiveBlockInfo ar_cache dep_archives + + -- compute dependencies + let block_info = objs_block_info `M.union` archives_block_info + dep_fun_roots = obj_roots `S.union` rts_wired_functions `S.union` extra_roots + + -- read transitive dependencies + new_required_blocks_var <- newIORef [] + let load_info mod = do + -- Adapted from the tangled code in GHC.Linker.Loader.getLinkDeps. + 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... + case ue_homeUnit unit_env of + Nothing -> pprPanic "getDeps: No home-unit: " (pprModule mod) + Just home_unit -> do + mb_stuff <- findHomeModule finder_cache finder_opts home_unit (moduleName mod) + case mb_stuff of + Found loc mod -> found loc mod + _ -> pprPanic "getDeps: Couldn't find home-module: " (pprModule mod) + where + found loc mod = do { + mb_lnk <- findObjectLinkableMaybe mod loc ; + case mb_lnk of { + Nothing -> pprPanic "getDeps: Couldn't find linkable for module: " (pprModule mod) ; + Just lnk -> pure lnk + }} + + Just mod_info -> case homeModInfoObject mod_info of + Nothing -> pprPanic "getDeps: Couldn't find object file for home-module: " (pprModule mod) + Just lnk -> pure lnk + + -- 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 + (updated_block_info, transitive_deps) <- getDeps block_info load_info dep_fun_roots mempty + + new_required_blocks <- readIORef new_required_blocks_var + let required_blocks = S.fromList $ mconcat + [ archives_required_blocks + , objs_required_blocks + , new_required_blocks + ] + + let all_deps = S.union transitive_deps required_blocks + + let plan = LinkPlan + { lkp_block_info = updated_block_info + , lkp_dep_blocks = all_deps + , lkp_archives = S.fromList dep_archives + , lkp_objs_js = S.fromList js_objs + , lkp_objs_cc = S.fromList cc_objs + } + + return plan + + +-- | Compiled module +data ModuleCode = ModuleCode + { mc_module :: !Module + , 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 :: !JS.JStat + , cmc_exports :: !B.ByteString -- ^ rendered exports + } + +-- | Output JS statements and return the output size in bytes. +hPutJS :: Bool -> Handle -> JS.JStat -> IO Integer +hPutJS render_pretty h = \case + JS.BlockStat [] -> pure 0 + x -> do + before <- hTell h + if render_pretty + then do + printSDoc defaultJsContext (Ppr.PageMode True) h (pretty render_pretty x) + else do + bh <- newBufHandle h + bPutHDoc bh defaultJsContext (line $ pretty render_pretty x) + bFlush bh + -- Append an empty line to correctly end the file in a newline + hPutChar h '\n' + after <- hTell h + pure $! (after - before) + +-- | Link modules and pretty-print them into the given Handle +renderModules + :: Handle + -> Bool -- ^ should we render readable JS for debugging? + -> [ModuleCode] -- ^ linked code per module + -> IO LinkerStats +renderModules h render_pretty mods = do + + -- link modules + let (compacted_mods, meta) = linkModules mods + + let + putJS = hPutJS render_pretty h + + --------------------------------------------------------- + -- Pretty-print JavaScript code for all the dependencies. + -- + -- We have to pretty-print at link time because we want to be able to perform + -- global link-time optimisations (e.g. renamings) on the whole generated JS + -- file. + + -- modules themselves + mod_sizes <- forM compacted_mods $ \m -> do + + !mod_size <- fromIntegral <$> (putJS $ cmc_js_code m) + let !mod_mod = cmc_module m + pure (mod_mod, mod_size) + + -- commoned up metadata + let meta_opt = jsOptimize meta + !meta_length <- fromIntegral <$> putJS meta_opt + + -- module exports + mapM_ (B.hPut h . cmc_exports) compacted_mods + + -- stats + let !link_stats = LinkerStats + { bytesPerModule = M.fromList mod_sizes + , packedMetaDataSize = meta_length + } + + pure link_stats + +-- | Render linker stats +renderLinkerStats :: LinkerStats -> String +renderLinkerStats s = + intercalate "\n\n" [meta_stats, package_stats, module_stats] <> "\n\n" + where + meta = packedMetaDataSize s + meta_stats = "number of modules: " <> show (length bytes_per_mod) + <> "\npacked metadata: " <> show meta + + bytes_per_mod = M.toList $ bytesPerModule s + + show_unit (UnitId fs) = unpackFS fs + + ps :: Map UnitId Word64 + ps = M.fromListWith (+) . map (\(m,s) -> (moduleUnitId m,s)) $ bytes_per_mod + + pad :: Int -> String -> String + pad n t = let l = length t + in if l < n then t <> replicate (n-l) ' ' else t + + pkgMods :: [[(Module,Word64)]] + pkgMods = groupBy ((==) `on` (moduleUnitId . fst)) bytes_per_mod + + showMod :: (Module, Word64) -> String + showMod (m,s) = pad 40 (" " <> moduleStableString m <> ":") <> show s <> "\n" + + package_stats :: String + package_stats = "code size summary per package (in bytes):\n\n" + <> concatMap (\(p,s) -> pad 25 (show_unit p <> ":") <> show s <> "\n") (M.toList ps) + + module_stats :: String + module_stats = "code size per module (in bytes):\n\n" <> unlines (map (concatMap showMod) pkgMods) + + +getPackageArchives :: StgToJSConfig -> UnitEnv -> [UnitId] -> IO [FilePath] +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_homeUnitState unit_env + + -- XXX the profiling library name is probably wrong now + profSuff | csProf cfg = "_p" + | otherwise = "" + + +-- | 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 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 + :: FilePath -- ^ output directory + -> IO () +writeHtml out = do + let htmlFile = out "index.html" + e <- doesFileExist htmlFile + unless e $ + B.writeFile htmlFile templateHtml + + +templateHtml :: B.ByteString +templateHtml = + "\n\ + \\n\ + \ \n\ + \ \n\ + \ \n\ + \ \n\ + \ \n\ + \" + +-- | write the runmain.js file that will be run with defer so that it runs after +-- index.html is loaded +writeRunMain + :: FilePath -- ^ output directory + -> UseEmccRts + -> IO () +writeRunMain out use_emcc_rts = do + let runMainFile = out "runmain.js" + B.writeFile runMainFile (runMainJS use_emcc_rts) + +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 () +writeRunner _settings out = do + cd <- getCurrentDirectory + let arch_os = hostPlatformArchOS + let runner = cd exeFileName arch_os False (Just (dropExtension out)) + srcFile = out "all" <.> "js" + nodePgm :: B.ByteString + nodePgm = "node" + src <- B.readFile (cd srcFile) + B.writeFile runner ("#!/usr/bin/env " <> nodePgm <> "\n" <> src) + perms <- getPermissions runner + setPermissions runner (perms {executable = True}) + +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 + -- 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.externs.js") + $ unpackFS rtsExterns + +-- | Get all block dependencies for a given set of roots +-- +-- 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 + -> Set BlockRef -- ^ and also link these + -> IO (Map Module LocatedBlockInfo, Set BlockRef) +getDeps init_infos load_info root_funs root_blocks = traverse_funs init_infos S.empty root_blocks (S.toList root_funs) + where + -- A block may depend on: + -- 1. other blocks from the same module + -- 2. exported functions from another module + -- + -- Process: + -- 1. We use the BlockInfos to find the block corresponding to every + -- exported root functions. + -- + -- 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 + -- add them to root_blocks (if they aren't already added to the result) and + -- to root_funs. + -- + -- 4. back to 1 + + lookup_info infos mod = case M.lookup mod infos of + Just info -> pure (infos, lbi_info info) + Nothing -> do + -- load info and update cache with it + info <- load_info mod + pure (M.insert mod info infos, lbi_info info) + + traverse_blocks + :: Map Module LocatedBlockInfo + -> Set BlockRef + -> Set BlockRef + -> IO (Map Module LocatedBlockInfo, Set BlockRef) + traverse_blocks infos result open = case S.minView open of + Nothing -> return (infos, result) + Just (ref, open') -> do + let mod = block_ref_mod ref + !(infos',info) <- lookup_info infos mod + let block = bi_block_deps info ! block_ref_idx ref + result' = S.insert ref result + to_block_ref i = BlockRef + { block_ref_mod = mod + , block_ref_idx = i + } + traverse_funs infos' result' + (addOpen result' open' $ + map to_block_ref (blockBlockDeps block)) (blockFunDeps block) + + traverse_funs + :: Map Module LocatedBlockInfo + -> Set BlockRef + -> Set BlockRef + -> [ExportedFun] + -> IO (Map Module LocatedBlockInfo, Set BlockRef) + traverse_funs infos result open = \case + [] -> traverse_blocks infos result open + (f:fs) -> do + let mod = funModule f + -- lookup module block info for the module that exports the function + !(infos',info) <- lookup_info infos mod + -- lookup block index associated to the function in the block info + case M.lookup f (bi_exports info) of + Nothing -> pprPanic "exported function not found: " $ ppr f + Just idx -> do + let fun_block_ref = BlockRef + { block_ref_mod = mod + , block_ref_idx = idx + } + -- always add the module "global block" when we link a module + let global_block_ref = BlockRef + { block_ref_mod = mod + , block_ref_idx = 0 + } + traverse_funs infos' result (addOpen result open [fun_block_ref,global_block_ref]) fs + + -- extend the open block set with new blocks that are not already in the + -- result block set nor in the open block set. + addOpen + :: Set BlockRef + -> Set BlockRef + -> [BlockRef] + -> Set BlockRef + addOpen result open new_blocks = + let alreadyLinked s = S.member s result || S.member s open + in open `S.union` S.fromList (filter (not . alreadyLinked) new_blocks) + +-- | collect dependencies for a set of roots +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 + + -- we're going to load all the blocks. Instead of doing this randomly, we + -- group them by module first. + let module_blocks :: Map Module BlockIds + module_blocks = M.fromListWith IS.union $ + map (\ref -> (block_ref_mod ref, IS.singleton (block_ref_idx ref))) (S.toList blocks) + + -- load blocks + forM (M.toList module_blocks) $ \(mod,bids) -> do + case M.lookup mod block_info of + Nothing -> pprPanic "collectModuleCodes: couldn't find block info for module" (ppr mod) + Just lbi -> extractBlocks ar_cache lbi bids + +extractBlocks :: ArchiveCache -> LocatedBlockInfo -> BlockIds -> IO ModuleCode +extractBlocks ar_state lbi blocks = do + case lbi_loc lbi of + ObjectFile fp -> do + us <- readObjectBlocks fp blocks + pure (collectCode us) + ArchiveFile a -> do + obj <- readArObject ar_state mod a + us <- getObjectBlocks obj blocks + pure (collectCode us) + InMemory _n obj -> do + us <- getObjectBlocks obj blocks + pure (collectCode us) + where + mod = bi_module (lbi_info lbi) + newline = BC.pack "\n" + mk_exports = mconcat . intersperse newline . filter (not . BS.null) . map oiRaw + mk_js_code = mconcat . map oiStat + collectCode l = ModuleCode + { mc_module = mod + , mc_js_code = mk_js_code l + , mc_exports = mk_exports l + , mc_closures = concatMap oiClInfo l + , mc_statics = concatMap oiStatic l + , mc_frefs = concatMap oiFImports l + } + +-- | 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_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 + [] -> panic $ "could not find object for module " + ++ moduleNameString (moduleName mod) + ++ " in " + ++ ar_file + + (e:es) -> do + let bs = Ar.filedata e + bh <- unsafeUnpackBinBuffer bs + getObjectHeader bh >>= \case + Left _ -> go_entries es -- not a valid object entry + Right mod_name + | mod_name /= moduleName mod + -> go_entries es -- not the module we're looking for + | otherwise + -> getObjectBody bh mod_name -- found it + + go_entries entries + +-- | dependencies for the RTS, these need to be always linked +rtsDeps :: ([UnitId], Set ExportedFun) +rtsDeps = + ( [ghcInternalUnitId] + , S.fromList $ concat + [ mkInternalFuns "GHC.Internal.Conc.Sync" + ["reportError"] + , mkInternalFuns "GHC.Internal.Control.Exception.Base" + ["nonTermination"] + , mkInternalFuns "GHC.Internal.Exception.Type" + [ "SomeException" + , "underflowException" + , "overflowException" + , "divZeroException" + ] + , mkInternalFuns "GHC.Internal.TopHandler" + [ "runMainIO" + , "topHandler" + ] + , mkInternalFuns "GHC.Internal.Base" + ["$fMonadIO"] + , mkInternalFuns "GHC.Internal.Maybe" + [ "Nothing" + , "Just" + ] + , mkInternalFuns "GHC.Internal.Ptr" + ["Ptr"] + , mkInternalFuns "GHC.Internal.JS.Prim" + [ "JSVal" + , "JSException" + , "$fShowJSException" + , "$fExceptionJSException" + , "resolve" + , "resolveIO" + , "toIO" + ] + , mkInternalFuns "GHC.Internal.JS.Prim.Internal" + [ "wouldBlock" + , "blockedIndefinitelyOnMVar" + , "blockedIndefinitelyOnSTM" + , "ignoreException" + , "setCurrentThreadResultException" + , "setCurrentThreadResultValue" + ] + , mkInternalFuns "GHC.Internal.Types" + [ ":" + , "[]" + ] + , mkInternalFuns "GHC.Internal.Tuple" + [ "(,)" + , "(,,)" + , "(,,,)" + , "(,,,,)" + , "(,,,,,)" + , "(,,,,,,)" + , "(,,,,,,,)" + , "(,,,,,,,,)" + , "(,,,,,,,,,)" + ] + ] + ) + +-- | 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@. +mkExportedFuns :: UnitId -> FastString -> [FastString] -> [ExportedFun] +mkExportedFuns uid mod_name symbols = mkExportedModFuns mod names + where + mod = mkModule (RealUnit (Definite uid)) (mkModuleNameFS mod_name) + names = map (mkJsSymbol True mod) symbols + +-- | Given a @Module@ and a set of symbols in the module, package these into an +-- @ExportedFun@. +mkExportedModFuns :: Module -> [FastString] -> [ExportedFun] +mkExportedModFuns mod symbols = map mk_fun symbols + where + mk_fun sym = ExportedFun mod (LexicalFastString sym) + +-- | read all dependency data from the to-be-linked files +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 :: ArchiveCache -> [FilePath] -> IO (Map Module LocatedBlockInfo, [BlockRef]) +loadArchiveBlockInfo ar_cache archives = do + archDeps <- forM archives $ \file -> do + (Ar.Archive entries) <- loadArchive ar_cache file + catMaybes <$> mapM (readEntry file) entries + return (prepareLoadedDeps $ concat archDeps) + where + readEntry :: FilePath -> Ar.ArchiveEntry -> IO (Maybe LocatedBlockInfo) + readEntry ar_file ar_entry = do + let bs = Ar.filedata ar_entry + bh <- unsafeUnpackBinBuffer bs + getObjectHeader bh >>= \case + Left _ -> pure Nothing -- not a valid object entry + Right mod_name -> do + obj <- getObjectBody bh mod_name + let !info = objBlockInfo obj + pure $ Just (LocatedBlockInfo (ArchiveFile ar_file) info) + +prepareLoadedDeps :: [LocatedBlockInfo] + -> (Map Module LocatedBlockInfo, [BlockRef]) +prepareLoadedDeps lbis = (module_blocks, must_link) + where + must_link = concatMap (requiredBlocks . lbi_info) lbis + module_blocks = M.fromList $ map (\d -> (bi_module (lbi_info d), d)) lbis + +requiredBlocks :: BlockInfo -> [BlockRef] +requiredBlocks d = map mk_block_ref (IS.toList $ bi_must_link d) + where + mk_block_ref i = BlockRef + { block_ref_mod = bi_module d + , block_ref_idx = i + } + +-- | read block info from an object that might have already been into memory +-- pulls in all Deps from an archive +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 JS object .o file +-- +-- JS files may contain option pragmas of the form: //#OPTIONS: +-- 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 + + createDirectoryIfMissing True (takeDirectory output_fn) + + -- the header lets the linker recognize processed JavaScript files + -- But don't add JavaScript header to object files! + + -- 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 + pp_fn <- newTempName logger tmpfs (tmpDir dflags) TFL_CurrentModule "js" + payload <- B.readFile input_fn + B.writeFile pp_fn (commonCppDefs profiling <> payload) + + -- run CPP on the input JS file + js_fn <- newTempName logger tmpfs (tmpDir dflags) TFL_CurrentModule "js" + let + cpp_opts = CppOpts + { sourceCodePreprocessor = SCPJsCpp + -- JS code requires keeping JSDoc comments for third party minification tooling + , cppLinePragmas = False -- LINE pragmas aren't JS compatible + } + doCpp logger + tmpfs + dflags + unit_env + cpp_opts + pp_fn + js_fn + pure js_fn + + -- 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], JS.JStat) +linkModules mods = (compact_mods, meta) + where + compact_mods = map compact mods + + -- here GHCJS used to: + -- - deduplicate declarations + -- - rename local variables into shorter ones + -- - compress initialization data + -- but we haven't ported it (yet). + compact m = CompactedModuleCode + { cmc_js_code = mc_js_code m + , cmc_module = mc_module m + , cmc_exports = mc_exports m + } + + -- common up statics: different bindings may reference the same statics, we + -- filter them here to initialize them once + statics = nubStaticInfo (concatMap mc_statics mods) + + infos = concatMap mc_closures mods + debug = False -- TODO: this could be enabled in a debug build. + -- It adds debug info to heap objects + meta = mconcat + -- render metadata as individual statements + [ mconcat (map staticDeclStat statics) + , mconcat (map staticInitStat statics) + , jStgStatToJS $ mconcat (map (closureInfoStat debug) infos) + ] + +-- | Only keep a single StaticInfo with a given name +nubStaticInfo :: [StaticInfo] -> [StaticInfo] +nubStaticInfo = go emptyUniqSet + where + go us = \case + [] -> [] + (x:xs) -> + -- only match on siVar. There is no reason for the initializing value to + -- be different for the same global name. + let name = siVar x + in if elementOfUniqSet name us + then go us xs + else x : go (addOneToUniqSet us name) xs + +-- | Initialize a global object. +-- +-- All global objects have to be declared (staticInfoDecl) first. +staticInitStat :: StaticInfo -> JS.JStat +staticInitStat (StaticInfo i sv mcc) = + jStgStatToJS $ + case sv of + (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 + Nothing -> as + Just cc -> as ++ [toJExpr cc] + +-- | declare and do first-pass init of a global object (create JS object for heap objects) +staticDeclStat :: StaticInfo -> JS.JStat +staticDeclStat (StaticInfo global_name static_value _) = jStgStatToJS decl + where + global_ident = name global_name + decl_init v = global_ident ||= v + + decl = case static_value of + StaticUnboxed u -> decl_init (unboxed_expr u) + _ -> decl_init (app hdDStr []) + + unboxed_expr = \case + StaticUnboxedBool b -> app hdPStr [toJExpr b] + StaticUnboxedInt i -> app hdPStr [toJExpr i] + StaticUnboxedDouble d -> app hdPStr [toJExpr (unSaneDouble d)] + 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 new file mode 100644 --- /dev/null +++ b/GHC/StgToJS/Linker/Opt.hs @@ -0,0 +1,127 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE ViewPatterns #-} + +----------------------------------------------------------------------------- +-- | +-- Module : GHC.StgToJS.Linker.Opt +-- Copyright : (c) The University of Glasgow 2001 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : Jeffrey Young +-- Luite Stegeman +-- Sylvain Henry +-- Stability : experimental +-- +-- Optimization pass at link time +-- +-- +-- +----------------------------------------------------------------------------- +module GHC.StgToJS.Linker.Opt + ( pretty + , optRenderJs + ) +where + +import GHC.Prelude +import GHC.Int +import GHC.Exts + +import GHC.JS.Syntax +import GHC.JS.Ppr + +import GHC.Utils.Outputable +import GHC.Data.FastString +import GHC.Types.Unique.Map + +import Data.List (sortOn) +import Data.Char (isAlpha,isDigit,ord) +import qualified Data.ByteString.Short as SBS + +pretty :: JsRender doc => Bool -> JStat -> doc +pretty render_pretty = \case + BlockStat [] -> empty + s | render_pretty -> jsToDocR defaultRenderJs [s] + | otherwise -> jsToDocR optRenderJs [s] + -- render as a list of statements to ensure that + -- semicolons are added. + +-- | Render JS with code size minimization enabled +optRenderJs :: RenderJs doc +optRenderJs = defaultRenderJs + { renderJsV = ghcjsRenderJsV + , renderJsS = ghcjsRenderJsS + , renderJsI = ghcjsRenderJsI + } + +hdd :: SBS.ShortByteString +hdd = SBS.pack (map (fromIntegral . ord) "h$$") + +ghcjsRenderJsI :: IsLine doc => RenderJs doc -> Ident -> doc +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. + -- + -- These symbols are usually very large because their name includes the + -- unit-id, the module name, and some unique number. So we rename these + -- symbols with a much shorter globally unique number. + -- + -- Here we reuse their FastString unique for this purpose! Note that it only + -- works if we pretty-print all the JS code linked together at once, which we + -- currently do. GHCJS used to maintain a CompactorState to support + -- incremental linking: it contained the mapping between original symbols and + -- their renaming. + | hdd `SBS.isPrefixOf` fastStringToShortByteString fs + , u <- uniqueOfFS fs + = text "h$$" <> hexDoc (fromIntegral u) + | otherwise + = ftext fs + +-- | Render as an hexadecimal number in reversed order (because it's faster and we +-- don't care about the actual value). +hexDoc :: IsLine doc => Word -> doc +hexDoc 0 = char '0' +hexDoc v = text $ go v + where + sym (I# i) = C# (indexCharOffAddr# chars i) + chars = "0123456789abcdef"# + go = \case + 0 -> [] + n -> sym (fromIntegral (n .&. 0x0F)) + : sym (fromIntegral ((n .&. 0xF0) `shiftR` 4)) + : go (n `shiftR` 8) + + + + +-- attempt to resugar some of the common constructs +ghcjsRenderJsS :: JsRender doc => RenderJs doc -> JStat -> doc +ghcjsRenderJsS r s = renderJsS defaultRenderJs r s + +-- don't quote keys in our object literals, so closure compiler works +ghcjsRenderJsV :: JsRender doc => RenderJs doc -> JVal -> doc +ghcjsRenderJsV r (JHash m) + | isNullUniqMap m = text "{}" + | otherwise = braceNest . fsep . punctuate comma . + map (\(x,y) -> quoteIfRequired x <> colon <+> jsToDocR r y) + -- nonDetEltsUniqMap doesn't introduce non-determinism here because + -- we sort the elements lexically + . sortOn (LexicalFastString . fst) $ nonDetUniqMapToList m + where + quoteIfRequired :: IsLine doc => FastString -> doc + quoteIfRequired x + | isUnquotedKey x = ftext x + | otherwise = char '\'' <> ftext x <> char '\'' + + isUnquotedKey :: FastString -> Bool + isUnquotedKey fs = case unpackFS fs of + [] -> False + s@(c:cs) -> all isDigit s || (validFirstIdent c && all validOtherIdent cs) + + validFirstIdent c = c == '_' || c == '$' || isAlpha c + validOtherIdent c = isAlpha c || isDigit c + +ghcjsRenderJsV r v = renderJsV defaultRenderJs r v 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 @@ -2,8 +2,6 @@ {-# LANGUAGE PartialTypeSignatures #-} {-# LANGUAGE LambdaCase #-} -{-# OPTIONS_GHC -Wno-orphans #-} -- for Ident's Binary instance - ----------------------------------------------------------------------------- -- | -- Module : GHC.StgToJS.Linker.Types @@ -19,26 +17,19 @@ ----------------------------------------------------------------------------- module GHC.StgToJS.Linker.Types - ( GhcjsEnv (..) - , newGhcjsEnv - , JSLinkConfig (..) - , defaultJSLinkConfig - , generateAllJs - , LinkedObj (..) - , LinkableUnit + ( JSLinkConfig (..) + , LinkPlan (..) ) where import GHC.StgToJS.Object import GHC.Unit.Types -import GHC.Utils.Outputable (hsep,Outputable(..),text,ppr) +import GHC.Utils.Outputable (Outputable(..),text,ppr, hang, IsDoc (vcat), IsLine (hcat)) import Data.Map.Strict (Map) -import qualified Data.Map.Strict as M import Data.Set (Set) - -import Control.Concurrent.MVar +import qualified Data.Set as S import System.IO @@ -49,53 +40,45 @@ -------------------------------------------------------------------------------- data JSLinkConfig = JSLinkConfig - { lcNoJSExecutables :: Bool - , lcNoHsMain :: Bool - , lcOnlyOut :: Bool - , lcNoRts :: Bool - , lcNoStats :: Bool - } - --- | we generate a runnable all.js only if we link a complete application, --- no incremental linking and no skipped parts -generateAllJs :: JSLinkConfig -> Bool -generateAllJs s = not (lcOnlyOut s) && not (lcNoRts s) - -defaultJSLinkConfig :: JSLinkConfig -defaultJSLinkConfig = JSLinkConfig - { lcNoJSExecutables = False - , lcNoHsMain = False - , lcOnlyOut = False - , lcNoRts = False - , lcNoStats = False + { 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. } --------------------------------------------------------------------------------- --- Linker Environment --------------------------------------------------------------------------------- +data LinkPlan = LinkPlan + { lkp_block_info :: Map Module LocatedBlockInfo + -- ^ Block information --- | A @LinkableUnit@ is a pair of a module and the index of the block in the --- object file -type LinkableUnit = (Module, Int) + , lkp_dep_blocks :: Set BlockRef + -- ^ Blocks to link --- | 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 + , lkp_archives :: !(Set FilePath) + -- ^ Archives to load JS and Cc sources from (JS code corresponding to + -- Haskell code is handled with blocks above) -instance Outputable LinkedObj where - ppr = \case - ObjFile fp -> hsep [text "ObjFile", text fp] - ObjLoaded s o -> hsep [text "ObjLoaded", text s, ppr (objModuleName o)] + , lkp_objs_js :: !(Set FilePath) + -- ^ JS objects to link -data GhcjsEnv = GhcjsEnv - { linkerArchiveDeps :: MVar (Map (Set FilePath) - (Map Module (Deps, DepsLocation) - , [LinkableUnit] - ) - ) + , lkp_objs_cc :: !(Set FilePath) + -- ^ Cc objects to link } --- | return a fresh @GhcjsEnv@ -newGhcjsEnv :: IO GhcjsEnv -newGhcjsEnv = GhcjsEnv <$> newMVar M.empty +instance Outputable LinkPlan where + ppr s = hang (text "LinkPlan") 2 $ vcat + -- Hidden because it's too verbose and it's not really part of the + -- 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 "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)))) + ] 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 @@ -42,10 +41,15 @@ import Prelude import GHC.Platform 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.Data.FastString + -- | Retrieve library directories provided by the @UnitId@ in @UnitState@ getInstalledPackageLibDirs :: UnitState -> UnitId -> [ShortText] getInstalledPackageLibDirs us = maybe mempty unitLibraryDirs . lookupUnitId us @@ -70,6 +74,28 @@ commonCppDefs_vanilla = genCommonCppDefs False commonCppDefs_profiled = genCommonCppDefs True +-- | 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$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 + symbol = identFS $ makeIdentForId (dataConWorkId $ tupleDataCon Boxed n) Nothing IdConEntry mod + name = tupleDataConName Boxed n + mod = case nameModule_maybe name of + Just m -> m + Nothing -> error "Tuple constructor is missing a module" + -- | Generate CPP Definitions depending on a profiled or normal build. This -- occurs at link time. genCommonCppDefs :: Bool -> ByteString @@ -86,86 +112,64 @@ in mconcat (closure_defs ++ thread_defs) -- low-level heap object manipulation macros - , if profiling - then mconcat - [ "#define MK_TUP2(x1,x2) (h$c2(h$ghczmprimZCGHCziTupleziPrimziZLz2cUZR_con_e,(x1),(x2),h$currentThread?h$currentThread.ccs:h$CCS_SYSTEM))\n" - , "#define MK_TUP3(x1,x2,x3) (h$c3(h$ghczmprimZCGHCziTupleziPrimziZLz2cUz2cUZR_con_e,(x1),(x2),(x3),h$currentThread?h$currentThread.ccs:h$CCS_SYSTEM))\n" - , "#define MK_TUP4(x1,x2,x3,x4) (h$c4(h$ghczmprimZCGHCziTupleziPrimziZLz2cUz2cUz2cUZR_con_e,(x1),(x2),(x3),(x4),h$currentThread?h$currentThread.ccs:h$CCS_SYSTEM))\n" - , "#define MK_TUP5(x1,x2,x3,x4,x5) (h$c5(h$ghczmprimZCGHCziTupleziPrimziZLz2cUz2cUz2cUz2cUZR_con_e,(x1),(x2),(x3),(x4),(x5),h$currentThread?h$currentThread.ccs:h$CCS_SYSTEM))\n" - , "#define MK_TUP6(x1,x2,x3,x4,x5,x6) (h$c6(h$ghczmprimZCGHCziTupleziPrimziZLz2cUz2cUz2cUz2cUz2cUZR_con_e,(x1),(x2),(x3),(x4),(x5),(x6),h$currentThread?h$currentThread.ccs:h$CCS_SYSTEM))\n" - , "#define MK_TUP7(x1,x2,x3,x4,x5,x6,x7) (h$c7(h$ghczmprimZCGHCziTupleziPrimziZLz2cUz2cUz2cUz2cUz2cUz2cUZR_con_e,(x1),(x2),(x3),(x4),(x5),(x6),(x7),h$currentThread?h$currentThread.ccs:h$CCS_SYSTEM))\n" - , "#define MK_TUP8(x1,x2,x3,x4,x5,x6,x7,x8) (h$c8(h$ghczmprimZCGHCziTupleziPrimziZLz2cUz2cUz2cUz2cUz2cUz2cUz2cUZR_con_e,(x1),(x2),(x3),(x4),(x5),(x6),(x7),(x8),h$currentThread?h$currentThread.ccs:h$CCS_SYSTEM))\n" - , "#define MK_TUP9(x1,x2,x3,x4,x5,x6,x7,x8,x9) (h$c9(h$ghczmprimZCGHCziTupleziPrimziZLz2cUz2cUz2cUz2cUz2cUz2cUz2cUz2cUZR_con_e,(x1),(x2),(x3),(x4),(x5),(x6),(x7),(x8),(x9),h$currentThread?h$currentThread.ccs:h$CCS_SYSTEM))\n" - , "#define MK_TUP10(x1,x2,x3,x4,x5,x6,x7,x8,x9,x10) (h$c10(h$ghczmprimZCGHCziTupleziPrimziZLz2cUz2cUz2cUz2cUz2cUz2cUz2cUz2cUz2cUZR_con_e,(x1),(x2),(x3),(x4),(x5),(x6),(x7),(x8),(x9),(x10),h$currentThread?h$currentThread.ccs:h$CCS_SYSTEM))\n" - ] - else mconcat - [ "#define MK_TUP2(x1,x2) (h$c2(h$ghczmprimZCGHCziTupleziPrimziZLz2cUZR_con_e,(x1),(x2)))\n" - , "#define MK_TUP3(x1,x2,x3) (h$c3(h$ghczmprimZCGHCziTupleziPrimziZLz2cUz2cUZR_con_e,(x1),(x2),(x3)))\n" - , "#define MK_TUP4(x1,x2,x3,x4) (h$c4(h$ghczmprimZCGHCziTupleziPrimziZLz2cUz2cUz2cUZR_con_e,(x1),(x2),(x3),(x4)))\n" - , "#define MK_TUP5(x1,x2,x3,x4,x5) (h$c5(h$ghczmprimZCGHCziTupleziPrimziZLz2cUz2cUz2cUz2cUZR_con_e,(x1),(x2),(x3),(x4),(x5)))\n" - , "#define MK_TUP6(x1,x2,x3,x4,x5,x6) (h$c6(h$ghczmprimZCGHCziTupleziPrimziZLz2cUz2cUz2cUz2cUz2cUZR_con_e,(x1),(x2),(x3),(x4),(x5),(x6)))\n" - , "#define MK_TUP7(x1,x2,x3,x4,x5,x6,x7) (h$c7(h$ghczmprimZCGHCziTupleziPrimziZLz2cUz2cUz2cUz2cUz2cUz2cUZR_con_e,(x1),(x2),(x3),(x4),(x5),(x6),(x7)))\n" - , "#define MK_TUP8(x1,x2,x3,x4,x5,x6,x7,x8) (h$c8(h$ghczmprimZCGHCziTupleziPrimziZLz2cUz2cUz2cUz2cUz2cUz2cUz2cUZR_con_e,(x1),(x2),(x3),(x4),(x5),(x6),(x7),(x8)))\n" - , "#define MK_TUP9(x1,x2,x3,x4,x5,x6,x7,x8,x9) (h$c9(h$ghczmprimZCGHCziTupleziPrimziZLz2cUz2cUz2cUz2cUz2cUz2cUz2cUz2cUZR_con_e,(x1),(x2),(x3),(x4),(x5),(x6),(x7),(x8),(x9)))\n" - , "#define MK_TUP10(x1,x2,x3,x4,x5,x6,x7,x8,x9,x10) (h$c10(h$ghczmprimZCGHCziTupleziPrimziZLz2cUz2cUz2cUz2cUz2cUz2cUz2cUz2cUz2cUZR_con_e,(x1),(x2),(x3),(x4),(x5),(x6),(x7),(x8),(x9),(x10)))\n" - ] + , mconcat (map (genMkTup profiling) [2..10]) , "#define TUP2_1(x) ((x).d1)\n" , "#define TUP2_2(x) ((x).d2)\n" -- 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 @@ -190,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" @@ -246,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" @@ -276,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 = reverse . dropWhile isSpace . reverse . 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.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,23 +61,44 @@ 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 {} -> return [ null_ ] + LitRubbish _ rr_ty -> + -- Generate appropriate rubbish literals, otherwise it might trip up the + -- code generator when a primop is applied to a rubbish literal (see #24664) + let reps = runtimeRepPrimRep (text "GHC.StgToJS.Literal.genLit") rr_ty + rub = \case + BoxedRep _ -> [ null_ ] + AddrRep -> [ null_, ValExpr (JInt 0) ] + WordRep -> [ ValExpr (JInt 0) ] + Word8Rep -> [ ValExpr (JInt 0) ] + Word16Rep -> [ ValExpr (JInt 0) ] + Word32Rep -> [ ValExpr (JInt 0) ] + Word64Rep -> [ ValExpr (JInt 0), ValExpr (JInt 0) ] + IntRep -> [ ValExpr (JInt 0) ] + Int8Rep -> [ ValExpr (JInt 0) ] + Int16Rep -> [ ValExpr (JInt 0) ] + Int32Rep -> [ ValExpr (JInt 0) ] + Int64Rep -> [ ValExpr (JInt 0), ValExpr (JInt 0) ] + DoubleRep -> [ ValExpr (JInt 0) ] + FloatRep -> [ ValExpr (JInt 0) ] + VecRep _ _ -> panic "GHC.StgToJS.Literal.genLit: VecRep unsupported" + in return (concatMap rub reps) -- | generate a literal for the static init tables 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 ] @@ -91,14 +114,12 @@ 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] - LiftedRep -> pure [ NullLit ] - UnliftedRep -> pure [ NullLit ] - VoidRep -> pure [ ] + in case expectOnly prim_reps of -- Note [Post-unarisation invariants] + BoxedRep _ -> pure [ NullLit ] AddrRep -> pure [ NullLit, IntLit 0 ] IntRep -> pure [ IntLit 0 ] Int8Rep -> pure [ IntLit 0 ] @@ -115,7 +136,7 @@ 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,12 +24,14 @@ import GHC.Prelude -import GHC.JS.Syntax +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 @@ -43,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 @@ -68,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 @@ -78,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} @@ -137,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 @@ -151,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 :: 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 @@ -177,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,40 +23,40 @@ -- 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 , readObject - , getObjectUnits - , readObjectUnits - , readObjectDeps - , isGlobalUnit - , isJsObjectFile + , getObjectBlocks + , readObjectBlocks + , readObjectBlockInfo + , isGlobalBlock , Object(..) , IndexEntry(..) - , Deps (..), BlockDeps (..), DepsLocation (..) + , LocatedBlockInfo (..) + , BlockInfo (..) + , BlockDeps (..) + , BlockLocation (..) + , BlockId + , BlockIds + , BlockRef (..) , ExportedFun (..) ) where @@ -63,21 +66,24 @@ 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.Syntax +import GHC.JS.Ident +import qualified GHC.JS.Syntax as Sat import GHC.StgToJS.Types import GHC.Unit.Module @@ -85,74 +91,153 @@ import GHC.Data.FastString import GHC.Types.Unique.Map -import GHC.Float (castDoubleToWord64, castWord64ToDouble) 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 - -- ^ BinHandle that can be used to read the ObjUnits - , objPayloadOffset :: !(Bin ObjUnit) + , objHandle :: !ReadBinHandle + -- ^ BinHandle that can be used to read the ObjBlocks + , objPayloadOffset :: !(Bin ObjBlock) -- ^ Offset of the payload (units) - , objDeps :: !Deps - -- ^ Dependencies + , objBlockInfo :: !BlockInfo + -- ^ Information about blocks , objIndex :: !Index - -- ^ The Index, serialed unit indices and their linkable units + -- ^ Block index: symbols per block and block offset in the object file } type BlockId = Int type BlockIds = IntSet --- | dependencies for a single module -data Deps = Deps - { depsModule :: !Module - -- ^ module - , depsRequired :: !BlockIds +-- | Information about blocks (linkable units) +data BlockInfo = BlockInfo + { bi_module :: !Module + -- ^ Module they were generated from + , bi_must_link :: !BlockIds -- ^ blocks that always need to be linked when this object is loaded (e.g. -- everything that contains initializer code or foreign exports) - , depsHaskellExported :: !(Map ExportedFun BlockId) + , bi_exports :: !(Map ExportedFun BlockId) -- ^ exported Haskell functions -> block - , depsBlocks :: !(Array BlockId BlockDeps) - -- ^ info about each block + , bi_block_deps :: !(Array BlockId BlockDeps) + -- ^ dependencies of each block } -instance Outputable Deps where +data LocatedBlockInfo = LocatedBlockInfo + { lbi_loc :: !BlockLocation -- ^ Where to find the blocks + , lbi_info :: !BlockInfo -- ^ Block information + } + +instance Outputable BlockInfo where ppr d = vcat - [ hcat [ text "module: ", pprModule (depsModule d) ] - , hcat [ text "exports: ", ppr (M.keys (depsHaskellExported d)) ] + [ hcat [ text "module: ", pprModule (bi_module d) ] + , hcat [ text "exports: ", ppr (M.keys (bi_exports d)) ] ] --- | Where are the dependencies -data DepsLocation +-- | Where are the blocks +data BlockLocation = ObjectFile FilePath -- ^ In an object file at path | ArchiveFile FilePath -- ^ In a Ar file at path | InMemory String Object -- ^ In memory -instance Outputable DepsLocation where +instance Outputable BlockLocation where ppr = \case ObjectFile fp -> hsep [text "ObjectFile", text fp] ArchiveFile fp -> hsep [text "ArchiveFile", text fp] InMemory s o -> hsep [text "InMemory", text s, ppr (objModuleName o)] +-- | A @BlockRef@ is a pair of a module and the index of the block in the +-- object file +data BlockRef = BlockRef + { block_ref_mod :: !Module -- ^ Module + , block_ref_idx :: !BlockId -- ^ Block index in the object file + } + deriving (Eq,Ord) + data BlockDeps = BlockDeps - { blockBlockDeps :: [Int] -- ^ dependencies on blocks in this object + { blockBlockDeps :: [BlockId] -- ^ dependencies on blocks in this object , blockFunDeps :: [ExportedFun] -- ^ dependencies on exported symbols in other objects -- , blockForeignExported :: [ExpFun] -- , blockForeignImported :: [ForeignRef] } -{- | we use the convention that the first unit (0) is a module-global - unit that's always included when something from the module - is loaded. everything in a module implicitly depends on the - global block. the global unit itself can't have dependencies - -} -isGlobalUnit :: Int -> Bool -isGlobalUnit n = n == 0 +-- | we use the convention that the first block (0) is a module-global block +-- that's always included when something from the module is loaded. everything +-- in a module implicitly depends on the global block. The global block itself +-- can't have dependencies +isGlobalBlock :: BlockId -> Bool +isGlobalBlock n = n == 0 -- | Exported Functions data ExportedFun = ExportedFun @@ -166,28 +251,28 @@ , hcat [ text "symbol: ", ppr f ] ] --- | Write an ObjUnit, except for the top level symbols which are stored in the +-- | Write an ObjBlock, except for the top level symbols which are stored in the -- index -putObjUnit :: BinHandle -> ObjUnit -> IO () -putObjUnit bh (ObjUnit _syms b c d e f g) = do - put_ bh b - put_ bh c +putObjBlock :: WriteBinHandle -> ObjBlock -> IO () +putObjBlock bh (ObjBlock _syms b c d e f g) = do + 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 ObjUnit and associate it to the given symbols (that must have been +-- | Read an ObjBlock and associate it to the given symbols (that must have been -- read from the index) -getObjUnit :: [FastString] -> BinHandle -> IO ObjUnit -getObjUnit syms bh = do - b <- get bh - c <- get bh +getObjBlock :: [FastString] -> ReadBinHandle -> IO ObjBlock +getObjBlock syms bh = do + b <- lazyGet bh + c <- lazyGet bh d <- lazyGet bh - e <- get bh - f <- get bh - g <- get bh - pure $ ObjUnit + e <- lazyGet bh + f <- lazyGet bh + g <- lazyGet bh + pure $ ObjBlock { oiSymbols = syms , oiClInfo = b , oiStatic = c @@ -198,34 +283,29 @@ } --- | 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 unit indexes and their exported symbols --- (the first unit is module-global) +-- | Serialized block indexes and their exported symbols +-- (the first block is module-global) type Index = [IndexEntry] data IndexEntry = IndexEntry - { idxSymbols :: ![FastString] -- ^ Symbols exported by a unit - , idxOffset :: !(Bin ObjUnit) -- ^ Offset of the unit in the object file + { idxSymbols :: ![FastString] -- ^ Symbols exported by a block + , idxOffset :: !(Bin ObjBlock) -- ^ Offset of the block in the object file } -------------------------------------------------------------------------------- --- 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 - -> Deps -- ^ dependencies - -> [ObjUnit] -- ^ linkable units and their symbols + -> 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 @@ -233,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 - putObjUnit bh_fs o + 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 @@ -288,27 +344,27 @@ 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) - deps <- get bh - idx <- forwardGet bh (get bh) - payload_pos <- tellBin bh + block_info <- get bh + idx <- forwardGet bh (get bh) + payload_pos <- tellBinReader bh pure $ Object { objModuleName = mod_name , objHandle = bh , objPayloadOffset = payload_pos - , objDeps = deps + , objBlockInfo = block_info , objIndex = idx } -- | Parse object -getObject :: BinHandle -> IO (Maybe Object) +getObject :: ReadBinHandle -> IO (Maybe Object) getObject bh = do getObjectHeader bh >>= \case Left _err -> pure Nothing @@ -322,43 +378,43 @@ bh <- readBinMem file getObject bh --- | Reads only the part necessary to get the dependencies -readObjectDeps :: FilePath -> IO (Maybe Deps) -readObjectDeps file = do +-- | Reads only the part necessary to get the block info +readObjectBlockInfo :: FilePath -> IO (Maybe BlockInfo) +readObjectBlockInfo file = do bh <- readBinMem file getObject bh >>= \case - Just obj -> pure $! Just $! objDeps obj + Just obj -> pure $! Just $! objBlockInfo obj Nothing -> pure Nothing --- | Get units in the object file, using the given filtering function -getObjectUnits :: Object -> (Word -> IndexEntry -> Bool) -> IO [ObjUnit] -getObjectUnits obj pred = mapMaybeM read_entry (zip (objIndex obj) [0..]) +-- | Get blocks in the object file, using the given filtering function +getObjectBlocks :: Object -> BlockIds -> IO [ObjBlock] +getObjectBlocks obj bids = mapMaybeM read_entry (zip (objIndex obj) [0..]) where bh = objHandle obj - read_entry (e@(IndexEntry syms offset),i) - | pred i e = do - seekBin bh offset - Just <$> getObjUnit syms bh + read_entry (IndexEntry syms offset,i) + | IS.member i bids = do + seekBinReader bh offset + Just <$> getObjBlock syms bh | otherwise = pure Nothing --- | Read units in the object file, using the given filtering function -readObjectUnits :: FilePath -> (Word -> IndexEntry -> Bool) -> IO [ObjUnit] -readObjectUnits file pred = do +-- | Read blocks in the object file, using the given filtering function +readObjectBlocks :: FilePath -> BlockIds -> IO [ObjBlock] +readObjectBlocks file bids = do readObject file >>= \case Nothing -> pure [] - Just obj -> getObjectUnits obj pred + Just obj -> getObjectBlocks obj bids -------------------------------------------------------------------------------- -- 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 @@ -378,13 +434,13 @@ put_ bh (IndexEntry a b) = put_ bh a >> put_ bh b get bh = IndexEntry <$> get bh <*> get bh -instance Binary Deps where - put_ bh (Deps m r e b) = do +instance Binary BlockInfo where + put_ bh (BlockInfo m r e b) = do put_ bh m put_ bh (map toI32 $ IS.toList r) put_ bh (map (\(x,y) -> (x, toI32 y)) $ M.toList e) put_ bh (elems b) - get bh = Deps <$> get bh + get bh = BlockInfo <$> get bh <*> (IS.fromList . map fromI32 <$> get bh) <*> (M.fromList . map (\(x,y) -> (x, fromI32 y)) <$> get bh) <*> ((\xs -> listArray (0, length xs - 1) xs) <$> get bh) @@ -402,99 +458,88 @@ put_ bh (ExpFun isIO args res) = put_ bh isIO >> put_ bh args >> put_ bh res get bh = ExpFun <$> get bh <*> get bh <*> get bh -instance Binary JStat where - put_ bh (DeclStat i e) = putByte bh 1 >> put_ bh i >> put_ bh e - put_ bh (ReturnStat e) = putByte bh 2 >> put_ bh e - put_ bh (IfStat e s1 s2) = putByte bh 3 >> put_ bh e >> put_ bh s1 >> put_ bh s2 - put_ bh (WhileStat b e s) = putByte bh 4 >> put_ bh b >> put_ bh e >> put_ bh s - put_ bh (ForInStat b i e s) = putByte bh 5 >> put_ bh b >> put_ bh i >> put_ bh e >> put_ bh s - put_ bh (SwitchStat e ss s) = putByte bh 6 >> put_ bh e >> put_ bh ss >> put_ bh s - put_ bh (TryStat s1 i s2 s3) = putByte bh 7 >> put_ bh s1 >> put_ bh i >> put_ bh s2 >> put_ bh s3 - put_ bh (BlockStat xs) = putByte bh 8 >> put_ bh xs - put_ bh (ApplStat e es) = putByte bh 9 >> put_ bh e >> put_ bh es - put_ bh (UOpStat o e) = putByte bh 10 >> put_ bh o >> put_ bh e - put_ bh (AssignStat e1 e2) = putByte bh 11 >> put_ bh e1 >> put_ bh e2 - put_ _ (UnsatBlock {}) = error "put_ bh JStat: UnsatBlock" - put_ bh (LabelStat l s) = putByte bh 12 >> put_ bh l >> put_ bh s - put_ bh (BreakStat ml) = putByte bh 13 >> put_ bh ml - put_ bh (ContinueStat ml) = putByte bh 14 >> put_ bh ml +instance Binary Sat.JStat where + put_ bh (Sat.DeclStat i e) = putByte bh 1 >> put_ bh i >> put_ bh e + put_ bh (Sat.ReturnStat e) = putByte bh 2 >> put_ bh e + put_ bh (Sat.IfStat e s1 s2) = putByte bh 3 >> put_ bh e >> put_ bh s1 >> put_ bh s2 + put_ bh (Sat.WhileStat b e s) = putByte bh 4 >> put_ bh b >> put_ bh e >> put_ bh s + put_ bh (Sat.ForStat is c s bd) = putByte bh 5 >> put_ bh is >> put_ bh c >> put_ bh s >> put_ bh bd + put_ bh (Sat.ForInStat b i e s) = putByte bh 6 >> put_ bh b >> put_ bh i >> put_ bh e >> put_ bh s + put_ bh (Sat.SwitchStat e ss s) = putByte bh 7 >> put_ bh e >> put_ bh ss >> put_ bh s + put_ bh (Sat.TryStat s1 i s2 s3) = putByte bh 8 >> put_ bh s1 >> put_ bh i >> put_ bh s2 >> put_ bh s3 + put_ bh (Sat.BlockStat xs) = putByte bh 9 >> put_ bh xs + put_ bh (Sat.ApplStat e es) = putByte bh 10 >> put_ bh e >> put_ bh es + put_ bh (Sat.UOpStat o e) = putByte bh 11 >> put_ bh o >> put_ bh e + put_ bh (Sat.AssignStat e1 op e2) = putByte bh 12 >> put_ bh e1 >> put_ bh op >> put_ bh e2 + put_ bh (Sat.LabelStat l s) = putByte bh 13 >> put_ bh l >> put_ bh s + put_ bh (Sat.BreakStat ml) = putByte bh 14 >> put_ bh ml + put_ bh (Sat.ContinueStat ml) = putByte bh 15 >> put_ bh ml + put_ bh (Sat.FuncStat i is b) = putByte bh 16 >> put_ bh i >> put_ bh is >> put_ bh b get bh = getByte bh >>= \case - 1 -> DeclStat <$> get bh <*> get bh - 2 -> ReturnStat <$> get bh - 3 -> IfStat <$> get bh <*> get bh <*> get bh - 4 -> WhileStat <$> get bh <*> get bh <*> get bh - 5 -> ForInStat <$> get bh <*> get bh <*> get bh <*> get bh - 6 -> SwitchStat <$> get bh <*> get bh <*> get bh - 7 -> TryStat <$> get bh <*> get bh <*> get bh <*> get bh - 8 -> BlockStat <$> get bh - 9 -> ApplStat <$> get bh <*> get bh - 10 -> UOpStat <$> get bh <*> get bh - 11 -> AssignStat <$> get bh <*> get bh - 12 -> LabelStat <$> get bh <*> get bh - 13 -> BreakStat <$> get bh - 14 -> ContinueStat <$> get bh + 1 -> Sat.DeclStat <$> get bh <*> get bh + 2 -> Sat.ReturnStat <$> get bh + 3 -> Sat.IfStat <$> get bh <*> get bh <*> get bh + 4 -> Sat.WhileStat <$> get bh <*> get bh <*> get bh + 5 -> Sat.ForStat <$> get bh <*> get bh <*> get bh <*> get bh + 6 -> Sat.ForInStat <$> get bh <*> get bh <*> get bh <*> get bh + 7 -> Sat.SwitchStat <$> get bh <*> get bh <*> get bh + 8 -> Sat.TryStat <$> get bh <*> get bh <*> get bh <*> get bh + 9 -> Sat.BlockStat <$> get bh + 10 -> Sat.ApplStat <$> get bh <*> get bh + 11 -> Sat.UOpStat <$> get bh <*> get bh + 12 -> Sat.AssignStat <$> get bh <*> get bh <*> get bh + 13 -> Sat.LabelStat <$> get bh <*> get bh + 14 -> Sat.BreakStat <$> get bh + 15 -> Sat.ContinueStat <$> get bh + 16 -> Sat.FuncStat <$> get bh <*> get bh <*> get bh n -> error ("Binary get bh JStat: invalid tag: " ++ show n) -instance Binary JExpr where - put_ bh (ValExpr v) = putByte bh 1 >> put_ bh v - put_ bh (SelExpr e i) = putByte bh 2 >> put_ bh e >> put_ bh i - put_ bh (IdxExpr e1 e2) = putByte bh 3 >> put_ bh e1 >> put_ bh e2 - put_ bh (InfixExpr o e1 e2) = putByte bh 4 >> put_ bh o >> put_ bh e1 >> put_ bh e2 - put_ bh (UOpExpr o e) = putByte bh 5 >> put_ bh o >> put_ bh e - put_ bh (IfExpr e1 e2 e3) = putByte bh 6 >> put_ bh e1 >> put_ bh e2 >> put_ bh e3 - put_ bh (ApplExpr e es) = putByte bh 7 >> put_ bh e >> put_ bh es - put_ _ (UnsatExpr {}) = error "put_ bh JExpr: UnsatExpr" - get bh = getByte bh >>= \case - 1 -> ValExpr <$> get bh - 2 -> SelExpr <$> get bh <*> get bh - 3 -> IdxExpr <$> get bh <*> get bh - 4 -> InfixExpr <$> get bh <*> get bh <*> get bh - 5 -> UOpExpr <$> get bh <*> get bh - 6 -> IfExpr <$> get bh <*> get bh <*> get bh - 7 -> ApplExpr <$> get bh <*> get bh - n -> error ("Binary get bh JExpr: invalid tag: " ++ show n) -instance Binary JVal where - put_ bh (JVar i) = putByte bh 1 >> put_ bh i - put_ bh (JList es) = putByte bh 2 >> put_ bh es - put_ bh (JDouble d) = putByte bh 3 >> put_ bh d - put_ bh (JInt i) = putByte bh 4 >> put_ bh i - put_ bh (JStr xs) = putByte bh 5 >> put_ bh xs - put_ bh (JRegEx xs) = putByte bh 6 >> put_ bh xs - put_ bh (JHash m) = putByte bh 7 >> put_ bh (sortOn (LexicalFastString . fst) $ nonDetEltsUniqMap m) - put_ bh (JFunc is s) = putByte bh 8 >> put_ bh is >> put_ bh s - put_ _ (UnsatVal {}) = error "put_ bh JVal: UnsatVal" +instance Binary Sat.JExpr where + put_ bh (Sat.ValExpr v) = putByte bh 1 >> put_ bh v + put_ bh (Sat.SelExpr e i) = putByte bh 2 >> put_ bh e >> put_ bh i + put_ bh (Sat.IdxExpr e1 e2) = putByte bh 3 >> put_ bh e1 >> put_ bh e2 + put_ bh (Sat.InfixExpr o e1 e2) = putByte bh 4 >> put_ bh o >> put_ bh e1 >> put_ bh e2 + put_ bh (Sat.UOpExpr o e) = putByte bh 5 >> put_ bh o >> put_ bh e + put_ bh (Sat.IfExpr e1 e2 e3) = putByte bh 6 >> put_ bh e1 >> put_ bh e2 >> put_ bh e3 + put_ bh (Sat.ApplExpr e es) = putByte bh 7 >> put_ bh e >> put_ bh es get bh = getByte bh >>= \case - 1 -> JVar <$> get bh - 2 -> JList <$> get bh - 3 -> JDouble <$> get bh - 4 -> JInt <$> get bh - 5 -> JStr <$> get bh - 6 -> JRegEx <$> get bh - 7 -> JHash . listToUniqMap <$> get bh - 8 -> JFunc <$> get bh <*> get bh - n -> error ("Binary get bh JVal: invalid tag: " ++ show n) + 1 -> Sat.ValExpr <$> get bh + 2 -> Sat.SelExpr <$> get bh <*> get bh + 3 -> Sat.IdxExpr <$> get bh <*> get bh + 4 -> Sat.InfixExpr <$> get bh <*> get bh <*> get bh + 5 -> Sat.UOpExpr <$> get bh <*> get bh + 6 -> Sat.IfExpr <$> get bh <*> get bh <*> get bh + 7 -> Sat.ApplExpr <$> get bh <*> get bh + n -> error ("Binary get bh UnsatExpr: invalid tag: " ++ show n) -instance Binary Ident where - put_ bh (TxtI xs) = put_ bh xs - get bh = TxtI <$> get bh --- we need to preserve NaN and infinities, unfortunately the Binary instance for Double does not do this -instance Binary SaneDouble where - put_ bh (SaneDouble d) - | isNaN d = putByte bh 1 - | isInfinite d && d > 0 = putByte bh 2 - | isInfinite d && d < 0 = putByte bh 3 - | isNegativeZero d = putByte bh 4 - | otherwise = putByte bh 5 >> put_ bh (castDoubleToWord64 d) +instance Binary Sat.JVal where + put_ bh (Sat.JVar i) = putByte bh 1 >> put_ bh i + put_ bh (Sat.JList es) = putByte bh 2 >> put_ bh es + put_ bh (Sat.JDouble d) = putByte bh 3 >> put_ bh d + 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.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 -> pure $ SaneDouble (0 / 0) - 2 -> pure $ SaneDouble (1 / 0) - 3 -> pure $ SaneDouble ((-1) / 0) - 4 -> pure $ SaneDouble (-0) - 5 -> SaneDouble . castWord64ToDouble <$> get bh - n -> error ("Binary get bh SaneDouble: invalid tag: " ++ show n) + 1 -> Sat.JVar <$> get bh + 2 -> Sat.JList <$> get bh + 3 -> Sat.JDouble <$> get bh + 4 -> Sat.JInt <$> get bh + 5 -> Sat.JStr <$> get bh + 6 -> Sat.JRegEx <$> 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 (identFS -> xs) = put_ bh xs + get bh = name <$> get bh + instance Binary ClosureInfo where put_ bh (ClosureInfo v regs name layo typ static) = do put_ bh v >> put_ bh regs >> put_ bh name >> put_ bh layo >> put_ bh typ >> put_ bh static @@ -504,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 @@ -516,14 +561,18 @@ 2 -> CIRegs <$> get bh <*> get bh n -> error ("Binary get bh CIRegs: invalid tag: " ++ show n) -instance Binary JOp where +instance Binary Sat.Op where put_ bh = putEnum bh get bh = getEnum bh -instance Binary JUOp where +instance Binary Sat.UOp where put_ bh = putEnum bh get bh = getEnum bh +instance Binary Sat.AOp where + put_ bh = putEnum bh + get bh = getEnum bh + -- 16 bit sizes should be enough... instance Binary CILayout where put_ bh CILayoutVariable = putByte bh 1 @@ -566,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) @@ -620,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,1568 +13,1685 @@ import GHC.Prelude -import GHC.JS.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 ---------------------------------------------- - - 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 "h$mulInt32" [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 |= app "h$mulWord32" [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] - ------------------------------- 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] - ------------------------------- 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 - 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 - - 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 - ] - - 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] - - 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/Printer.hs b/GHC/StgToJS/Printer.hs deleted file mode 100644 --- a/GHC/StgToJS/Printer.hs +++ /dev/null @@ -1,218 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MagicHash #-} - ------------------------------------------------------------------------------ --- | --- Module : GHC.StgToJS.Printer --- Copyright : (c) The University of Glasgow 2001 --- License : BSD-style (see the file LICENSE) --- --- Maintainer : Jeffrey Young --- Luite Stegeman --- Sylvain Henry --- Stability : experimental --- --- Custom prettyprinter for JS AST uses the JS PPr module for most of --- the work --- --- ------------------------------------------------------------------------------ -module GHC.StgToJS.Printer - ( pretty - , ghcjsRenderJs - , prettyBlock - ) -where - -import GHC.Prelude -import GHC.Int -import GHC.Exts - -import GHC.JS.Syntax -import GHC.JS.Ppr - -import GHC.Utils.Ppr as PP -import GHC.Data.FastString -import GHC.Types.Unique.Map - -import Data.List (sortOn) -import Data.Char (isAlpha,isDigit,ord) -import qualified Data.ByteString.Short as SBS - -pretty :: JStat -> Doc -pretty = jsToDocR ghcjsRenderJs - -ghcjsRenderJs :: RenderJs -ghcjsRenderJs = defaultRenderJs - { renderJsV = ghcjsRenderJsV - , renderJsS = ghcjsRenderJsS - , renderJsI = ghcjsRenderJsI - } - -hdd :: SBS.ShortByteString -hdd = SBS.pack (map (fromIntegral . ord) "h$$") - -ghcjsRenderJsI :: RenderJs -> Ident -> Doc -ghcjsRenderJsI _ (TxtI 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. - -- - -- These symbols are usually very large because their name includes the - -- unit-id, the module name, and some unique number. So we rename these - -- symbols with a much shorter globally unique number. - -- - -- Here we reuse their FastString unique for this purpose! Note that it only - -- works if we pretty-print all the JS code linked together at once, which we - -- currently do. GHCJS used to maintain a CompactorState to support - -- incremental linking: it contained the mapping between original symbols and - -- their renaming. - | hdd `SBS.isPrefixOf` fastStringToShortByteString fs - , u <- uniqueOfFS fs - = text "h$$" <> hexDoc (fromIntegral u) - | otherwise - = ftext fs - --- | Render as an hexadecimal number in reversed order (because it's faster and we --- don't care about the actual value). -hexDoc :: Word -> Doc -hexDoc 0 = char '0' -hexDoc v = text $ go v - where - sym (I# i) = C# (indexCharOffAddr# chars i) - chars = "0123456789abcdef"# - go = \case - 0 -> [] - n -> sym (fromIntegral (n .&. 0x0F)) - : sym (fromIntegral ((n .&. 0xF0) `shiftR` 4)) - : go (n `shiftR` 8) - - - - --- attempt to resugar some of the common constructs -ghcjsRenderJsS :: RenderJs -> JStat -> Doc -ghcjsRenderJsS r (BlockStat xs) = prettyBlock r (flattenBlocks xs) -ghcjsRenderJsS r s = renderJsS defaultRenderJs r s - --- don't quote keys in our object literals, so closure compiler works -ghcjsRenderJsV :: RenderJs -> JVal -> Doc -ghcjsRenderJsV r (JHash m) - | isNullUniqMap m = text "{}" - | otherwise = braceNest . PP.fsep . punctuate comma . - map (\(x,y) -> quoteIfRequired x <> PP.colon <+> jsToDocR r y) - -- nonDetEltsUniqMap doesn't introduce non-determinism here because - -- we sort the elements lexically - . sortOn (LexicalFastString . fst) $ nonDetEltsUniqMap m - where - quoteIfRequired :: FastString -> Doc - quoteIfRequired x - | isUnquotedKey x' = text x' - | otherwise = PP.squotes (text x') - where x' = unpackFS x - - isUnquotedKey :: String -> Bool - isUnquotedKey x | null x = False - | all isDigit x = True - | otherwise = validFirstIdent (head x) - && all validOtherIdent (tail x) - - - validFirstIdent c = c == '_' || c == '$' || isAlpha c - validOtherIdent c = isAlpha c || isDigit c -ghcjsRenderJsV r v = renderJsV defaultRenderJs r v - -prettyBlock :: RenderJs -> [JStat] -> Doc -prettyBlock r xs = vcat $ map addSemi (prettyBlock' r xs) - --- recognize common patterns in a block and convert them to more idiomatic/concise javascript -prettyBlock' :: RenderJs -> [JStat] -> [Doc] --- return/... -prettyBlock' r ( x@(ReturnStat _) - : xs - ) - | not (null xs) - = prettyBlock' r [x] --- declare/assign -prettyBlock' r ( (DeclStat i Nothing) - : (AssignStat (ValExpr (JVar i')) v) - : xs - ) - | i == i' - = prettyBlock' r (DeclStat i (Just v) : xs) - --- resugar for loops with/without var declaration -prettyBlock' r ( (DeclStat i (Just v0)) - : (WhileStat False p (BlockStat bs)) - : xs - ) - | not (null flat) && isForUpdStat (last flat) - = mkFor r True i v0 p (last flat) (init flat) : prettyBlock' r xs - where - flat = flattenBlocks bs -prettyBlock' r ( (AssignStat (ValExpr (JVar i)) v0) - : (WhileStat False p (BlockStat bs)) - : xs - ) - | not (null flat) && isForUpdStat (last flat) - = mkFor r False i v0 p (last flat) (init flat) : prettyBlock' r xs - where - flat = flattenBlocks bs - --- global function (does not preserve semantics but works for GHCJS) -prettyBlock' r ( (DeclStat i (Just (ValExpr (JFunc is b)))) - : xs - ) - = (hangBrace (text "function" <+> jsToDocR r i <> parens (fsep . punctuate comma . map (jsToDocR r) $ is)) - (jsToDocR r b) - ) : prettyBlock' r xs --- modify/assign operators -prettyBlock' r ( (AssignStat (ValExpr (JVar i)) (InfixExpr AddOp (ValExpr (JVar i')) (ValExpr (JInt 1)))) - : xs - ) - | i == i' = (text "++" <> jsToDocR r i) : prettyBlock' r xs -prettyBlock' r ( (AssignStat (ValExpr (JVar i)) (InfixExpr SubOp (ValExpr (JVar i')) (ValExpr (JInt 1)))) - : xs - ) - | i == i' = (text "--" <> jsToDocR r i) : prettyBlock' r xs -prettyBlock' r ( (AssignStat (ValExpr (JVar i)) (InfixExpr AddOp (ValExpr (JVar i')) e)) - : xs - ) - | i == i' = (jsToDocR r i <+> text "+=" <+> jsToDocR r e) : prettyBlock' r xs -prettyBlock' r ( (AssignStat (ValExpr (JVar i)) (InfixExpr SubOp (ValExpr (JVar i')) e)) - : xs - ) - | i == i' = (jsToDocR r i <+> text "-=" <+> jsToDocR r e) : prettyBlock' r xs - - -prettyBlock' r (x:xs) = jsToDocR r x : prettyBlock' r xs -prettyBlock' _ [] = [] - --- build the for block -mkFor :: RenderJs -> Bool -> Ident -> JExpr -> JExpr -> JStat -> [JStat] -> Doc -mkFor r decl i v0 p s1 sb = hangBrace (text "for" <> forCond) - (jsToDocR r $ BlockStat sb) - where - c0 | decl = text "var" <+> jsToDocR r i <+> char '=' <+> jsToDocR r v0 - | otherwise = jsToDocR r i <+> char '=' <+> jsToDocR r v0 - forCond = parens $ hcat $ interSemi - [ c0 - , jsToDocR r p - , parens (jsToDocR r s1) - ] - --- check if a statement is suitable to be converted to something in the for(;;x) position -isForUpdStat :: JStat -> Bool -isForUpdStat UOpStat {} = True -isForUpdStat AssignStat {} = True -isForUpdStat ApplStat {} = True -isForUpdStat _ = False - -interSemi :: [Doc] -> [Doc] -interSemi [] = [PP.empty] -interSemi [s] = [s] -interSemi (x:xs) = x <> text ";" : interSemi xs - -addSemi :: Doc -> Doc -addSemi x = x <> text ";" 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 @@ -27,12 +28,15 @@ import GHC.Prelude import GHC.JS.Syntax +import GHC.JS.JStg.Syntax (JStgExpr) +import qualified GHC.JS.JStg.Syntax as JStg import GHC.JS.Make +import GHC.JS.Ident +import GHC.StgToJS.Monad import GHC.StgToJS.Regs -import GHC.StgToJS.Types import GHC.StgToJS.Symbols -import GHC.StgToJS.Monad +import GHC.StgToJS.Types import GHC.Types.CostCentre @@ -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.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 @@ -1,661 +1,680 @@ {-# LANGUAGE OverloadedStrings #-} - -{-# OPTIONS_GHC -O0 #-} - ------------------------------------------------------------------------------ --- | --- Module : GHC.StgToJS.Rts.Rts --- 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 --- --- Top level driver of the JavaScript Backend RTS. This file is an --- implementation of the JS RTS for the JS backend written as an EDSL in --- Haskell. It assumes the existence of pre-generated JS functions, included as --- js-sources in base. These functions are similarly assumed for non-inline --- Primops, See 'GHC.StgToJS.Prim'. Most of the elements in this module are --- constants in Haskell Land which define pieces of the JS RTS. --- ------------------------------------------------------------------------------ - -module GHC.StgToJS.Rts.Rts where - -import GHC.Prelude - -import GHC.JS.Syntax -import GHC.JS.Make -import GHC.JS.Transform - -import GHC.StgToJS.Apply -import GHC.StgToJS.Closure -import GHC.StgToJS.Heap -import GHC.StgToJS.Printer -import GHC.StgToJS.Profiling -import GHC.StgToJS.Regs -import GHC.StgToJS.Types -import GHC.StgToJS.Stack - -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 [ TxtI "h$resetRegisters" ||= jLam (mconcat $ map resetRegister [minBound..maxBound]) - , TxtI "h$resetResultVars" ||= jLam (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 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 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 - [ declClsConstr "h$c" ["f"] $ Closure - { clEntry = var "f" - , clField1 = null_ - , clField2 = null_ - , clMeta = 0 - , clCC = ccVal - } - , declClsConstr "h$c0" ["f"] $ Closure - { clEntry = var "f" - , clField1 = null_ - , clField2 = null_ - , clMeta = 0 - , clCC = ccVal - } - , declClsConstr "h$c1" ["f", "x1"] $ Closure - { clEntry = var "f" - , clField1 = var "x1" - , clField2 = null_ - , clMeta = 0 - , clCC = ccVal - } - , declClsConstr "h$c2" ["f", "x1", "x2"] $ Closure - { clEntry = var "f" - , clField1 = var "x1" - , clField2 = var "x2" - , clMeta = 0 - , clCC = ccVal - } - , mconcat (map mkClosureCon [3..24]) - , mconcat (map mkDataFill [1..24]) - ] - where - prof = csProf s - (ccArg,ccVal) - -- the cc argument happens to be named just like the cc field... - | prof = ([TxtI closureCC_], Just (var closureCC_)) - | otherwise = ([], Nothing) - addCCArg as = map TxtI as ++ ccArg - addCCArg' as = as ++ ccArg - - declClsConstr i as cl = TxtI i ||= ValExpr (JFunc (addCCArg as) - ( jVar $ \x -> - [ checkC - , x |= newClosure cl - , notifyAlloc x - , traceAlloc x - , returnS x - ] - )) - - traceAlloc x | csTraceRts s = appS "h$traceAlloc" [x] - | otherwise = mempty - - notifyAlloc x | csDebugAlloc s = appS "h$debugAlloc_notifyAlloc" [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 | 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 - - -- 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 -> - mconcat [ msg |= jString "warning: undefined or null in argument: " + i + jString " allocating fields" - , jwhenS (var "console" .&&. (var "console" .^ "trace")) - ((var "console" .^ "trace") `ApplStat` [msg]) - ])) - - | otherwise = mempty - - mkClosureCon :: Int -> JStat - mkClosureCon n = funName ||= toJExpr fun - where - funName = TxtI $ mkFastString ("h$c" ++ show n) - -- args are: f x1 x2 .. xn [cc] - args = TxtI "f" : addCCArg' (map (TxtI . mkFastString . ('x':) . show) [(1::Int)..n]) - fun = JFunc args funBod - -- x1 goes into closureField1. All the other args are bundled into an - -- object in closureField2: { d1 = x2, d2 = x3, ... } - -- - extra_args = ValExpr . JHash . listToUniqMap $ zip - (map (mkFastString . ('d':) . show) [(1::Int)..]) - (map (toJExpr . TxtI . mkFastString . ('x':) . show) [2..n]) - - funBod = jVar $ \x -> - [ checkC - , x |= newClosure Closure - { clEntry = var "f" - , clField1 = var "x1" - , clField2 = extra_args - , clMeta = 0 - , clCC = ccVal - } - , notifyAlloc x - , traceAlloc x - , returnS x - ] - - mkDataFill :: Int -> JStat - mkDataFill n = funName ||= toJExpr fun - where - funName = TxtI $ mkFastString ("h$d" ++ show n) - ds = map (mkFastString . ('d':) . show) [(1::Int)..n] - extra_args = ValExpr . JHash . listToUniqMap . zip ds $ map (toJExpr . TxtI) ds - fun = JFunc (map TxtI ds) (checkD <> returnS extra_args) - --- | JS Payload to perform stack manipulation in the RTS -stackManip :: JStat -stackManip = mconcat (map mkPush [1..32]) <> - mconcat (map mkPpush [1..255]) - where - mkPush :: Int -> JStat - mkPush n = let funName = TxtI $ mkFastString ("h$p" ++ show n) - as = map (TxtI . mkFastString . ('x':) . show) [1..n] - fun = JFunc as ((sp |= sp + toJExpr n) - <> mconcat (zipWith (\i a -> stack .! (sp - toJExpr (n-i)) |= toJExpr a) - [1..] as)) - in funName ||= toJExpr fun - - -- 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) - bits = bitsIdx sig - n = length bits - h = last bits - args = map (TxtI . mkFastString . ('x':) . show) [1..n] - fun = JFunc args $ - mconcat [ sp |= sp + toJExpr (h+1) - , mconcat (zipWith (\b a -> stack .! (sp - toJExpr (h-b)) |= toJExpr a) bits args) - ] - in funName ||= toJExpr fun - -bitsIdx :: Integer -> [Int] -bitsIdx n | n < 0 = error "bitsIdx: negative" - | otherwise = go n 0 - where - go 0 _ = [] - 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_) - ] - - --- | JS payload to declare the registers -declRegs :: JStat -declRegs = - mconcat [ TxtI "h$regs" ||= toJExpr (JList []) - , mconcat (map declReg (enumFromTo R1 R32)) - , regGettersSetters - , loadRegs - ] - where - declReg r = (decl . TxtI . mkFastString . ("h$"++) . map toLower . show) r - <> BlockStat [AssignStat (toJExpr r) (ValExpr (JInt 0))] -- [j| `r` = 0; |] - --- | JS payload to define getters and setters on the registers. -regGettersSetters :: JStat -regGettersSetters = - mconcat [ TxtI "h$getReg" ||= jLam (\n -> SwitchStat n getRegCases mempty) - , TxtI "h$setReg" ||= jLam (\n v -> SwitchStat n (setRegCases v) mempty) - ] - where - getRegCases = - map (\r -> (toJExpr (jsRegToInt r) , returnS (toJExpr r))) regsFromR1 - 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] - where - mkLoad :: Int -> JStat - mkLoad n = let args = map (TxtI . mkFastString . ("x"++) . show) [1..n] - assign = zipWith (\a r -> toJExpr r |= toJExpr a) - args (reverse $ take n regsFromR1) - fname = TxtI $ mkFastString ("h$l" ++ show n) - fun = JFunc args (mconcat assign) - in fname ||= toJExpr fun - --- | Assign registers R1 ... Rn in descending order, that is assign Rn first. --- This function uses the 'assignRegs'' 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: --- @ --- function h$l4(x1, x2, x3, x4) { --- h$r4 = x1; --- h$r3 = x2; --- h$r2 = x3; --- h$r1 = x4; --- }; --- @ -assignRegs' :: Array Int Ident -assignRegs' = listArray (1,32) (map (TxtI . mkFastString . ("h$l"++) . show) [(1::Int)..32]) - --- | JS payload to declare return variables. -declRets :: JStat -declRets = mconcat $ map (decl . TxtI . mkFastString . ("h$"++) . map toLower . show) (enumFrom Ret1) - --- | JS payload defining the types closures. -closureTypes :: JStat -closureTypes = mconcat (map mkClosureType (enumFromTo minBound maxBound)) <> closureTypeName - where - mkClosureType :: ClosureType -> JStat - mkClosureType c = let s = TxtI . mkFastString $ "h$" ++ map toUpper (show c) ++ "_CLOSURE" - in s ||= toJExpr c - closureTypeName :: JStat - closureTypeName = - TxtI "h$closureTypeName" ||= jLam (\c -> - mconcat (map (ifCT c) [minBound..maxBound]) - <> returnS (jString "InvalidClosureType")) - - ifCT :: JExpr -> ClosureType -> JStat - ifCT arg ct = jwhenS (arg .===. toJExpr ct) (returnS (toJExpr (show ct))) - --- | JS payload declaring the RTS functions. -rtsDecls :: JStat -rtsDecls = jsSaturate (Just "h$RTSD") $ - 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] - --- | print the embedded RTS to a String -rtsText :: StgToJSConfig -> String -rtsText = show . pretty . rts - --- | print the RTS declarations to a String. -rtsDeclsText :: String -rtsDeclsText = show . pretty $ rtsDecls - --- | Wrapper over the RTS to guarentee saturation, see 'GHC.JS.Transform' -rts :: StgToJSConfig -> JStat -rts = jsSaturate (Just "h$RTS") . 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_rtsobj" ||= toJExpr RtsObjV - , TxtI "h$vt_obj" ||= toJExpr ObjV - , TxtI "h$vt_arr" ||= toJExpr ArrV - , TxtI "h$bh" ||= jLam (bhStats s True) - , TxtI "h$bh_lne" ||= jLam (\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 -> - 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_ - , r1 |= t - , returnS (app "h$ap_0_0_fast" []) - ] - ) - , 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" []) - ] - , closure (ClosureInfo (TxtI "h$keepAlive_e") (CIRegs 0 [PtrV]) "keepAlive" (CILayoutFixed 1 [PtrV]) CIStackFrame mempty) - (mconcat [ adjSpN' 2 - , 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")) - (returnS (stack .! sp))) - , closure (ClosureInfo (TxtI "h$maskFrame") (CIRegs 0 [PtrV]) "mask" (CILayoutFixed 0 []) CIStackFrame mempty) - ((var "h$currentThread" .^ "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) - <> 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 (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))) - ] +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE BlockArguments #-} + +----------------------------------------------------------------------------- +-- | +-- Module : GHC.StgToJS.Rts.Rts +-- 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 +-- +-- Top level driver of the JavaScript Backend RTS. This file is an +-- implementation of the JS RTS for the JS backend written as an EDSL in +-- Haskell. It assumes the existence of pre-generated JS functions, included as +-- js-sources in base. These functions are similarly assumed for non-inline +-- Primops, See 'GHC.StgToJS.Prim'. Most of the elements in this module are +-- constants in Haskell Land which define pieces of the JS RTS. +-- +----------------------------------------------------------------------------- + +module GHC.StgToJS.Rts.Rts + ( rts + , assignRegs + ) +where + +import GHC.Prelude + +import GHC.JS.JStg.Syntax +import GHC.JS.JStg.Monad +import GHC.JS.Make +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.Stack +import GHC.StgToJS.Symbols +import GHC.StgToJS.Types + +import GHC.Types.Unique.Map + +import Data.Array +import Data.Monoid +import qualified Data.Bits as Bits + +-- | The garbageCollector resets registers and result variables. +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 -> 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 -> JStgStat +resetResultVar r = toJExpr r |= null_ + +-- | 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 = ([Var $ name closureCC_], Just (global closureCC_)) + | otherwise = ([], Nothing) + + addCCArg' as = as ++ ccArg + + traceAlloc x | csTraceRts s = appS hdTraceAlloc [x] + | otherwise = mempty + + 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 :: JSM JStgStat + checkC | csAssertRts s = + jVar $ \msg -> + 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 (.<. 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 (console .&&. (console .^ trace)) + ((console .^ trace) `ApplStat` [msg]) + ])) + + | otherwise = pure mempty + + -- special case handler, the key difference is a call to @jFunction@ instead + -- of @jFunctionSized@ + singleton_closure_con 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 + funName = name $ clsName n + + 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 -> JSM JStgStat + mkDataFill n = jFunctionSized funName n body + where + funName = name $ dataName n + ds = map dataFieldName [1..n] + 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 :: JSM JStgStat +stackManip = do + pushes <- mapM mkPush [1..32] + ppushes <- mapM mkPpush [1..255] + return $ mconcat $ pushes ++ ppushes + where + 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 jFunctionSized funName n body + + -- partial pushes, based on bitmap, increases Sp by highest bit + mkPpush :: Integer -> JSM JStgStat + mkPpush sig | sig Bits..&. (sig+1) == 0 = pure mempty -- already handled by h$p + mkPpush sig = let funName = pushNN ! sig + bits = bitsIdx sig + h = last bits + 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" + | otherwise = go n 0 + where + go 0 _ = [] + 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 -> 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 :: 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 r <> BlockStat [toJExpr r |= zero_] + +-- | JS payload to define getters and setters on the registers. +regGettersSetters :: JSM JStgStat +regGettersSetters = + 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 :: JSM JStgStat +loadRegs = mconcat <$> mapM mkLoad [1..32] + where + mkLoad :: Int -> JSM JStgStat + mkLoad n = let body = \args -> return $ mconcat $ + zipWith (\a r -> toJExpr r |= a) + args (reverse $ take n regsFromR1) + fname = hdLoads ! n + in jFunctionSized fname n body + +-- | Assign registers R1 ... Rn in descending order, that is assign Rn first. +-- This function uses the 'hdLoads' array to construct functions which set +-- the registers. + +-- | JS payload which defines an array of function symbols that set N registers +-- from M parameters. For example, h$l4 compiles to: +-- @ +-- function h$l4(x1, x2, x3, x4) { +-- h$r4 = x1; +-- h$r3 = x2; +-- h$r2 = x3; +-- h$r1 = x4; +-- }; +-- @ +assignRegs :: StgToJSConfig -> [JStgExpr] -> JStgStat +assignRegs _ [] = mempty +assignRegs s xs + | l <= 32 && not (csInlineLoadRegs s) + = ApplStat (ValExpr (JVar $ hdLoads ! l)) (reverse xs) + | otherwise = mconcat . reverse $ + zipWith (\r ex -> toJExpr r |= ex) (take l regsFromR1) xs + where + l = length xs + + +-- | JS payload to declare return variables. +declRets :: JStgStat +declRets = mconcat $ map decl retRegs + +-- | JS payload defining the types closures. +closureTypes :: JSM JStgStat +closureTypes = do + cls_typ_nm <- closureTypeName + return $ + mconcat (map mkClosureType (enumFromTo minBound maxBound)) + <> cls_typ_nm + where + mkClosureType :: ClosureType -> JStgStat + mkClosureType c = let s = closureNames ! c + in s ||= toJExpr c + closureTypeName :: JSM JStgStat + closureTypeName = jFunction hdClosureTypeNameStr + \(MkSolo c) -> return $ + mconcat (map (ifCT c) [minBound..maxBound]) + <> returnS (jString "InvalidClosureType") + + ifCT :: JStgExpr -> ClosureType -> JStgStat + ifCT arg ct = jwhenS (arg .===. toJExpr ct) (returnS (toJExpr (show ct))) + +-- | JS payload declaring the RTS functions. +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 -> 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_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' 2 + , stack .! (sp - 1) |= r1 + , stack .! sp |= hdUpdFrame + , closureInfo r1 |= hdBlackHole + , closureField1 r1 |= hdCurrentThread + , closureField2 r1 |= null_ + , r1 |= t + , returnS (app hdAp00FastStr []) + ] + ) + -- 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 []) + ] + , 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) + ]) + , 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 hdMaskFrameStr (CIRegs 0 [PtrV]) mask (CILayoutFixed 0 []) CIStackFrame mempty) + (return $ + (hdCurrentThread .^ mask |= 2) + <> adjSpN' 1 + <> returnS (stack .! sp)) + , closure (ClosureInfo hdMaskUnintFrameStr (CIRegs 0 [PtrV]) "maskUnint" (CILayoutFixed 0 []) CIStackFrame mempty) + (return $ + (hdCurrentThread .^ mask |= 1) + <> adjSpN' 1 + <> returnS (stack .! sp)) + , 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 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.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.CoreUtils - -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] - | 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 -> Just (StgConApp dc cnum args []) - StgRhsClosure _ _ _ _ e@(StgLit{}) -> 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 -> 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 -> collectArgsE e - StgRhsCon _ccs _con _mu _ticks args -> 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)) = - [ (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.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.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/StgUtils.hs b/GHC/StgToJS/StgUtils.hs deleted file mode 100644 --- a/GHC/StgToJS/StgUtils.hs +++ /dev/null @@ -1,266 +0,0 @@ -{-# LANGUAGE LambdaCase #-} - -module GHC.StgToJS.StgUtils - ( bindingRefs - , hasExport - , collectTopIds - , collectIds - , removeTick - , isUpdatableRhs - , isInlineExpr - , exprRefs - -- * Live vars - , LiveVars - , liveVars - , liveStatic - , stgRhsLive - , stgExprLive - , stgTopBindLive - , stgLetNoEscapeLive - , stgLneLiveExpr - , stgLneLive - , stgLneLive' - ) -where - -import GHC.Prelude - -import GHC.Stg.Syntax -import GHC.Core.DataCon -import GHC.Core.Type -import GHC.Core.TyCon - -import GHC.Types.Unique.FM -import GHC.Types.Unique.Set -import GHC.Types.Unique -import GHC.Types.Id -import GHC.Types.Id.Info -import GHC.Types.ForeignCall -import GHC.Types.TyThing -import GHC.Types.Name -import GHC.Types.Var.Set - -import GHC.Builtin.Names -import GHC.Builtin.PrimOps (PrimOp(SeqOp), primOpIsReallyInline) -import GHC.Utils.Misc (seqList) -import GHC.Utils.Panic - -import qualified Data.Foldable as F -import qualified Data.Set as S -import qualified Data.List as L -import Data.Set (Set) -import Data.Monoid - -s :: a -> Set a -s = S.singleton - -l :: (a -> Set Id) -> [a] -> Set Id -l = F.foldMap - --- | collect Ids that this binding refers to --- (does not include the bindees themselves) --- first argument is Id -> StgExpr map for unfloated arguments -bindingRefs :: UniqFM Id CgStgExpr -> CgStgBinding -> Set Id -bindingRefs u = \case - StgNonRec _ rhs -> rhsRefs u rhs - StgRec bs -> l (rhsRefs u . snd) bs - -rhsRefs :: UniqFM Id CgStgExpr -> CgStgRhs -> Set Id -rhsRefs u = \case - StgRhsClosure _ _ _ _ body -> exprRefs u body - StgRhsCon _ccs d _mu _ticks args -> l s [ i | AnId i <- dataConImplicitTyThings d] <> l (argRefs u) args - -exprRefs :: UniqFM Id CgStgExpr -> CgStgExpr -> Set Id -exprRefs u = \case - StgApp f args -> s f <> l (argRefs u) args - StgConApp d _n args _ -> l s [ i | AnId i <- dataConImplicitTyThings d] <> l (argRefs u) args - StgOpApp _ args _ -> l (argRefs u) args - StgLit {} -> mempty - StgCase expr _ _ alts -> exprRefs u expr <> mconcat (fmap (altRefs u) alts) - StgLet _ bnd expr -> bindingRefs u bnd <> exprRefs u expr - StgLetNoEscape _ bnd expr -> bindingRefs u bnd <> exprRefs u expr - StgTick _ expr -> exprRefs u expr - -altRefs :: UniqFM Id CgStgExpr -> CgStgAlt -> Set Id -altRefs u alt = exprRefs u (alt_rhs alt) - -argRefs :: UniqFM Id CgStgExpr -> StgArg -> Set Id -argRefs u = \case - StgVarArg id - | Just e <- lookupUFM u id -> exprRefs u e - | otherwise -> s id - _ -> mempty - -hasExport :: CgStgBinding -> Bool -hasExport bnd = - case bnd of - StgNonRec b e -> isExportedBind b e - StgRec bs -> any (uncurry isExportedBind) bs - where - isExportedBind _i (StgRhsCon _cc con _ _ _) = - getUnique con == staticPtrDataConKey - isExportedBind _ _ = False - -collectTopIds :: CgStgBinding -> [Id] -collectTopIds (StgNonRec b _) = [b] -collectTopIds (StgRec bs) = let xs = map (zapFragileIdInfo . fst) bs - in seqList xs `seq` xs - -collectIds :: UniqFM Id CgStgExpr -> CgStgBinding -> [Id] -collectIds unfloated b = - let xs = map zapFragileIdInfo . - filter acceptId $ S.toList (bindingRefs unfloated b) - 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 - ------------------------------------------------------ --- Live vars --- --- TODO: should probably be moved into GHC.Stg.LiveVars - -type LiveVars = DVarSet - -liveStatic :: LiveVars -> LiveVars -liveStatic = filterDVarSet isGlobalId - -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)] - StgRec bs -> map (\(b,rhs) -> (b, stgRhsLive rhs)) bs - -stgBindRhsLive :: CgStgBinding -> LiveVars -stgBindRhsLive b = - let (bs, ls) = unzip (stgBindLive b) - in delDVarSetList (unionDVarSets ls) bs - -stgRhsLive :: CgStgRhs -> LiveVars -stgRhsLive = \case - StgRhsClosure _ _ _ args e -> delDVarSetList (stgExprLive True e) args - StgRhsCon _ _ _ _ args -> unionDVarSets (map stgArgLive args) - -stgArgLive :: StgArg -> LiveVars -stgArgLive = \case - StgVarArg occ -> unitDVarSet occ - StgLitArg {} -> emptyDVarSet - -stgExprLive :: Bool -> CgStgExpr -> LiveVars -stgExprLive includeLHS = \case - StgApp occ args -> unionDVarSets (unitDVarSet occ : map stgArgLive args) - StgLit {} -> emptyDVarSet - StgConApp _dc _n args _tys -> unionDVarSets (map stgArgLive args) - StgOpApp _op args _ty -> unionDVarSets (map stgArgLive args) - StgCase e b _at alts - | includeLHS -> el `unionDVarSet` delDVarSet al b - | otherwise -> delDVarSet al b - where - al = unionDVarSets (map stgAltLive alts) - el = stgExprLive True e - StgLet _ b e -> delDVarSetList (stgBindRhsLive b `unionDVarSet` stgExprLive True e) (bindees b) - StgLetNoEscape _ b e -> delDVarSetList (stgBindRhsLive b `unionDVarSet` stgExprLive True e) (bindees b) - StgTick _ti e -> stgExprLive True e - -stgAltLive :: CgStgAlt -> LiveVars -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] - StgRec bs -> map fst bs - -isUpdatableRhs :: CgStgRhs -> Bool -isUpdatableRhs (StgRhsClosure _ _ u _ _) = isUpdatable u -isUpdatableRhs _ = False - -stgLneLive' :: CgStgBinding -> [Id] -stgLneLive' b = filter (`notElem` bindees b) (stgLneLive b) - -stgLneLive :: CgStgBinding -> [Id] -stgLneLive (StgNonRec _b e) = stgLneLiveExpr e -stgLneLive (StgRec bs) = L.nub $ concatMap (stgLneLiveExpr . snd) bs - -stgLneLiveExpr :: CgStgRhs -> [Id] -stgLneLiveExpr rhs = dVarSetElems (liveVars $ stgRhsLive rhs) --- stgLneLiveExpr (StgRhsClosure _ _ _ _ e) = dVarSetElems (liveVars (stgExprLive e)) --- stgLneLiveExpr StgRhsCon {} = [] - --- | returns True if the expression is definitely inline -isInlineExpr :: UniqSet Id -> CgStgExpr -> (UniqSet Id, Bool) -isInlineExpr v = \case - StgApp i args - -> (emptyUniqSet, isInlineApp v i args) - StgLit{} - -> (emptyUniqSet, True) - StgConApp{} - -> (emptyUniqSet, True) - StgOpApp (StgFCallOp f _) _ _ - -> (emptyUniqSet, isInlineForeignCall f) - StgOpApp (StgPrimOp SeqOp) [StgVarArg e] t - -> (emptyUniqSet, e `elementOfUniqSet` v || isStrictType t) - StgOpApp (StgPrimOp op) _ _ - -> (emptyUniqSet, 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 - -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 - _ | isJoinId i -> False - [] -> isUnboxedTupleType (idType i) || - isStrictType (idType i) || - i `elementOfUniqSet` v - - [StgVarArg a] - | DataConWrapId dc <- idDetails i - , isNewTyCon (dataConTyCon dc) - , isStrictType (idType a) || a `elementOfUniqSet` v || isStrictId a - -> True - _ -> False - 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 @@ -1,4 +1,3 @@ -{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE LambdaCase #-} @@ -23,12 +22,17 @@ import GHC.Prelude -import GHC.JS.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 @@ -36,20 +40,21 @@ import GHC.Types.ForeignCall import Control.Monad.Trans.State.Strict -import GHC.Utils.Outputable (Outputable (..), text, SDocContext, (<+>), ($$)) +import GHC.Utils.Outputable (Outputable (..), text, SDocContext) import GHC.Data.FastString import GHC.Data.FastMutInt 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.Typeable (Typeable) -import GHC.Generics (Generic) -import Control.DeepSeq +import Data.Set (Set) import Data.Word -- | A State monad over IO holding the generator state. @@ -63,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 @@ -86,6 +91,7 @@ , csInlineLoadRegs :: !Bool , csInlineEnter :: !Bool , csInlineAlloc :: !Bool + , csPrettyRender :: !Bool , csTraceRts :: !Bool , csAssertRts :: !Bool , csBoundsCheck :: !Bool @@ -95,28 +101,27 @@ , 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 , ciType :: CIType -- ^ type of the object, with extra info where required , ciStatic :: CIStatic -- ^ static references of this object } - deriving stock (Eq, Show, Generic) + deriving stock (Eq, Show) -- | Closure information, 'ClosureInfo', registers 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, Generic) - -instance NFData CIRegs + deriving stock (Eq, Ord, Show) -- | Closure Information, 'ClosureInfo', layout data CILayout @@ -126,11 +131,9 @@ } | 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, Generic) - -instance NFData CILayout + deriving stock (Eq, Ord, Show) -- | The type of 'ClosureInfo' data CIType @@ -142,51 +145,47 @@ | CIPap -- ^ The closure is a Partial Application | CIBlackhole -- ^ The closure is a black hole | CIStackFrame -- ^ The closure is a stack frame - deriving stock (Eq, Ord, Show, Generic) - -instance NFData CIType + deriving stock (Eq, Ord, Show) -- | Static references that must be kept alive newtype CIStatic = CIStaticRefs { staticRefs :: [FastString] } - deriving stock (Eq, Generic) + deriving stock (Eq) deriving newtype (Semigroup, Monoid, Show) -- | static refs: array = references, null = nothing to report -- 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 - = PtrV -- ^ pointer = reference to heap object (closure object) +-- | 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 | DoubleV -- ^ A Double: one field | IntV -- ^ An Int (32bit because JS): one field | LongV -- ^ A Long: two fields one for the upper 32bits, one for the lower (NB: JS is little endian) | AddrV -- ^ a pointer not to the heap: two fields, array + index - | RtsObjV -- ^ some RTS object from GHCJS (for example TVar#, MVar#, MutVar#, Weak#) | ObjV -- ^ some JS object, user supplied, be careful around these, can be anything | ArrV -- ^ boxed array - deriving stock (Eq, Ord, Enum, Bounded, Show, Generic) - -instance NFData VarType + 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(); -- }; -- @ @@ -230,21 +229,25 @@ { siVar :: !FastString -- ^ global object , siVal :: !StaticVal -- ^ static initialization , siCC :: !(Maybe Ident) -- ^ optional CCS name - } deriving stock (Eq, Show, Typeable, Generic) + } 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) - deriving stock (Eq, Show, Generic) + | 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 = StaticUnboxedBool !Bool @@ -252,9 +255,7 @@ | StaticUnboxedDouble !SaneDouble | StaticUnboxedString !BS.ByteString | StaticUnboxedStringOffset !BS.ByteString - deriving stock (Eq, Ord, Show, Generic) - -instance NFData StaticUnboxed + deriving stock (Eq, Ord, Show) -- | Static Arguments. Static Arguments are things that are statically -- allocated, i.e., they exist at program startup. These are static heap objects @@ -263,7 +264,7 @@ = StaticObjArg !FastString -- ^ reference to a heap object | StaticLitArg !StaticLit -- ^ literal | StaticConArg !FastString [StaticArg] -- ^ unfloated constructor - deriving stock (Eq, Show, Generic) + deriving stock (Eq, Show) instance Outputable StaticArg where ppr x = text (show x) @@ -277,20 +278,19 @@ | StringLit !FastString | BinLit !BS.ByteString | LabelLit !Bool !FastString -- ^ is function pointer, label (also used for string / binary init) - deriving (Eq, Show, Generic) + deriving (Eq, Show) instance Outputable StaticLit where ppr x = text (show x) - instance ToJExpr StaticLit where toJExpr (BoolLit b) = toJExpr b 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 @@ -300,11 +300,12 @@ , foreignRefCConv :: !CCallConv , foreignRefArgs :: ![FastString] , foreignRefResult :: !FastString - } deriving stock (Generic) + } + deriving (Show) --- | data used to generate one ObjUnit in our object file +-- | data used to generate one ObjBlock in our object file data LinkableUnit = LinkableUnit - { luObjUnit :: ObjUnit -- ^ serializable unit info + { luObjBlock :: ObjBlock -- ^ serializable unit info , luIdExports :: [Id] -- ^ exported names from haskell identifiers , luOtherExports :: [FastString] -- ^ other exports , luIdDeps :: [Id] -- ^ identifiers this unit depends on @@ -315,14 +316,14 @@ } -- | one toplevel block in the object file -data ObjUnit = ObjUnit - { oiSymbols :: ![FastString] -- ^ toplevel symbols (stored in index) - , oiClInfo :: ![ClosureInfo] -- ^ closure information of all closures in block - , oiStatic :: ![StaticInfo] -- ^ static closure data - , oiStat :: JStat -- ^ the code - , oiRaw :: !BS.ByteString -- ^ raw JS code - , oiFExports :: ![ExpFun] - , oiFImports :: ![ForeignJSRef] +data ObjBlock = ObjBlock + { 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] } data ExpFun = ExpFun @@ -351,26 +352,26 @@ -- | Typed expression data TypedExpr = TypedExpr { typex_typ :: !PrimRep - , typex_expr :: [JExpr] + , typex_expr :: [JStgExpr] } instance Outputable TypedExpr where - ppr x = text "TypedExpr: " <+> ppr (typex_expr x) - $$ text "PrimReps: " <+> ppr (typex_typ x) + 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 @@ -381,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 @@ -391,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 @@ -1,57 +1,473 @@ {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE LambdaCase #-} module GHC.StgToJS.Utils - ( assignToTypedExprs - , assignCoerce1 + ( assignCoerce1 , assignToExprCtx + , fixedLayout + , assocIdExprs + -- * Unboxable datacon + , isUnboxableCon + , isUnboxable + , isBoolDataCon + -- * JSRep + , slotCount + , varSize + , typeSize + , isVoid + , isMultiVar + , idJSRep + , typeJSRep + , unaryTypeJSRep + , primRepToJSRep + , primOrVoidRepToJSRep + , stackSlotType + , primRepSize + , mkArityTag + -- * References and Ids + , exprRefs + , hasExport + , collectTopIds + , collectIds + -- * Live variables + , LiveVars + , liveStatic + , liveVars + , stgRhsLive + , stgExprLive + , isUpdatableRhs + , stgLneLive' + , stgLneLiveExpr + , isInlineExpr ) where import GHC.Prelude -import GHC.StgToJS.Types import GHC.StgToJS.ExprCtx +import GHC.StgToJS.Symbols +import GHC.StgToJS.Types -import GHC.JS.Syntax +import GHC.JS.JStg.Syntax import GHC.JS.Make +import GHC.JS.Transform +import GHC.Core.DataCon +import GHC.Core.TyCo.Rep hiding (typeSize) import GHC.Core.TyCon +import GHC.Core.Type hiding (typeSize) +import GHC.Stg.Syntax + +import GHC.Tc.Utils.TcType + +import GHC.Builtin.Names +import GHC.Builtin.PrimOps (primOpIsReallyInline) + +import GHC.Types.RepType +import GHC.Types.Var +import GHC.Types.Var.Set +import GHC.Types.Id +import GHC.Types.Id.Info +import GHC.Types.Unique.FM +import GHC.Types.ForeignCall +import GHC.Types.TyThing +import GHC.Types.Name + import GHC.Utils.Misc +import GHC.Utils.Outputable hiding ((<>)) import GHC.Utils.Panic -import GHC.Utils.Outputable -assignToTypedExprs :: HasDebugCallStack => [TypedExpr] -> [JExpr] -> JStat +import qualified Data.Bits as Bits +import qualified Data.Foldable as F +import qualified Data.Set as S +import qualified Data.List as L +import Data.Set (Set) +import Data.Monoid + + +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 :: HasDebugCallStack => 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 :: HasDebugCallStack => [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 ]) -- | 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 UnliftedRep [sptr]) = mconcat - [ a_val |= var "h$stablePtrBuf" +assignCoerce (TypedExpr AddrRep [a_val, a_off]) (TypedExpr (BoxedRep (Just Unlifted)) [sptr]) = mconcat + [ a_val |= hdStablePtrBuf , a_off |= sptr ] -assignCoerce (TypedExpr UnliftedRep [sptr]) (TypedExpr AddrRep [_a_val, a_off]) = +assignCoerce (TypedExpr (BoxedRep (Just Unlifted)) [sptr]) (TypedExpr AddrRep [_a_val, a_off]) = sptr |= a_off assignCoerce p1 p2 = assignTypedExprs [p1] [p2] + +-------------------------------------------------------------------------------- +-- Core Utils +-------------------------------------------------------------------------------- + +-- | can we unbox C x to x, only if x is represented as a Number +isUnboxableCon :: DataCon -> Bool +isUnboxableCon dc + | [t] <- dataConRepArgTys dc + , [t1] <- typeJSRep (scaledThing t) + = isUnboxable t1 && + dataConTag dc == 1 && + length (tyConDataCons $ dataConTyCon dc) == 1 + | otherwise = False + +-- | one-constructor types with one primitive field represented as a JS Number +-- can be unboxed +isUnboxable :: JSRep -> Bool +isUnboxable DoubleV = True +isUnboxable IntV = True -- includes Char# +isUnboxable _ = False + +-- | Number of slots occupied by a PrimRep +data SlotCount + = NoSlot + | OneSlot + | TwoSlots + deriving (Show,Eq,Ord) + +instance Outputable SlotCount where + ppr = text . show + +-- | Return SlotCount as an Int +slotCount :: SlotCount -> Int +slotCount = \case + NoSlot -> 0 + OneSlot -> 1 + TwoSlots -> 2 + + +-- | Number of slots occupied by a value with the given JSRep +varSize :: JSRep -> Int +varSize = slotCount . jsRepSlots + +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 . typeJSRep $ t + +isVoid :: JSRep -> Bool +isVoid VoidV = True +isVoid _ = False + +isMultiVar :: JSRep -> Bool +isMultiVar v = case jsRepSlots v of + NoSlot -> False + OneSlot -> False + TwoSlots -> True + +idJSRep :: HasDebugCallStack => Id -> [JSRep] +idJSRep = typeJSRep . idType + +typeJSRep :: HasDebugCallStack => Type -> [JSRep] +typeJSRep t = map primRepToJSRep (typePrimRep t) + +-- only use if you know it's not an unboxed tuple +unaryTypeJSRep :: HasDebugCallStack => UnaryType -> JSRep +unaryTypeJSRep ut = primOrVoidRepToJSRep (typePrimRep1 ut) + +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" + +primOrVoidRepToJSRep :: HasDebugCallStack => PrimOrVoidRep -> JSRep +primOrVoidRepToJSRep VoidRep = VoidV +primOrVoidRepToJSRep (NVRep rep) = primRepToJSRep rep + +dataConType :: DataCon -> Type +dataConType dc = idType (dataConWrapId dc) + +isBoolDataCon :: DataCon -> Bool +isBoolDataCon dc = isBoolTy (dataConType dc) + +-- standard fixed layout: payload types +-- payload starts at .d1 for heap objects, entry closest to Sp for stack frames +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 -> JSRep +stackSlotType i + | OneSlot <- jsRepSlots otype = otype + | otherwise = DoubleV + where otype = unaryTypeJSRep (idType i) + +idPrimReps :: Id -> [PrimRep] +idPrimReps = typePrimReps . idType + +typePrimReps :: Type -> [PrimRep] +typePrimReps = typePrimRep . unwrapType + +primRepSize :: PrimRep -> SlotCount +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] -> [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 jStgExprToJS <$> err) + +-- | Associate the given values to the Id's PrimReps, taking into account the +-- number of slots per PrimRep +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 -> [JStgExpr] -> [TypedExpr] +assocIdExprs i es = fmap (uncurry TypedExpr) (assocIdPrimReps i es) + +mkArityTag :: Int -> Int -> Int +mkArityTag arity registers = arity Bits..|. (registers `Bits.shiftL` 8) + +-------------------------------------------------------------------------------- +-- Stg Utils +-------------------------------------------------------------------------------- + +s :: a -> Set a +s = S.singleton + +l :: (a -> Set Id) -> [a] -> Set Id +l = F.foldMap + +-- | collect Ids that this binding refers to +-- (does not include the bindees themselves) +-- first argument is Id -> StgExpr map for unfloated arguments +bindingRefs :: UniqFM Id CgStgExpr -> CgStgBinding -> Set Id +bindingRefs u = \case + StgNonRec _ rhs -> rhsRefs u rhs + StgRec bs -> l (rhsRefs u . snd) bs + +rhsRefs :: UniqFM Id CgStgExpr -> CgStgRhs -> Set Id +rhsRefs u = \case + StgRhsClosure _ _ _ _ body _ -> exprRefs u body + StgRhsCon _ccs d _mu _ticks args _ -> l s [ i | AnId i <- dataConImplicitTyThings d] <> l (argRefs u) args + +exprRefs :: UniqFM Id CgStgExpr -> CgStgExpr -> Set Id +exprRefs u = \case + StgApp f args -> s f <> l (argRefs u) args + StgConApp d _n args _ -> l s [ i | AnId i <- dataConImplicitTyThings d] <> l (argRefs u) args + StgOpApp _ args _ -> l (argRefs u) args + StgLit {} -> mempty + StgCase expr _ _ alts -> exprRefs u expr <> mconcat (fmap (altRefs u) alts) + StgLet _ bnd expr -> bindingRefs u bnd <> exprRefs u expr + StgLetNoEscape _ bnd expr -> bindingRefs u bnd <> exprRefs u expr + StgTick _ expr -> exprRefs u expr + +altRefs :: UniqFM Id CgStgExpr -> CgStgAlt -> Set Id +altRefs u alt = exprRefs u (alt_rhs alt) + +argRefs :: UniqFM Id CgStgExpr -> StgArg -> Set Id +argRefs u = \case + StgVarArg id + | Just e <- lookupUFM u id -> exprRefs u e + | otherwise -> s id + _ -> mempty + +hasExport :: CgStgBinding -> Bool +hasExport bnd = + case bnd of + StgNonRec b e -> isExportedBind b e + StgRec bs -> any (uncurry isExportedBind) bs + where + isExportedBind _i (StgRhsCon _cc con _ _ _ _) = + getUnique con == staticPtrDataConKey + isExportedBind _ _ = False + +collectTopIds :: CgStgBinding -> [Id] +collectTopIds (StgNonRec b _) = [b] +collectTopIds (StgRec bs) = let xs = map (zapFragileIdInfo . fst) bs + in seqList xs `seq` xs + +collectIds :: UniqFM Id CgStgExpr -> CgStgBinding -> [Id] +collectIds unfloated b = + let xs = map zapFragileIdInfo . + filter acceptId $ S.toList (bindingRefs unfloated b) + in seqList xs `seq` xs + where + acceptId i = all ($ i) [not . isForbidden] -- fixme test this: [isExported[isGlobalId, not.isForbidden] + isForbidden i + -- 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 +-- +-- TODO: should probably be moved into GHC.Stg.LiveVars + +type LiveVars = DVarSet + +liveStatic :: LiveVars -> LiveVars +liveStatic = filterDVarSet isGlobalId + +liveVars :: LiveVars -> LiveVars +liveVars = filterDVarSet (not . isGlobalId) + +stgBindLive :: CgStgBinding -> [(Id, LiveVars)] +stgBindLive = \case + StgNonRec b rhs -> [(b, stgRhsLive rhs)] + StgRec bs -> map (\(b,rhs) -> (b, stgRhsLive rhs)) bs + +stgBindRhsLive :: CgStgBinding -> LiveVars +stgBindRhsLive b = + let (bs, ls) = unzip (stgBindLive b) + in delDVarSetList (unionDVarSets ls) bs + +stgRhsLive :: CgStgRhs -> LiveVars +stgRhsLive = \case + StgRhsClosure _ _ _ args e _ -> delDVarSetList (stgExprLive True e) args + StgRhsCon _ _ _ _ args _ -> unionDVarSets (map stgArgLive args) + +stgArgLive :: StgArg -> LiveVars +stgArgLive = \case + StgVarArg occ -> unitDVarSet occ + StgLitArg {} -> emptyDVarSet + +stgExprLive :: Bool -> CgStgExpr -> LiveVars +stgExprLive includeLHS = \case + StgApp occ args -> unionDVarSets (unitDVarSet occ : map stgArgLive args) + StgLit {} -> emptyDVarSet + StgConApp _dc _n args _tys -> unionDVarSets (map stgArgLive args) + StgOpApp _op args _ty -> unionDVarSets (map stgArgLive args) + StgCase e b _at alts + | includeLHS -> el `unionDVarSet` delDVarSet al b + | otherwise -> delDVarSet al b + where + al = unionDVarSets (map stgAltLive alts) + el = stgExprLive True e + StgLet _ b e -> delDVarSetList (stgBindRhsLive b `unionDVarSet` stgExprLive True e) (bindees b) + StgLetNoEscape _ b e -> delDVarSetList (stgBindRhsLive b `unionDVarSet` stgExprLive True e) (bindees b) + StgTick _ti e -> stgExprLive True e + +stgAltLive :: CgStgAlt -> LiveVars +stgAltLive alt = + delDVarSetList (stgExprLive True (alt_rhs alt)) (alt_bndrs alt) + +bindees :: CgStgBinding -> [Id] +bindees = \case + StgNonRec b _e -> [b] + StgRec bs -> map fst bs + +isUpdatableRhs :: CgStgRhs -> Bool +isUpdatableRhs (StgRhsClosure _ _ u _ _ _) = isUpdatable u +isUpdatableRhs _ = False + +stgLneLive' :: CgStgBinding -> [Id] +stgLneLive' b = filter (`notElem` bindees b) (stgLneLive b) + +stgLneLive :: CgStgBinding -> [Id] +stgLneLive (StgNonRec _b e) = stgLneLiveExpr e +stgLneLive (StgRec bs) = L.nub $ concatMap (stgLneLiveExpr . snd) bs + +stgLneLiveExpr :: CgStgRhs -> [Id] +stgLneLiveExpr rhs = dVarSetElems (liveVars $ stgRhsLive rhs) +-- stgLneLiveExpr (StgRhsClosure _ _ _ _ e) = dVarSetElems (liveVars (stgExprLive e)) +-- stgLneLiveExpr StgRhsCon {} = [] + +-- | returns True if the expression is definitely inline +isInlineExpr :: CgStgExpr -> Bool +isInlineExpr = \case + StgApp i args + -> isInlineApp i args + StgLit{} + -> True + StgConApp{} + -> True + StgOpApp (StgFCallOp f _) _ _ + -> isInlineForeignCall f + StgOpApp (StgPrimOp op) _ _ + -> primOpIsReallyInline op + StgOpApp (StgPrimCallOp _c) _ _ + -> 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 :: Id -> [StgArg] -> Bool +isInlineApp i = \case + _ | isJoinId i -> False + [] -> isUnboxedTupleType (idType i) || + isStrictType (idType i) || + ctxIsEvaluated i + + [StgVarArg a] + | DataConWrapId dc <- idDetails i + , isNewTyCon (dataConTyCon dc) + , 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,8 +155,14 @@ 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 = + [ "-D__FMA__" | isFmaEnabled dflags ] + let avx_defs = [ "-D__AVX__" | isAvxEnabled dflags ] ++ [ "-D__AVX2__" | isAvx2Enabled dflags ] ++ @@ -109,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 @@ -134,12 +201,14 @@ 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 ++ map GHC.SysTools.Option avx_defs ++ map GHC.SysTools.Option io_manager_defs ++ mb_macro_include @@ -195,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,238 +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 (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 ("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.Session - 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,35 +7,55 @@ -- (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 import GHC.Utils.Misc import GHC.Utils.Logger import GHC.Utils.TmpFs -import GHC.Utils.Constants (isWindowsHost) 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) {- ************************************************************************ @@ -61,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, @@ -140,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 @@ -205,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 @@ -237,12 +301,26 @@ 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 @@ -278,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 = @@ -353,12 +366,10 @@ , "does not support object merging." ] optl_args = map Option (getOpts dflags opt_lm) args2 = args0 ++ args ++ optl_args - -- N.B. Darwin's ld64 doesn't support response files. Consequently we only - -- use them on Windows where they are truly necessary. - if isWindowsHost + 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 @@ -390,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,56 +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 {- ************************************************************************ @@ -173,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 } {- @@ -277,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] @@ -289,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 @@ -414,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] @@ -432,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. @@ -443,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 @@ -455,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 @@ -491,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 = ... @@ -606,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)" $ @@ -639,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)) @@ -677,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. -- @@ -762,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. @@ -792,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 @@ -808,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' @@ -854,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 } @@ -1133,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 @@ -1154,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 :: @@ -1335,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 @@ -1348,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' @@ -1358,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 @@ -1370,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 @@ -1442,19 +1542,24 @@ -- See Note [DerivEnv and DerivSpecMechanism] in GHC.Tc.Deriv.Utils whenIsJust (hasStockDeriving cls) $ \_ -> expectNonDataFamTyCon dit - mk_eqn_originative dit + mk_eqn_originative cls dit | otherwise -> mk_eqn_anyclass where -- Use heuristics (checkOriginativeSideConditions) to determine whether -- stock or anyclass deriving should be used. - mk_eqn_originative :: DerivInstTys -> DerivM EarlyDerivSpec - mk_eqn_originative dit@(DerivInstTys { dit_tc = tc - , dit_rep_tc = rep_tc }) = do + mk_eqn_originative :: Class -> DerivInstTys -> DerivM EarlyDerivSpec + mk_eqn_originative cls dit@(DerivInstTys { dit_tc = tc + , dit_rep_tc = rep_tc }) = do dflags <- getDynFlags - let isDeriveAnyClassEnabled = - deriveAnyClassEnabled (xopt LangExt.DeriveAnyClass dflags) + let isDeriveAnyClassEnabled + | canSafelyDeriveAnyClass cls + = deriveAnyClassEnabled (xopt LangExt.DeriveAnyClass dflags) + | otherwise + -- Pretend that the extension is enabled so that we won't suggest + -- enabling it. + = YesDeriveAnyClassEnabled -- See Note [Deriving instances for classes themselves] let dac_error @@ -1471,6 +1576,12 @@ , dsm_stock_gen_fns = gen_fns } CanDeriveAnyClass -> mk_eqn_from_mechanism DerivSpecAnyClass + canSafelyDeriveAnyClass cls = + -- If the set of minimal required definitions is nonempty, + -- `DeriveAnyClass` will generate an instance with undefined methods or + -- associated types, so don't suggest enabling it. + isNothing $ isUnsatisfied (const False) (classMinimalDef cls) + {- ************************************************************************ * * @@ -1864,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 @@ -1892,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 @@ -1903,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] @@ -1960,9 +2068,13 @@ case mechanism of DerivSpecStock{dsm_stock_dit = dit} -> data_cons_in_scope_check dit - DerivSpecNewtype{dsm_newtype_dit = dit} - -> do atf_coerce_based_error_checks - 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 constructors as + -- used because newtypes are handled separately elsewhere. + -- See Note [Tracking unused binding and imports] in GHC.Tc.Types + -- or #17328 for more. + DerivSpecNewtype{} + -> atf_coerce_based_error_checks DerivSpecAnyClass{} -> pure () DerivSpecVia{} @@ -2241,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, @@ -44,53 +44,56 @@ import GHC.Prelude -import GHC.Tc.Utils.Monad -import GHC.Tc.TyCl.Class ( substATBndrs ) import GHC.Hs -import GHC.Types.FieldLabel + +import GHC.Tc.TyCl.Class ( substATBndrs ) +import GHC.Tc.Utils.Monad +import GHC.Tc.Utils.Instantiate( newFamInst ) +import GHC.Tc.Utils.Env +import GHC.Tc.Utils.TcType +import GHC.Tc.Zonk.Type +import GHC.Tc.Validity + +import GHC.Core.DataCon +import GHC.Core.FamInstEnv +import GHC.Core.TyCon +import GHC.Core.Coercion.Axiom ( coAxiomSingleBranch ) +import GHC.Core.Type +import GHC.Core.Class + import GHC.Types.Name.Reader import GHC.Types.Basic import GHC.Types.Fixity -import GHC.Core.DataCon import GHC.Types.Name import GHC.Types.SourceText +import GHC.Types.Id.Make ( coerceId ) +import GHC.Types.SrcLoc +import GHC.Types.Unique.FM ( lookupUFM, listToUFM ) +import GHC.Types.Var.Env +import GHC.Types.Var +import GHC.Types.Var.Set -import GHC.Tc.Instance.Family -import GHC.Core.FamInstEnv import GHC.Builtin.Names import GHC.Builtin.Names.TH -import GHC.Types.Id.Make ( coerceId ) import GHC.Builtin.PrimOps import GHC.Builtin.PrimOps.Ids (primOpId) -import GHC.Types.SrcLoc -import GHC.Core.TyCon -import GHC.Tc.Utils.Env -import GHC.Tc.Utils.TcType -import GHC.Tc.Utils.Zonk -import GHC.Tc.Validity ( checkValidCoAxBranch ) -import GHC.Core.Coercion.Axiom ( coAxiomSingleBranch ) import GHC.Builtin.Types.Prim import GHC.Builtin.Types -import GHC.Core.Type -import GHC.Core.Class -import GHC.Types.Unique.FM ( lookupUFM, listToUFM ) -import GHC.Types.Var.Env import GHC.Utils.Misc -import GHC.Types.Var import GHC.Utils.Outputable import GHC.Utils.Panic -import GHC.Utils.Panic.Plain import GHC.Utils.Lexeme + import GHC.Data.FastString import GHC.Data.Pair import GHC.Data.Bag +import GHC.Data.Maybe ( expectJust ) +import GHC.Unit.Module import Language.Haskell.Syntax.Basic (FieldLabelString(..)) import Data.List ( find, partition, intersperse ) -import GHC.Data.Maybe ( expectJust ) -import GHC.Unit.Module -- | A declarative description of an auxiliary binding that should be -- generated. See @Note [Auxiliary binders]@ for a more detailed description @@ -237,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 @@ -260,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 @@ -403,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 @@ -415,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 @@ -444,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 @@ -512,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 @@ -591,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 {}) @@ -601,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 } } @@ -657,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 @@ -673,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] @@ -695,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, @@ -713,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 @@ -726,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]) @@ -741,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 @@ -838,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]) $ @@ -855,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 @@ -871,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)] ( @@ -885,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... @@ -905,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) @@ -917,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 @@ -943,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] @@ -1031,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 @@ -1049,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 @@ -1111,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 @@ -1119,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 @@ -1216,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) @@ -1263,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 @@ -1272,15 +1278,13 @@ 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 | isUnliftedType arg_ty -- See Note [Deriving and unboxed types] in GHC.Tc.Deriv.Infer - = with_conv $ - nlHsApps compose_RDR + = nlHsApps compose_RDR [mk_shows_app boxed_arg, mk_showString_app postfixMod] | otherwise = mk_showsPrec_app arg_prec arg @@ -1288,14 +1292,6 @@ arg = nlHsVar b boxed_arg = box "Show" arg arg_ty postfixMod = assoc_ty_id "Show" postfixModTbl arg_ty - with_conv expr - | (Just conv) <- assoc_ty_id_maybe primConvTbl arg_ty = - nested_compose_Expr - [ mk_showString_app ("(" ++ conv ++ " ") - , expr - , mk_showString_app ")" - ] - | otherwise = expr -- Fixity stuff is_infix = dataConIsInfix data_con @@ -1341,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 @@ -1391,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 @@ -1410,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 @@ -1420,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 @@ -1430,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 @@ -1461,7 +1448,7 @@ = mkSimpleGeneratedFunBind loc dataTypeOf_RDR - [nlWildPat] + (noLocA [nlWildPat]) (nlHsVar dataT_RDR) ------------ gcast1/2 @@ -1483,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 @@ -1511,25 +1498,24 @@ eqAddr_RDR , ltAddr_RDR , geAddr_RDR , gtAddr_RDR , leAddr_RDR , eqFloat_RDR , ltFloat_RDR , geFloat_RDR , gtFloat_RDR , leFloat_RDR , eqDouble_RDR, ltDouble_RDR, geDouble_RDR, gtDouble_RDR, leDouble_RDR, - word8ToWord_RDR , int8ToInt_RDR , - word16ToWord_RDR, int16ToInt_RDR, - word32ToWord_RDR, int32ToInt_RDR + 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#") @@ -1616,15 +1602,14 @@ gtDouble_RDR = varQual_RDR gHC_PRIM (fsLit ">##" ) geDouble_RDR = varQual_RDR gHC_PRIM (fsLit ">=##") -word8ToWord_RDR = varQual_RDR gHC_PRIM (fsLit "word8ToWord#") -int8ToInt_RDR = varQual_RDR gHC_PRIM (fsLit "int8ToInt#") - -word16ToWord_RDR = varQual_RDR gHC_PRIM (fsLit "word16ToWord#") -int16ToInt_RDR = varQual_RDR gHC_PRIM (fsLit "int16ToInt#") - -word32ToWord_RDR = varQual_RDR gHC_PRIM (fsLit "word32ToWord#") -int32ToInt_RDR = varQual_RDR gHC_PRIM (fsLit "int32ToInt#") - +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#") {- ************************************************************************ * * @@ -1639,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] {- ************************************************************************ @@ -1704,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 @@ -1727,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 @@ -1741,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): @@ -1807,21 +1892,20 @@ *must* generate a term-level evidence binding in order to instantiate the quantified constraint! In response, GHC currently chooses not to use such a quantified constraint. -See Note [Instances in no-evidence implications] in GHC.Tc.Solver.Interact. +See Note [Instances in no-evidence implications] in GHC.Tc.Solver.Equality. 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 @@ -1830,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 @@ -1979,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 @@ -2006,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 @@ -2052,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. @@ -2093,6 +2110,7 @@ rep_lhs_tys let axiom = mkSingleCoAxiom Nominal rep_tc_name rep_tvs' [] rep_cvs' fam_tc rep_lhs_tys rep_rhs_ty + checkFamPatBinders fam_tc (rep_tvs' ++ rep_cvs') emptyVarSet rep_lhs_tys rep_rhs_ty -- Check (c) from Note [GND and associated type families] in GHC.Tc.Deriv checkValidCoAxBranch fam_tc (coAxiomSingleBranch axiom) newFamInst SynFamilyInst axiom @@ -2107,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 @@ -2185,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) @@ -2229,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 _ _ _ @@ -2291,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 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 @@ -2312,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 ] @@ -2327,7 +2345,7 @@ -> [LMatch GhcPs (LHsExpr GhcPs)] -> LHsBind GhcPs mkRdrFunBindEC arity catch_all fun@(L loc _fun_rdr) matches - = L (na2la loc) (mkFunBind Generated fun matches') + = L (l2l loc) (mkFunBind (Generated OtherExpansion SkipPmc) fun matches') where -- Catch-all eqn looks like -- fmap _ z = case z of {} @@ -2339,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 @@ -2351,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 fun matches') + = L (l2l loc) (mkFunBind (Generated OtherExpansion SkipPmc) fun matches') where -- Catch-all eqn looks like -- compare _ _ = error "Void compare" @@ -2359,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) @@ -2371,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 @@ -2411,38 +2429,28 @@ ,(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. --- NOTE: Int8#/Word8# will become Int/Word. -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 $ getRdrName intDataCon) - . nlHsApp (nlHsVar int8ToInt_RDR)) - , (word8PrimTy, - nlHsApp (nlHsVar $ getRdrName wordDataCon) - . nlHsApp (nlHsVar word8ToWord_RDR)) - , (int16PrimTy, - nlHsApp (nlHsVar $ getRdrName intDataCon) - . nlHsApp (nlHsVar int16ToInt_RDR)) - , (word16PrimTy, - nlHsApp (nlHsVar $ getRdrName wordDataCon) - . nlHsApp (nlHsVar word16ToWord_RDR)) - , (int32PrimTy, - nlHsApp (nlHsVar $ getRdrName intDataCon) - . nlHsApp (nlHsVar int32ToInt_RDR)) - , (word32PrimTy, - nlHsApp (nlHsVar $ getRdrName wordDataCon) - . nlHsApp (nlHsVar word32ToWord_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) ] -- | A table of postfix modifiers for unboxed values. +-- Following https://github.com/ghc-proposals/ghc-proposals/pull/596, +-- we use the ExtendedLiterals syntax for sized literals. postfixModTbl :: [(Type, String)] postfixModTbl = [(charPrimTy , "#" ) @@ -2450,46 +2458,18 @@ ,(wordPrimTy , "##") ,(floatPrimTy , "#" ) ,(doublePrimTy, "##") - ,(int8PrimTy, "#") - ,(word8PrimTy, "##") - ,(int16PrimTy, "#") - ,(word16PrimTy, "##") - ,(int32PrimTy, "#") - ,(word32PrimTy, "##") - ] - -primConvTbl :: [(Type, String)] -primConvTbl = - [ (int8PrimTy, "intToInt8#") - , (word8PrimTy, "wordToWord8#") - , (int16PrimTy, "intToInt16#") - , (word16PrimTy, "wordToWord16#") - , (int32PrimTy, "intToInt32#") - , (word32PrimTy, "wordToWord32#") - ] - -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)) + ,(int8PrimTy , "#Int8") + ,(word8PrimTy , "#Word8") + ,(int16PrimTy , "#Int16") + ,(word16PrimTy, "#Word16") + ,(int32PrimTy , "#Int32") + ,(word32PrimTy, "#Word32") + ,(int64PrimTy , "#Int64") + ,(word64PrimTy, "#Word64") ] -- | Lookup `Type` in an association list. -assoc_ty_id :: HasCallStack => String -- The class involved +assoc_ty_id :: HasDebugCallStack => String -- The class involved -> [(Type,a)] -- The table -> Type -- The type -> a -- The result of the lookup @@ -2542,47 +2522,22 @@ 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. genOpApp :: LHsExpr GhcPs -> RdrName -> LHsExpr GhcPs -> LHsExpr GhcPs @@ -2780,19 +2735,19 @@ rep_tc_args' = substTys subst rep_tc_args -- | Zonk the 'TcTyVar's in a 'DerivInstTys' value to 'TyVar's. --- See @Note [What is zonking?]@ in "GHC.Tc.Utils.TcMType". +-- See @Note [What is zonking?]@ in "GHC.Tc.Zonk.Type". -- -- This is only used in the final zonking step when inferring -- the context for a derived instance. -- See @Note [Overlap and deriving]@ in "GHC.Tc.Deriv.Infer". -zonkDerivInstTys :: ZonkEnv -> DerivInstTys -> TcM DerivInstTys -zonkDerivInstTys ze dit@(DerivInstTys { dit_cls_tys = cls_tys - , dit_tc_args = tc_args - , dit_rep_tc = rep_tc - , dit_rep_tc_args = rep_tc_args }) = do - cls_tys' <- zonkTcTypesToTypesX ze cls_tys - tc_args' <- zonkTcTypesToTypesX ze tc_args - rep_tc_args' <- zonkTcTypesToTypesX ze rep_tc_args +zonkDerivInstTys :: DerivInstTys -> ZonkT TcM DerivInstTys +zonkDerivInstTys dit@(DerivInstTys { dit_cls_tys = cls_tys + , dit_tc_args = tc_args + , dit_rep_tc = rep_tc + , dit_rep_tc_args = rep_tc_args }) = do + cls_tys' <- zonkTcTypesToTypesX cls_tys + tc_args' <- zonkTcTypesToTypesX tc_args + rep_tc_args' <- zonkTcTypesToTypesX rep_tc_args pure dit{ dit_cls_tys = cls_tys' , dit_tc_args = tc_args' , dit_rep_tc_args = rep_tc_args' 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 @@ -28,7 +28,9 @@ import GHC.Tc.Deriv.Generate import GHC.Tc.Deriv.Functor import GHC.Tc.Errors.Types -import GHC.Tc.Instance.Family +import GHC.Tc.Utils.Instantiate( newFamInst ) +import GHC.Tc.Utils.Env +import GHC.Tc.Utils.Monad import GHC.Core.Type import GHC.Core.DataCon @@ -45,29 +47,27 @@ import GHC.Types.SourceText import GHC.Types.Fixity import GHC.Types.Basic +import GHC.Types.SrcLoc +import GHC.Types.Var.Env +import GHC.Types.Var.Set (elemVarSet) + import GHC.Builtin.Types.Prim import GHC.Builtin.Types import GHC.Builtin.Names -import GHC.Tc.Utils.Env -import GHC.Tc.Utils.Monad -import GHC.Driver.Session + import GHC.Utils.Error( Validity'(..), andValid ) -import GHC.Types.SrcLoc -import GHC.Data.Bag -import GHC.Types.Var.Env -import GHC.Types.Var.Set (elemVarSet) import GHC.Utils.Outputable import GHC.Utils.Panic -import GHC.Utils.Panic.Plain -import GHC.Data.FastString import GHC.Utils.Misc +import GHC.Driver.DynFlags +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) @@ -350,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 @@ -377,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 } @@ -652,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,10 +27,13 @@ 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) +import GHC.Tc.Zonk.TcType ( zonkWC ) +import GHC.Tc.Zonk.Env ( ZonkFlexi(..), initZonkEnv ) import GHC.Core.Class import GHC.Core.DataCon @@ -41,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 @@ -64,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 @@ -81,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} @@ -167,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 @@ -295,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 } @@ -368,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] @@ -406,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] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -549,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 @@ -672,7 +758,7 @@ ; final_specs <- iterate_deriv 1 initial_solutions -- After simplification finishes, zonk the TcTyVars as described -- in Note [Overlap and deriving]. - ; traverse zonkDerivSpec final_specs } + ; initZonkEnv DefaultFlexi $ traverse zonkDerivSpec final_specs } where ------------------------------------------------------------------ -- The initial solutions for the equations claim that each @@ -713,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) - {- *********************************************************************************** * * @@ -735,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 @@ -756,20 +838,22 @@ solveWanteds wanteds -- It's not yet zonked! Obviously zonk it before peering at it - ; solved_wanteds <- zonkWC solved_wanteds + ; solved_wanteds <- liftZonkM $ zonkWC solved_wanteds -- 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. -- Returns @Nothing@ if the Ct is too exotic. - -- See Note [Exotic derived instance contexts] for what - -- constitutes an exotic constraint. + -- See (VD2) in Note [Valid 'deriving' predicate] in + -- GHC.Tc.Validity for what constitutes an exotic constraint. get_good :: Ct -> Maybe PredType get_good ct | validDerivPred head_size p = Just p | otherwise = Nothing @@ -798,8 +882,9 @@ min_theta_vars solved_wanteds -- This call to simplifyTop is purely for error reporting -- See Note [Error reporting for deriving clauses] - -- See also Note [Exotic derived instance contexts], which are caught - -- in this line of code. + -- See also Note [Valid 'deriving' predicate] in GHC.Tc.Validity, as this + -- line of code catches "exotic" constraints like the ones described in + -- (VD2) of that Note. ; simplifyTopImplic leftover_implic ; traceTc "GHC.Tc.Deriv" (ppr deriv_rhs $$ ppr min_theta) @@ -807,7 +892,7 @@ -- Claim: the result instance declaration is guaranteed valid -- Hence no need to call: -- checkValidInstance tyvars theta clas inst_tys - -- See Note [Exotic derived instance contexts] + -- See Note [Valid 'deriving' predicate] in GHC.Tc.Validity ; return min_theta } @@ -1008,7 +1093,8 @@ cannot solve, which might include: 1. Insoluble constraints -2. "Exotic" constraints (See Note [Exotic derived instance contexts]) +2. "Exotic" constraints (See Note [Valid 'deriving' predicate] in + GHC.Tc.Validity) Then we report an error immediately in simplifyDeriv. @@ -1029,55 +1115,4 @@ all the constraints in , then everything is hunky-dory. But if contains, say, an insoluble constraint, then (Foo a) won't be able to solve it, causing GHC to error. - -Note [Exotic derived instance contexts] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In a 'derived' instance declaration, we *infer* the context. It's a -bit unclear what rules we should apply for this; the Haskell report is -silent. Obviously, constraints like (Eq a) are fine, but what about - data T f a = MkT (f a) deriving( Eq ) -where we'd get an Eq (f a) constraint. That's probably fine too. - -One could go further: consider - data T a b c = MkT (Foo a b c) deriving( Eq ) - instance (C Int a, Eq b, Eq c) => Eq (Foo a b c) - -Notice that this instance (just) satisfies the Paterson termination -conditions. Then we *could* derive an instance decl like this: - - instance (C Int a, Eq b, Eq c) => Eq (T a b c) -even though there is no instance for (C Int a), because there just -*might* be an instance for, say, (C Int Bool) at a site where we -need the equality instance for T's. - -However, this seems pretty exotic, and it's quite tricky to allow -this, and yet give sensible error messages in the (much more common) -case where we really want that instance decl for C. - -So for now we simply require that the derived instance context -should have only type-variable constraints. - -Here is another example: - data Fix f = In (f (Fix f)) deriving( Eq ) -Here, if we are prepared to allow -XUndecidableInstances we -could derive the instance - instance Eq (f (Fix f)) => Eq (Fix f) -but this is so delicate that I don't think it should happen inside -'deriving'. If you want this, write it yourself! - -NB: if you want to lift this condition, make sure you still meet the -termination conditions! If not, the deriving mechanism generates -larger and larger constraints. Example: - data Succ a = S a - data Seq a = Cons a (Seq (Succ a)) | Nil deriving Show - -Note the lack of a Show instance for Succ. First we'll generate - instance (Show (Succ a), Show a) => Show (Seq a) -and then - instance (Show (Succ (Succ a)), Show (Succ a), Show a) => Show (Seq a) -and so on. Instead we want to complain of no instance for (Show (Succ a)). - -The bottom line -~~~~~~~~~~~~~~~ -Allow constraints which consist only of type variables, with no repeats. -} 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 @@ -39,7 +40,7 @@ import GHC.Tc.Utils.Monad import GHC.Tc.Utils.TcType import GHC.Tc.Utils.Unify (tcSubTypeSigma) -import GHC.Tc.Utils.Zonk +import GHC.Tc.Zonk.Type import GHC.Core.Class import GHC.Core.DataCon @@ -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 @@ -231,22 +229,22 @@ setDerivSpecTheta theta ds = ds{ds_theta = theta} -- | Zonk the 'TcTyVar's in a 'DerivSpec' to 'TyVar's. --- See @Note [What is zonking?]@ in "GHC.Tc.Utils.TcMType". +-- See @Note [What is zonking?]@ in "GHC.Tc.Zonk.Type". -- -- This is only used in the final zonking step when inferring -- the context for a derived instance. -- See @Note [Overlap and deriving]@ in "GHC.Tc.Deriv.Infer". -zonkDerivSpec :: DerivSpec ThetaType -> TcM (DerivSpec ThetaType) +zonkDerivSpec :: DerivSpec ThetaType -> ZonkTcM (DerivSpec ThetaType) zonkDerivSpec ds@(DS { ds_tvs = tvs, ds_theta = theta , ds_tys = tys, ds_mechanism = mechanism - }) = do - (ze, tvs') <- zonkTyBndrs tvs - theta' <- zonkTcTypesToTypesX ze theta - tys' <- zonkTcTypesToTypesX ze tys - mechanism' <- zonkDerivSpecMechanism ze mechanism - pure ds{ ds_tvs = tvs', ds_theta = theta' - , ds_tys = tys', ds_mechanism = mechanism' - } + }) = + runZonkBndrT (zonkTyBndrsX tvs) $ \ tvs' -> do + theta' <- zonkTcTypesToTypesX theta + tys' <- zonkTcTypesToTypesX tys + mechanism' <- zonkDerivSpecMechanism mechanism + pure ds{ ds_tvs = tvs', ds_theta = theta' + , ds_tys = tys', ds_mechanism = mechanism' + } -- | What action to take in order to derive a class instance. -- See @Note [DerivEnv and DerivSpecMechanism]@, as well as @@ -308,26 +306,26 @@ isDerivSpecVia _ = False -- | Zonk the 'TcTyVar's in a 'DerivSpecMechanism' to 'TyVar's. --- See @Note [What is zonking?]@ in "GHC.Tc.Utils.TcMType". +-- See @Note [What is zonking?]@ in "GHC.Tc.Zonk.Type". -- -- This is only used in the final zonking step when inferring -- the context for a derived instance. -- See @Note [Overlap and deriving]@ in "GHC.Tc.Deriv.Infer". -zonkDerivSpecMechanism :: ZonkEnv -> DerivSpecMechanism -> TcM DerivSpecMechanism -zonkDerivSpecMechanism ze mechanism = +zonkDerivSpecMechanism :: DerivSpecMechanism -> ZonkTcM DerivSpecMechanism +zonkDerivSpecMechanism mechanism = case mechanism of DerivSpecStock { dsm_stock_dit = dit , dsm_stock_gen_fns = gen_fns } -> do - dit' <- zonkDerivInstTys ze dit + dit' <- zonkDerivInstTys dit pure $ DerivSpecStock { dsm_stock_dit = dit' , dsm_stock_gen_fns = gen_fns } DerivSpecNewtype { dsm_newtype_dit = dit , dsm_newtype_rep_ty = rep_ty } -> do - dit' <- zonkDerivInstTys ze dit - rep_ty' <- zonkTcTypeToTypeX ze rep_ty + dit' <- zonkDerivInstTys dit + rep_ty' <- zonkTcTypeToTypeX rep_ty pure $ DerivSpecNewtype { dsm_newtype_dit = dit' , dsm_newtype_rep_ty = rep_ty' } @@ -337,9 +335,9 @@ , dsm_via_inst_ty = inst_ty , dsm_via_ty = via_ty } -> do - cls_tys' <- zonkTcTypesToTypesX ze cls_tys - inst_ty' <- zonkTcTypeToTypeX ze inst_ty - via_ty' <- zonkTcTypeToTypeX ze via_ty + cls_tys' <- zonkTcTypesToTypesX cls_tys + inst_ty' <- zonkTcTypeToTypeX inst_ty + via_ty' <- zonkTcTypeToTypeX via_ty pure $ DerivSpecVia { dsm_via_cls_tys = cls_tys' , dsm_via_inst_ty = inst_ty' , dsm_via_ty = via_ty' @@ -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 @@ -644,7 +650,7 @@ , sps_type_or_kind = t_or_k }) -substPredSpec :: HasCallStack => Subst -> PredSpec -> PredSpec +substPredSpec :: HasDebugCallStack => Subst -> PredSpec -> PredSpec substPredSpec subst ps = case ps of SimplePredSpec { sps_pred = pred @@ -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,2516 +1,2632 @@ - -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE ParallelListComp #-} -{-# LANGUAGE ScopedTypeVariables #-} - -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} -{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} - -module GHC.Tc.Errors( - reportUnsolved, reportAllUnsolved, warnAllUnsolved, - warnDefaulting, - - -- * GHC API helper functions - solverReportMsg_ExpectedActuals, - ) where - -import GHC.Prelude - -import GHC.Driver.Env (hsc_units) -import GHC.Driver.Session -import GHC.Driver.Ppr -import GHC.Driver.Config.Diagnostic - -import GHC.Rename.Unbound - -import GHC.Tc.Types -import GHC.Tc.Utils.Monad -import GHC.Tc.Errors.Types -import GHC.Tc.Errors.Ppr -import GHC.Tc.Types.Constraint -import GHC.Tc.Utils.TcMType -import GHC.Tc.Utils.Env( tcInitTidyEnv ) -import GHC.Tc.Utils.TcType -import GHC.Tc.Utils.Unify ( checkTyVarEq ) -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 GHC.Types.Name -import GHC.Types.Name.Reader ( lookupGRE_Name, GlobalRdrEnv, mkRdrUnqual - , emptyLocalRdrEnv, lookupGlobalRdrEnv , lookupLocalRdrOcc ) -import GHC.Types.Id -import GHC.Types.Var -import GHC.Types.Var.Set -import GHC.Types.Var.Env -import GHC.Types.Name.Env -import GHC.Types.SrcLoc -import GHC.Types.Basic -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 - -import GHC.Core.Predicate -import GHC.Core.Type -import GHC.Core.Coercion -import GHC.Core.TyCo.Ppr ( pprTyVars ) -import GHC.Core.InstEnv -import GHC.Core.TyCon -import GHC.Core.DataCon - -import GHC.Utils.Error (diagReasonSeverity, pprLocMsgEnvelope ) -import GHC.Utils.Misc -import GHC.Utils.Outputable as O -import GHC.Utils.Panic -import GHC.Utils.Panic.Plain -import GHC.Utils.FV ( fvVarList, unionFV ) - -import GHC.Data.Bag -import GHC.Data.List.SetOps ( equivClasses, nubOrdBy ) -import GHC.Data.Maybe -import qualified GHC.Data.Strict as Strict - -import Control.Monad ( unless, when, foldM, forM_ ) -import Data.Foldable ( toList ) -import Data.Function ( on ) -import Data.List ( partition, sort, sortBy ) -import Data.List.NonEmpty ( NonEmpty(..) ) -import qualified Data.List.NonEmpty as NE -import Data.Ord ( comparing ) -import qualified Data.Semigroup as S - -{- -************************************************************************ -* * -\section{Errors and contexts} -* * -************************************************************************ - -ToDo: for these error messages, should we note the location as coming -from the insts, or just whatever seems to be around in the monad just -now? - -Note [Deferring coercion errors to runtime] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -While developing, sometimes it is desirable to allow compilation to succeed even -if there are type errors in the code. Consider the following case: - - module Main where - - a :: Int - a = 'a' - - main = print "b" - -Even though `a` is ill-typed, it is not used in the end, so if all that we're -interested in is `main` it is handy to be able to ignore the problems in `a`. - -Since we treat type equalities as evidence, this is relatively simple. Whenever -we run into a type mismatch in GHC.Tc.Utils.Unify, we normally just emit an error. But it -is always safe to defer the mismatch to the main constraint solver. If we do -that, `a` will get transformed into - - co :: Int ~ Char - co = ... - - a :: Int - a = 'a' `cast` co - -The constraint solver would realize that `co` is an insoluble constraint, and -emit an error with `reportUnsolved`. But we can also replace the right-hand side -of `co` with `error "Deferred type error: Int ~ Char"`. This allows the program -to compile, and it will run fine unless we evaluate `a`. This is what -`deferErrorsToRuntime` does. - -It does this by keeping track of which errors correspond to which coercion -in GHC.Tc.Errors. GHC.Tc.Errors.reportTidyWanteds does not print the errors -and does not fail if -fdefer-type-errors is on, so that we can continue -compilation. The errors are turned into warnings in `reportUnsolved`. --} - --- | Report unsolved goals as errors or warnings. We may also turn some into --- deferred run-time errors if `-fdefer-type-errors` is on. -reportUnsolved :: WantedConstraints -> TcM (Bag EvBind) -reportUnsolved wanted - = do { binds_var <- newTcEvBinds - ; defer_errors <- goptM Opt_DeferTypeErrors - ; let type_errors | not defer_errors = ErrorWithoutFlag - | otherwise = WarningWithFlag Opt_WarnDeferredTypeErrors - - ; defer_holes <- goptM Opt_DeferTypedHoles - ; let expr_holes | not defer_holes = ErrorWithoutFlag - | otherwise = WarningWithFlag Opt_WarnTypedHoles - - ; partial_sigs <- xoptM LangExt.PartialTypeSignatures - ; let type_holes | not partial_sigs - = ErrorWithoutFlag - | otherwise - = WarningWithFlag Opt_WarnPartialTypeSignatures - - ; defer_out_of_scope <- goptM Opt_DeferOutOfScopeVariables - ; let out_of_scope_holes | not defer_out_of_scope - = ErrorWithoutFlag - | otherwise - = WarningWithFlag Opt_WarnDeferredOutOfScopeVariables - - ; report_unsolved type_errors expr_holes - type_holes out_of_scope_holes - binds_var wanted - - ; ev_binds <- getTcEvBindsMap binds_var - ; return (evBindMapBinds ev_binds)} - --- | Report *all* unsolved goals as errors, even if -fdefer-type-errors is on --- However, do not make any evidence bindings, because we don't --- have any convenient place to put them. --- NB: Type-level holes are OK, because there are no bindings. --- See Note [Deferring coercion errors to runtime] --- Used by solveEqualities for kind equalities --- (see Note [Failure in local type signatures] in GHC.Tc.Solver) -reportAllUnsolved :: WantedConstraints -> TcM () -reportAllUnsolved wanted - = do { ev_binds <- newNoTcEvBinds - - ; partial_sigs <- xoptM LangExt.PartialTypeSignatures - ; let type_holes | not partial_sigs = ErrorWithoutFlag - | otherwise = WarningWithFlag Opt_WarnPartialTypeSignatures - - ; report_unsolved ErrorWithoutFlag - ErrorWithoutFlag type_holes ErrorWithoutFlag - ev_binds wanted } - --- | Report all unsolved goals as warnings (but without deferring any errors to --- run-time). See Note [Safe Haskell Overlapping Instances Implementation] in --- "GHC.Tc.Solver" -warnAllUnsolved :: WantedConstraints -> TcM () -warnAllUnsolved wanted - = do { ev_binds <- newTcEvBinds - ; report_unsolved WarningWithoutFlag - WarningWithoutFlag - WarningWithoutFlag - WarningWithoutFlag - ev_binds wanted } - --- | Report unsolved goals as errors or warnings. -report_unsolved :: DiagnosticReason -- Deferred type errors - -> DiagnosticReason -- Expression holes - -> DiagnosticReason -- Type holes - -> DiagnosticReason -- Out of scope holes - -> EvBindsVar -- cec_binds - -> WantedConstraints -> TcM () -report_unsolved type_errors expr_holes - type_holes out_of_scope_holes binds_var wanted - | isEmptyWC wanted - = return () - | otherwise - = do { traceTc "reportUnsolved {" $ - vcat [ text "type errors:" <+> ppr type_errors - , text "expr holes:" <+> ppr expr_holes - , text "type holes:" <+> ppr type_holes - , text "scope holes:" <+> ppr out_of_scope_holes ] - ; traceTc "reportUnsolved (before zonking and tidying)" (ppr wanted) - - ; wanted <- zonkWC wanted -- Zonk to reveal all information - - ; let tidy_env = tidyFreeTyCoVars emptyTidyEnv free_tvs - free_tvs = filterOut isCoVar $ - tyCoVarsOfWCList wanted - -- tyCoVarsOfWC returns free coercion *holes*, even though - -- they are "bound" by other wanted constraints. They in - -- turn may mention variables bound further in, which makes - -- no sense. Really we should not return those holes at all; - -- for now we just filter them out. - - ; traceTc "reportUnsolved (after zonking):" $ - vcat [ text "Free tyvars:" <+> pprTyVars free_tvs - , text "Tidy env:" <+> ppr tidy_env - , text "Wanted:" <+> ppr wanted ] - - ; warn_redundant <- woptM Opt_WarnRedundantConstraints - ; exp_syns <- goptM Opt_PrintExpandedSynonyms - ; let err_ctxt = CEC { cec_encl = [] - , cec_tidy = tidy_env - , cec_defer_type_errors = type_errors - , cec_expr_holes = expr_holes - , cec_type_holes = type_holes - , cec_out_of_scope_holes = out_of_scope_holes - , cec_suppress = insolubleWC wanted - -- See Note [Suppressing error messages] - -- Suppress low-priority errors if there - -- are insoluble errors anywhere; - -- See #15539 and c.f. setting ic_status - -- in GHC.Tc.Solver.setImplicationStatus - , cec_warn_redundant = warn_redundant - , cec_expand_syns = exp_syns - , cec_binds = binds_var } - - ; tc_lvl <- getTcLevel - ; reportWanteds err_ctxt tc_lvl wanted - ; traceTc "reportUnsolved }" empty } - --------------------------------------------- --- Internal functions --------------------------------------------- - --- | Make a report from a single 'TcSolverReportMsg'. -important :: SolverReportErrCtxt -> TcSolverReportMsg -> SolverReport -important ctxt doc - = SolverReport { sr_important_msg = SolverReportWithCtxt ctxt doc - , sr_supplementary = [] - , sr_hints = [] } - -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 -deferringAnyBindings (CEC { cec_defer_type_errors = ErrorWithoutFlag - , cec_expr_holes = ErrorWithoutFlag - , cec_out_of_scope_holes = ErrorWithoutFlag }) = False -deferringAnyBindings _ = True - -maybeSwitchOffDefer :: EvBindsVar -> SolverReportErrCtxt -> SolverReportErrCtxt --- Switch off defer-type-errors inside CoEvBindsVar --- See Note [Failing equalities with no evidence bindings] -maybeSwitchOffDefer evb ctxt - | CoEvBindsVar{} <- evb - = ctxt { cec_defer_type_errors = ErrorWithoutFlag - , cec_expr_holes = ErrorWithoutFlag - , cec_out_of_scope_holes = ErrorWithoutFlag } - | otherwise - = ctxt - -{- Note [Failing equalities with no evidence bindings] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -If we go inside an implication that has no term evidence -(e.g. unifying under a forall), we can't defer type errors. You could -imagine using the /enclosing/ bindings (in cec_binds), but that may -not have enough stuff in scope for the bindings to be well typed. So -we just switch off deferred type errors altogether. See #14605. - -This is done by maybeSwitchOffDefer. It's also useful in one other -place: see Note [Wrapping failing kind equalities] in GHC.Tc.Solver. - -Note [Suppressing error messages] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The cec_suppress flag says "don't report any errors". Instead, just create -evidence bindings (as usual). It's used when more important errors have occurred. - -Specifically (see reportWanteds) - * If there are insoluble Givens, then we are in unreachable code and all bets - are off. So don't report any further errors. - * If there are any insolubles (eg Int~Bool), here or in a nested implication, - then suppress errors from the simple constraints here. Sometimes the - simple-constraint errors are a knock-on effect of the insolubles. - -This suppression behaviour is controlled by the Bool flag in -ReportErrorSpec, as used in reportWanteds. - -But we need to take care: flags can turn errors into warnings, and we -don't want those warnings to suppress subsequent errors (including -suppressing the essential addTcEvBind for them: #15152). So in -tryReporter we use askNoErrs to see if any error messages were -/actually/ produced; if not, we don't switch on suppression. - -A consequence is that warnings never suppress warnings, so turning an -error into a warning may allow subsequent warnings to appear that were -previously suppressed. (e.g. partial-sigs/should_fail/T14584) --} - -reportImplic :: SolverReportErrCtxt -> Implication -> TcM () -reportImplic ctxt implic@(Implic { ic_skols = tvs - , ic_given = given - , ic_wanted = wanted, ic_binds = evb - , ic_status = status, ic_info = info - , ic_env = tcl_env - , ic_tclvl = tc_lvl }) - | BracketSkol <- info - , not insoluble - = return () -- For Template Haskell brackets report only - -- definite errors. The whole thing will be re-checked - -- later when we plug it in, and meanwhile there may - -- certainly be un-satisfied constraints - - | otherwise - = do { traceTc "reportImplic" $ vcat - [ text "tidy env:" <+> ppr (cec_tidy ctxt) - , text "skols: " <+> pprTyVars tvs - , text "tidy skols:" <+> pprTyVars tvs' ] - - ; when bad_telescope $ reportBadTelescope ctxt tcl_env info tvs - -- Do /not/ use the tidied tvs because then are in the - -- wrong order, so tidying will rename things wrongly - ; reportWanteds ctxt' tc_lvl wanted - - -- Report redundant (unused) constraints - ; warnRedundantConstraints ctxt' tcl_env info' dead_givens } - where - insoluble = isInsolubleStatus status - (env1, tvs') = tidyVarBndrs (cec_tidy ctxt) $ - scopedSort tvs - -- scopedSort: the ic_skols may not be in dependency order - -- (see Note [Skolems in an implication] in GHC.Tc.Types.Constraint) - -- but tidying goes wrong on out-of-order constraints; - -- so we sort them here before tidying - info' = tidySkolemInfoAnon env1 info - implic' = implic { ic_skols = tvs' - , ic_given = map (tidyEvVar env1) given - , ic_info = info' } - - ctxt1 = maybeSwitchOffDefer evb ctxt - ctxt' = ctxt1 { cec_tidy = env1 - , cec_encl = implic' : cec_encl ctxt - - , cec_suppress = insoluble || cec_suppress ctxt - -- Suppress inessential errors if there - -- are insolubles anywhere in the - -- tree rooted here, or we've come across - -- a suppress-worthy constraint higher up (#11541) - - , cec_binds = evb } - - dead_givens = case status of - IC_Solved { ics_dead = dead } -> dead - _ -> [] - - bad_telescope = case status of - IC_BadTelescope -> True - _ -> False - -warnRedundantConstraints :: SolverReportErrCtxt -> TcLclEnv -> SkolemInfoAnon -> [EvVar] -> TcM () --- See Note [Tracking redundant constraints] in GHC.Tc.Solver -warnRedundantConstraints ctxt env info redundant_evs - | not (cec_warn_redundant ctxt) - = return () - - | 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". - = restoreLclEnv env $ - setSrcSpan (redundantConstraintsSpan user_ctxt) $ - report_redundant_msg True - -- ^^^^ add "In the type signature..." - - | otherwise - -- But for InstSkol there already *is* a surrounding - -- "In the instance declaration for Eq [a]" context - -- and we don't want to say it twice. Seems a bit ad-hoc - = restoreLclEnv env - $ report_redundant_msg False - -- ^^^^^ don't add "In the type signature..." - where - report_redundant_msg :: Bool -- whether to add "In the type signature..." to the diagnostic - -> TcRn () - report_redundant_msg show_info - = do { lcl_env <- getLclEnv - ; msg <- - mkErrorReport - lcl_env - (TcRnRedundantConstraints redundant_evs (info, show_info)) - (Just ctxt) - [] - ; reportDiagnostic msg } - -reportBadTelescope :: SolverReportErrCtxt -> TcLclEnv -> SkolemInfoAnon -> [TcTyVar] -> TcM () -reportBadTelescope ctxt env (ForAllSkol telescope) skols - = do { msg <- mkErrorReport - env - (TcRnSolverReport report ErrorWithoutFlag noHints) - (Just ctxt) - [] - ; reportDiagnostic msg } - where - report = SolverReportWithCtxt ctxt $ BadTelescope telescope skols - -reportBadTelescope _ _ skol_info skols - = pprPanic "reportBadTelescope" (ppr skol_info $$ ppr skols) - --- | Should we completely ignore this constraint in error reporting? --- It *must* be the case that any constraint for which this returns True --- somehow causes an error to be reported elsewhere. --- See Note [Constraints to ignore]. -ignoreConstraint :: Ct -> Bool -ignoreConstraint ct - | AssocFamPatOrigin <- ctOrigin ct - = True - | otherwise - = False - --- | Makes an error item from a constraint, calculating whether or not --- the item should be suppressed. See Note [Wanteds rewrite Wanteds] --- in GHC.Tc.Types.Constraint. Returns Nothing if we should just ignore --- a constraint. See Note [Constraints to ignore]. -mkErrorItem :: Ct -> TcM (Maybe ErrorItem) -mkErrorItem ct - | ignoreConstraint ct - = do { traceTc "Ignoring constraint:" (ppr ct) - ; return Nothing } -- See Note [Constraints to ignore] - - | otherwise - = do { let loc = ctLoc ct - flav = ctFlavour ct - - ; (suppress, m_evdest) <- case ctEvidence ct of - CtGiven {} -> return (False, Nothing) - CtWanted { ctev_rewriters = rewriters, ctev_dest = dest } - -> do { supp <- anyUnfilledCoercionHoles rewriters - ; return (supp, Just dest) } - - ; let m_reason = case ct of CIrredCan { cc_reason = reason } -> Just reason - _ -> Nothing - - ; return $ Just $ EI { ei_pred = ctPred ct - , ei_evdest = m_evdest - , ei_flavour = flav - , ei_loc = loc - , ei_m_reason = m_reason - , ei_suppress = suppress }} - --- | Actually report this 'ErrorItem'. -unsuppressErrorItem :: ErrorItem -> ErrorItem -unsuppressErrorItem ei = ei { ei_suppress = False } - ----------------------------------------------------------------- -reportWanteds :: SolverReportErrCtxt -> TcLevel -> WantedConstraints -> TcM () -reportWanteds ctxt tc_lvl wc@(WC { wc_simple = simples, wc_impl = implics - , wc_errors = errs }) - | isEmptyWC wc = traceTc "reportWanteds empty WC" empty - | otherwise - = do { tidy_items1 <- mapMaybeM mkErrorItem tidy_cts - ; traceTc "reportWanteds 1" (vcat [ text "Simples =" <+> ppr simples - , text "Suppress =" <+> ppr (cec_suppress ctxt) - , text "tidy_cts =" <+> ppr tidy_cts - , text "tidy_items1 =" <+> ppr tidy_items1 - , text "tidy_errs =" <+> ppr tidy_errs ]) - - -- Catch an awkward case in which /all/ errors are suppressed: - -- see Wrinkle at end of Note [Wanteds rewrite Wanteds] in GHC.Tc.Types.Constraint - -- Unless we are sure that an error will be reported some other way (details - -- in the defn of tidy_items) un-suppress the lot. This makes sure we don't forget to - -- report an error at all, which is catastrophic: GHC proceeds to desguar and optimise - -- the program, even though it is full of type errors (#22702, #22793) - ; errs_already <- ifErrsM (return True) (return False) - ; let tidy_items - | not errs_already -- Have not already reported an error (perhaps - -- from an outer implication); see #21405 - , not (any ignoreConstraint simples) -- No error is ignorable (is reported elsewhere) - , all ei_suppress tidy_items1 -- All errors are suppressed - = map unsuppressErrorItem tidy_items1 - | otherwise = tidy_items1 - - -- First, deal with any out-of-scope errors: - ; let (out_of_scope, other_holes, not_conc_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 $ - reportHoles tidy_items ctxt_for_scope_errs out_of_scope - - -- Next, deal with things that are utterly wrong - -- Like Int ~ Bool (incl nullary TyCons) - -- or Int ~ t a (AppTy on one side) - -- These /ones/ are not suppressed by the incoming context - -- (but will be by out-of-scope errors) - ; let ctxt_for_insols = ctxt { cec_suppress = not no_out_of_scope } - ; reportHoles tidy_items ctxt_for_insols other_holes - -- holes never suppress - - ; reportNotConcreteErrs ctxt_for_insols not_conc_errs - - -- See Note [Suppressing confusing errors] - ; let (suppressed_items, items0) = partition suppress tidy_items - ; traceTc "reportWanteds suppressed:" (ppr suppressed_items) - ; (ctxt1, items1) <- tryReporters ctxt_for_insols report1 items0 - - -- 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 - ; massertPpr (null leftovers) - (text "The following unsolved Wanted constraints \ - \have not been reported to the user:" - $$ ppr leftovers) - - ; mapBagM_ (reportImplic ctxt2) implics - -- NB ctxt2: don't suppress inner insolubles if there's only a - -- 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 - ; 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 - - -- report1: ones that should *not* be suppressed by - -- an insoluble somewhere else in the tree - -- It's crucial that anything that is considered insoluble - -- (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) - - , 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) - , ("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.Canonical - , ("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) - ] - - -- rigid_nom_eq, rigid_nom_tv_eq, - is_dict, is_equality, is_ip, is_FRR, is_irred :: ErrorItem -> Pred -> Bool - - is_given_eq item pred - | Given <- ei_flavour item - , EqPred {} <- pred = True - | otherwise = False - -- I think all given residuals are equalities - - -- Things like (Int ~N Bool) - utterly_wrong _ (EqPred NomEq ty1 ty2) = isRigidTy ty1 && isRigidTy ty2 - utterly_wrong _ _ = False - - -- Things like (a ~N Int) - very_wrong _ (EqPred NomEq ty1 ty2) = isSkolemTy tc_lvl ty1 && isRigidTy ty2 - very_wrong _ _ = False - - -- Representation-polymorphism errors, to be reported using mkFRRErr. - is_FRR item _ = isJust $ fixedRuntimeRepOrigin_maybe item - - -- Things like (a ~N b) or (a ~N F Bool) - skolem_eq _ (EqPred NomEq ty1 _) = isSkolemTy tc_lvl ty1 - skolem_eq _ _ = False - - -- Things like (F a ~N Int) - non_tv_eq _ (EqPred NomEq ty1 _) = not (isTyVarTy ty1) - non_tv_eq _ _ = False - - is_user_type_error item _ = isUserTypeError (errorItemPred item) - - is_homo_equality _ (EqPred _ ty1 ty2) - = typeKind ty1 `tcEqType` typeKind ty2 - is_homo_equality _ _ - = False - - is_equality _(EqPred {}) = True - is_equality _ _ = False - - is_dict _ (ClassPred {}) = True - is_dict _ _ = False - - is_ip _ (ClassPred cls _) = isIPClass cls - is_ip _ _ = False - - 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 - - given_eq_spec -- See Note [Given errors] - | has_gadt_match_here - = ("insoluble1a", is_given_eq, True, mkGivenErrorReporter) - | otherwise - = ("insoluble1b", is_given_eq, False, ignoreErrorReporter) - -- False means don't suppress subsequent errors - -- Reason: we don't report all given errors - -- (see mkGivenErrorReporter), and we should only suppress - -- subsequent errors if we actually report this one! - -- #13446 is an example - - -- See Note [Given errors] - has_gadt_match_here = has_gadt_match (cec_encl ctxt) - has_gadt_match [] = False - has_gadt_match (implic : implics) - | PatSkol {} <- ic_info implic - , ic_given_eqs implic /= NoGivenEqs - , ic_warn_inaccessible implic - -- Don't bother doing this if -Winaccessible-code isn't enabled. - -- See Note [Avoid -Winaccessible-code when deriving] in GHC.Tc.TyCl.Instance. - = True - | otherwise - = has_gadt_match implics - ---------------- -isSkolemTy :: TcLevel -> Type -> Bool --- The type is a skolem tyvar -isSkolemTy tc_lvl ty - | Just tv <- getTyVar_maybe ty - = isSkolemTyVar tv - || (isTyVarTyVar tv && isTouchableMetaTyVar tc_lvl tv) - -- The last case is for touchable TyVarTvs - -- we postpone untouchables to a latter test (too obscure) - - | otherwise - = False - -isTyFun_maybe :: Type -> Maybe TyCon -isTyFun_maybe ty = case tcSplitTyConApp_maybe ty of - Just (tc,_) | isTypeFamilyTyCon tc -> Just tc - _ -> Nothing - -{- Note [Suppressing confusing errors] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -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): - -1) Errors which arise from the interaction of two Wanted fun-dep constraints. - Example: - - class C a b | a -> b where - op :: a -> b -> b - - foo _ = op True Nothing - - bar _ = op False [] - - Here, we could infer - foo :: C Bool (Maybe a) => p -> Maybe a - bar :: C Bool [a] => p -> [a] - - (The unused arguments suppress the monomorphism restriction.) The problem - is that these types can't both be correct, as they violate the functional - dependency. Yet reporting an error here is awkward: we must - non-deterministically choose either foo or bar to reject. We thus want - to report this problem only when there is nothing else to report. - See typecheck/should_fail/T13506 for an example of when to suppress - the error. The case above is actually accepted, because foo and bar - are checked separately, and thus the two fundep constraints never - encounter each other. It is test case typecheck/should_compile/FunDepOrigin1. - - This case applies only when both fundeps are *Wanted* fundeps; when - both are givens, the error represents unreachable code. For - a Given/Wanted case, see #9612. - -Mechanism: - -We use the `suppress` function within reportWanteds to filter out these two -cases, then report all other errors. Lastly, we return to these suppressed -ones and report them only if there have been no errors so far. - -Note [Constraints to ignore] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Some constraints are meant only to aid the solver by unification; a failure -to solve them is not necessarily an error to report to the user. It is critical -that compilation is aborted elsewhere if there are any ignored constraints here; -they will remain unfilled, and might have been used to rewrite another constraint. - -Currently, the constraints to ignore are: - -1) Constraints generated in order to unify associated type instance parameters - with class parameters. Here are two illustrative examples: - - class C (a :: k) where - type F (b :: k) - - instance C True where - type F a = Int - - instance C Left where - type F (Left :: a -> Either a b) = Bool - - In the first instance, we want to infer that `a` has type Bool. So we emit - a constraint unifying kappa (the guessed type of `a`) with Bool. All is well. - - In the second instance, we process the associated type instance only - after fixing the quantified type variables of the class instance. We thus - have skolems a1 and b1 such that the class instance is for (Left :: a1 -> Either a1 b1). - Unifying a1 and b1 with a and b in the type instance will fail, but harmlessly so. - checkConsistentFamInst checks for this, and will fail if anything has gone - awry. Really the equality constraints emitted are just meant as an aid, not - a requirement. This is test case T13972. - - We detect this case by looking for an origin of AssocFamPatOrigin; constraints - with this origin are dropped entirely during error message reporting. - - If there is any trouble, checkValidFamInst bleats, aborting compilation. - --} - - - --------------------------------------------- --- Reporters --------------------------------------------- - -type Reporter - = SolverReportErrCtxt -> [ErrorItem] -> TcM () -type ReporterSpec - = ( String -- Name - , ErrorItem -> Pred -> Bool -- Pick these ones - , Bool -- True <=> suppress subsequent reporters - , Reporter) -- The reporter itself - -mkSkolReporter :: Reporter --- Suppress duplicates with either the same LHS, or same location --- Pre-condition: all items are equalities -mkSkolReporter ctxt items - = mapM_ (reportGroup mkEqErr ctxt) (group items) - where - group [] = [] - group (item:items) = (item : yeses) : group noes - where - (yeses, noes) = partition (group_with item) items - - group_with item1 item2 - | EQ <- cmp_loc item1 item2 = True - | eq_lhs_type item1 item2 = True - | otherwise = False - -reportHoles :: [ErrorItem] -- other (tidied) constraints - -> SolverReportErrCtxt -> [Hole] -> TcM () -reportHoles tidy_items ctxt holes - = do - diag_opts <- initDiagOpts <$> getDynFlags - let severity = diagReasonSeverity diag_opts (cec_type_holes ctxt) - holes' = filter (keepThisHole severity) holes - -- Zonk and tidy all the TcLclEnvs before calling `mkHoleError` - -- because otherwise types will be zonked and tidied many times over. - (tidy_env', lcl_name_cache) <- zonkTidyTcLclEnvs (cec_tidy ctxt) (map (ctl_env . hole_loc) holes') - let ctxt' = ctxt { cec_tidy = tidy_env' } - forM_ holes' $ \hole -> do { msg <- mkHoleError lcl_name_cache tidy_items ctxt' hole - ; reportDiagnostic msg } - -keepThisHole :: Severity -> Hole -> Bool --- See Note [Skip type holes rapidly] -keepThisHole sev hole - = case hole_sort hole of - ExprHole {} -> True - TypeHole -> keep_type_hole - ConstraintHole -> keep_type_hole - where - keep_type_hole = case sev of - SevIgnore -> False - _ -> True - --- | zonkTidyTcLclEnvs takes a bunch of 'TcLclEnv's, each from a Hole. --- It returns a ('Name' :-> 'Type') mapping which gives the zonked, tidied --- type for each Id in any of the binder stacks in the 'TcLclEnv's. --- Since there is a huge overlap between these stacks, is is much, --- much faster to do them all at once, avoiding duplication. -zonkTidyTcLclEnvs :: TidyEnv -> [TcLclEnv] -> TcM (TidyEnv, NameEnv Type) -zonkTidyTcLclEnvs tidy_env lcls = foldM go (tidy_env, emptyNameEnv) (concatMap tcl_bndrs lcls) - where - go envs tc_bndr = case tc_bndr of - TcTvBndr {} -> return envs - TcIdBndr id _top_lvl -> go_one (idName id) (idType id) envs - TcIdBndr_ExpType name et _top_lvl -> - do { mb_ty <- readExpType_maybe et - -- et really should be filled in by now. But there's a chance - -- it hasn't, if, say, we're reporting a kind error en route to - -- checking a term. See test indexed-types/should_fail/T8129 - -- Or we are reporting errors from the ambiguity check on - -- a local type signature - ; case mb_ty of - Just ty -> go_one name ty envs - Nothing -> return envs - } - go_one name ty (tidy_env, name_env) = do - if name `elemNameEnv` name_env - then return (tidy_env, name_env) - else do - (tidy_env', tidy_ty) <- zonkTidyTcType tidy_env ty - return (tidy_env', extendNameEnv name_env name tidy_ty) - -reportNotConcreteErrs :: SolverReportErrCtxt -> [NotConcreteError] -> TcM () -reportNotConcreteErrs _ [] = return () -reportNotConcreteErrs ctxt errs@(err0:_) - = do { msg <- mkErrorReport (ctLocEnv (nce_loc err0)) diag (Just ctxt) [] - ; reportDiagnostic msg } - - where - - frr_origins = acc_errors errs - diag = TcRnSolverReport - (SolverReportWithCtxt ctxt (FixedRuntimeRepError frr_origins)) - ErrorWithoutFlag noHints - - -- Accumulate the different kind of errors arising from syntactic equality. - -- (Only SynEq_FRR origin for the moment.) - acc_errors = go [] - where - go frr_errs [] = frr_errs - go frr_errs (err:errs) - | frr_errs <- go frr_errs errs - = case err of - NCE_FRR - { nce_frr_origin = frr_orig - , nce_reasons = _not_conc } -> - FRR_Info - { frr_info_origin = frr_orig - , frr_info_not_concrete = Nothing } - : frr_errs - -{- Note [Skip type holes rapidly] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose we have module with a /lot/ of partial type signatures, and we -compile it while suppressing partial-type-signature warnings. Then -we don't want to spend ages constructing error messages and lists of -relevant bindings that we never display! This happened in #14766, in -which partial type signatures in a Happy-generated parser cause a huge -increase in compile time. - -The function ignoreThisHole short-circuits the error/warning generation -machinery, in cases where it is definitely going to be a no-op. --} - -mkUserTypeErrorReporter :: Reporter -mkUserTypeErrorReporter ctxt - = mapM_ $ \item -> do { let err = important ctxt $ mkUserTypeError item - ; maybeReportError ctxt [item] err - ; addDeferredBinding ctxt err item } - -mkUserTypeError :: ErrorItem -> TcSolverReportMsg -mkUserTypeError item = - case getUserTypeErrorMsg (errorItemPred item) of - Just msg -> UserTypeError msg - Nothing -> pprPanic "mkUserTypeError" (ppr item) - -mkGivenErrorReporter :: Reporter --- See Note [Given errors] -mkGivenErrorReporter ctxt items - = do { (ctxt, relevant_binds, item) <- relevantBindings True ctxt item - ; let (implic:_) = cec_encl ctxt - -- Always non-empty when mkGivenErrorReporter is called - 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 - ; reportDiagnostic msg } - where - (item : _ ) = items -- Never empty - (ty1, ty2) = getEqPredTys (errorItemPred item) - -ignoreErrorReporter :: Reporter --- Discard Given errors that don't come from --- a pattern match; maybe we should warn instead? -ignoreErrorReporter ctxt items - = do { traceTc "mkGivenErrorReporter no" (ppr items $$ ppr (cec_encl ctxt)) - ; return () } - - -{- Note [Given errors] -~~~~~~~~~~~~~~~~~~~~~~ -Given constraints represent things for which we have (or will have) -evidence, so they aren't errors. But if a Given constraint is -insoluble, this code is inaccessible, and we might want to at least -warn about that. A classic case is - - data T a where - T1 :: T Int - T2 :: T a - T3 :: T Bool - - f :: T Int -> Bool - f T1 = ... - f T2 = ... - f T3 = ... -- We want to report this case as inaccessible - -We'd like to point out that the T3 match is inaccessible. It -will have a Given constraint [G] Int ~ Bool. - -But we don't want to report ALL insoluble Given constraints. See Trac -#12466 for a long discussion. For example, if we aren't careful -we'll complain about - f :: ((Int ~ Bool) => a -> a) -> Int -which arguably is OK. It's more debatable for - g :: (Int ~ Bool) => Int -> Int -but it's tricky to distinguish these cases so we don't report -either. - -The bottom line is this: has_gadt_match looks for an enclosing -pattern match which binds some equality constraints. If we -find one, we report the insoluble Given. --} - -mkGroupReporter :: (SolverReportErrCtxt -> [ErrorItem] -> TcM SolverReport) - -- Make error message for a group - -> Reporter -- Deal with lots of constraints --- 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 . toList) (equivClasses cmp_loc items) - -eq_lhs_type :: ErrorItem -> ErrorItem -> Bool -eq_lhs_type item1 item2 - = case (classifyPredType (errorItemPred item1), classifyPredType (errorItemPred item2)) of - (EqPred eq_rel1 ty1 _, EqPred eq_rel2 ty2 _) -> - (eq_rel1 == eq_rel2) && (ty1 `eqType` ty2) - _ -> pprPanic "mkSkolReporter" (ppr item1 $$ ppr item2) - -cmp_loc :: ErrorItem -> ErrorItem -> Ordering -cmp_loc item1 item2 = get item1 `compare` get item2 - where - get ei = realSrcSpanStart (ctLocSpan (errorItemCtLoc ei)) - -- Reduce duplication by reporting only one error from each - -- /starting/ location even if the end location differs - -reportGroup :: (SolverReportErrCtxt -> [ErrorItem] -> TcM SolverReport) -> Reporter -reportGroup mk_err ctxt items - = do { err <- mk_err ctxt items - ; traceTc "About to maybeReportErr" $ - vcat [ text "Constraint:" <+> ppr items - , text "cec_suppress =" <+> ppr (cec_suppress ctxt) - , text "cec_defer_type_errors =" <+> ppr (cec_defer_type_errors ctxt) ] - ; maybeReportError ctxt items err - -- But see Note [Always warn with -fdefer-type-errors] - ; traceTc "reportGroup" (ppr items) - ; mapM_ (addDeferredBinding ctxt 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 - -- abort, we need bindings for all (e.g. #12156) - --- See Note [No deferring for multiplicity errors] -nonDeferrableOrigin :: CtOrigin -> Bool -nonDeferrableOrigin NonLinearPatternOrigin = True -nonDeferrableOrigin (UsageEnvironmentOf {}) = True -nonDeferrableOrigin (FRROrigin {}) = True -nonDeferrableOrigin _ = False - -maybeReportError :: SolverReportErrCtxt - -> [ErrorItem] -- items covered by the Report - -> SolverReport -> TcM () -maybeReportError ctxt items@(item1:_) (SolverReport { sr_important_msg = important - , sr_supplementary = supp - , sr_hints = hints }) - = unless (cec_suppress ctxt -- Some worse error has occurred, so suppress this diagnostic - || all ei_suppress items) $ - -- if they're all to be suppressed, report nothing - -- if at least one is not suppressed, do report: - -- the function that generates the error message - -- should look for an unsuppressed error item - 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 - reportDiagnostic msg -maybeReportError _ _ _ = panic "maybeReportError" - -addDeferredBinding :: SolverReportErrCtxt -> SolverReport -> 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 - | deferringAnyBindings ctxt - = do { err_tm <- mkErrorTerm ctxt loc item_ty err - ; let ev_binds_var = cec_binds ctxt - - ; case dest of - EvVarDest evar - -> addTcEvBind ev_binds_var $ mkWantedEvBind evar err_tm - HoleDest hole - -> do { -- See Note [Deferred errors for coercion holes] - let co_var = coHoleCoVar hole - ; addTcEvBind ev_binds_var $ mkWantedEvBind co_var err_tm - ; fillCoercionHole hole (mkCoVarCo co_var) } } -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 }) - = do { msg <- mkErrorReport - (ctLocEnv ct_loc) - (TcRnSolverReport important ErrorWithoutFlag noHints) (Just ctxt) supp - -- 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 - err_str = showSDoc dflags $ - err_msg $$ text "(deferred type error)" - - ; return $ evDelayedError ty err_str } - -tryReporters :: SolverReportErrCtxt -> [ReporterSpec] -> [ErrorItem] -> TcM (SolverReportErrCtxt, [ErrorItem]) --- Use the first reporter in the list whose predicate says True -tryReporters ctxt reporters items - = do { let (vis_items, invis_items) - = partition (isVisibleOrigin . errorItemOrigin) items - ; traceTc "tryReporters {" (ppr vis_items $$ ppr invis_items) - ; (ctxt', items') <- go ctxt reporters vis_items invis_items - ; traceTc "tryReporters }" (ppr items') - ; return (ctxt', items') } - where - go ctxt [] vis_items invis_items - = return (ctxt, vis_items ++ invis_items) - - go ctxt (r : rs) vis_items invis_items - -- always look at *visible* Origins before invisible ones - -- this is the whole point of isVisibleOrigin - = do { (ctxt', vis_items') <- tryReporter ctxt r vis_items - ; (ctxt'', invis_items') <- tryReporter ctxt' r invis_items - ; go ctxt'' rs vis_items' invis_items' } - -- Carry on with the rest, because we must make - -- deferred bindings for them if we have -fdefer-type-errors - -- But suppress their error messages - -tryReporter :: SolverReportErrCtxt -> ReporterSpec -> [ErrorItem] -> TcM (SolverReportErrCtxt, [ErrorItem]) -tryReporter ctxt (str, keep_me, suppress_after, reporter) items - | null yeses - = return (ctxt, items) - | otherwise - = do { traceTc "tryReporter{ " (text str <+> ppr yeses) - ; (_, no_errs) <- askNoErrs (reporter ctxt yeses) - ; let suppress_now = not no_errs && suppress_after - -- See Note [Suppressing error messages] - ctxt' = ctxt { cec_suppress = suppress_now || cec_suppress ctxt } - ; traceTc "tryReporter end }" (text str <+> ppr (cec_suppress ctxt) <+> ppr suppress_after) - ; return (ctxt', nos) } - where - (yeses, nos) = partition keep items - keep item = keep_me item (classifyPredType (errorItemPred item)) - --- | Wrap an input 'TcRnMessage' with additional contextual information, --- such as relevant bindings or valid hole fits. -mkErrorReport :: TcLclEnv - -> TcRnMessage - -- ^ The main payload of the message. - -> Maybe SolverReportErrCtxt - -- ^ The context to add, after the main diagnostic - -- but before the supplementary information. - -- Nothing <=> don't add any context. - -> [SolverReportSupplementary] - -- ^ Supplementary information, to be added at the end of the message. - -> TcM (MsgEnvelope TcRnMessage) -mkErrorReport tcl_env msg mb_ctxt supplementary - = do { mb_context <- traverse (\ ctxt -> mkErrInfo (cec_tidy ctxt) (tcl_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 - ; mkTcRnMessage - (RealSrcSpan (tcl_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 -if cec_suppress is on. This can lead to a lot more warnings than you -would get errors without -fdefer-type-errors, but if we suppress any of -them you might get a runtime error that wasn't warned about at compile -time. - -To be consistent, we should also report multiple warnings from a single -location in mkGroupReporter, when -fdefer-type-errors is on. But that -is perhaps a bit *over*-consistent! - -With #10283, you can now opt out of deferred type error warnings. - -Note [No deferring for multiplicity errors] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -As explained in Note [Wrapper returned from tcSubMult] in GHC.Tc.Utils.Unify, -linear types do not support casts and any nontrivial coercion will raise -an error during desugaring. - -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. - -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 -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. -This plan is tracked in #20083. - -Note [Deferred errors for coercion holes] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose we need to defer a type error where the destination for the evidence -is a coercion hole. We can't just put the error in the hole, because we can't -make an erroneous coercion. (Remember that coercions are erased for runtime.) -Instead, we invent a new EvVar, bind it to an error and then make a coercion -from that EvVar, filling the hole with that coercion. Because coercions' -types are unlifted, the error is guaranteed to be hit before we get to the -coercion. - -************************************************************************ -* * - Irreducible predicate errors -* * -************************************************************************ --} - -mkIrredErr :: SolverReportErrCtxt -> [ErrorItem] -> TcM SolverReport -mkIrredErr ctxt items - = do { (ctxt, binds, item1) <- relevantBindings True ctxt item1 - ; let msg = important ctxt $ mkPlainMismatchMsg $ - CouldNotDeduce (getUserGivens ctxt) (item1 :| others) Nothing - ; return $ add_relevant_bindings binds msg } - where - (item1:others) = final_items - - filtered_items = filter (not . ei_suppress) items - final_items | null filtered_items = items - -- they're all suppressed; must report *something* - -- NB: even though reportWanteds asserts that not - -- all items are suppressed, it's possible all the - -- irreducibles are suppressed, and so this function - -- might get all suppressed items - | otherwise = filtered_items - -{- 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! - -There are two cases to consider: - -1. For out-of-scope variables we always report an error, unless -fdefer-out-of-scope-variables is on, - in which case the messages are discarded. See also #12170 and #12406. If deferring, report a warning - only if -Wout-of-scope-variables is on. - -2. For the general case, when -XPartialTypeSignatures is on, warnings (instead of errors) are generated - for holes in partial type signatures, unless -Wpartial-type-signatures is not on, in which case - the messages are discarded. If deferring, report a warning only if -Wtyped-holes is on. - -The above can be summarised into the following table: - -| Hole Type | Active Flags | Outcome | -|--------------|----------------------------------------------------------|------------------| -| out-of-scope | None | Error | -| out-of-scope | -fdefer-out-of-scope-variables, -Wout-of-scope-variables | Warning | -| out-of-scope | -fdefer-out-of-scope-variables | Ignore (discard) | -| type | None | Error | -| type | -XPartialTypeSignatures, -Wpartial-type-signatures | Warning | -| type | -XPartialTypeSignatures | Ignore (discard) | -| expression | None | Error | -| expression | -Wdefer-typed-holes, -Wtyped-holes | Warning | -| expression | -Wdefer-typed-holes | Ignore (discard) | - -See also 'reportUnsolved'. - --} - ----------------- --- | 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 }) - | isOutOfScopeHole hole - = do { dflags <- getDynFlags - ; rdr_env <- getGlobalRdrEnv - ; imp_info <- getImports - ; curr_mod <- getModule - ; hpt <- getHpt - ; let (imp_errs, hints) - = unknownNameSuggestions WL_Anything - dflags hpt curr_mod rdr_env - (tcl_rdr lcl_env) imp_info occ - err = SolverReportWithCtxt ctxt (ReportHoleError hole $ OutOfScopeHole imp_errs) - report = SolverReport err [] hints - - ; 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. - } - where - lcl_env = ctLocEnv ct_loc - - -- general case: not an out-of-scope error -mkHoleError lcl_name_cache tidy_simples ctxt - hole@(Hole { hole_ty = hole_ty - , hole_sort = sort - , hole_loc = ct_loc }) - = do { rel_binds - <- relevant_bindings False lcl_env lcl_name_cache (tyCoVarsOfType hole_ty) - -- The 'False' means "don't filter the bindings"; see #8191 - - ; show_hole_constraints <- goptM Opt_ShowHoleConstraints - ; let relevant_cts - | ExprHole _ <- sort, show_hole_constraints - = givenConstraints ctxt - | otherwise - = [] - - ; show_valid_hole_fits <- goptM Opt_ShowValidHoleFits - ; (ctxt, hole_fits) <- if show_valid_hole_fits - then validHoleFits ctxt tidy_simples hole - else return (ctxt, noValidHoleFits) - ; (grouped_skvs, other_tvs) <- 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 []) - - ; mkErrorReport lcl_env (TcRnSolverReport err reason noHints) (Just ctxt) supp - } - - where - lcl_env = ctLocEnv ct_loc - --- | For all the skolem type variables in a type, zonk the skolem info and group together --- all the type variables with the same origin. -zonkAndGroupSkolTvs :: Type -> TcM ([(SkolemInfoAnon, [TcTyVar])], [TcTyVar]) -zonkAndGroupSkolTvs hole_ty = do - zonked_info <- mapM (\(sk, tv) -> (,) <$> (zonkSkolemInfoAnon . getSkolemInfo $ sk) <*> pure (fst <$> tv)) skolem_list - return (zonked_info, other_tvs) - where - tvs = tyCoVarsOfTypeList hole_ty - (skol_tvs, other_tvs) = partition (\tv -> isTcTyVar tv && isSkolemTyVar tv) tvs - - group_skolems :: UM.UniqMap SkolemInfo ([(TcTyVar, Int)]) - group_skolems = bagToList <$> UM.listToUniqMap_C unionBags [(skolemSkolInfo tv, unitBag (tv, n)) | tv <- skol_tvs | n <- [0..]] - - skolem_list = sortBy (comparing (sort . map snd . snd)) (UM.nonDetEltsUniqMap group_skolems) - -{- 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 - -> SolverReport - -> TcM () -maybeAddDeferredBindings ctxt 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 - -- NB: ref_ty, not hole_ty. hole_ty might be rewritten. - -- See Note [Holes] in GHC.Tc.Types.Constraint - writeMutVar ref err_tm - _ -> pure () - --- We unwrap the SolverReportErrCtxt here, to avoid introducing a loop in module --- imports -validHoleFits :: SolverReportErrCtxt -- ^ The context we're in, i.e. the - -- implications and the tidy environment - -> [ErrorItem] -- ^ Unsolved simple constraints - -> Hole -- ^ The hole - -> TcM (SolverReportErrCtxt, ValidHoleFits) - -- ^ We return the new context - -- with a possibly updated - -- tidy environment, and - -- the valid hole fits. -validHoleFits ctxt@(CEC { cec_encl = implics - , cec_tidy = lcl_env}) simps hole - = do { (tidy_env, fits) <- findValidHoleFits lcl_env implics (mapMaybe mk_wanted simps) hole - ; return (ctxt {cec_tidy = tidy_env}, fits) } - where - 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 }) - | otherwise - = Nothing -- The ErrorItem was a Given - - --- See Note [Constraints include ...] -givenConstraints :: SolverReportErrCtxt -> [(Type, RealSrcSpan)] -givenConstraints ctxt - = do { implic@Implic{ ic_given = given } <- cec_encl ctxt - ; constraint <- given - ; return (varType constraint, tcl_loc (ic_env implic)) } - ----------------- - -mkIPErr :: SolverReportErrCtxt -> [ErrorItem] -> TcM SolverReport --- What would happen if an item is suppressed because of --- Note [Wanteds rewrite Wanteds] in GHC.Tc.Types.Constraint? Very unclear --- what's best. Let's not worry about this. -mkIPErr ctxt items - = do { (ctxt, binds, item1) <- relevantBindings True ctxt item1 - ; let msg = important ctxt $ UnboundImplicitParams (item1 :| others) - ; return $ add_relevant_bindings binds msg } - where - item1:others = items - ----------------- - --- | Report a representation-polymorphism error to the user: --- a type is required to have a fixed runtime representation, --- but doesn't. --- --- See Note [Reporting representation-polymorphism errors] in GHC.Tc.Types.Origin. -mkFRRErr :: HasDebugCallStack => SolverReportErrCtxt -> [ErrorItem] -> TcM SolverReport -mkFRRErr ctxt items - = do { -- Process the error items. - ; (_tidy_env, frr_infos) <- - zonkTidyFRRInfos (cec_tidy ctxt) $ - -- 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) - items - ; return $ important ctxt $ FixedRuntimeRepError frr_infos } - --- | Whether to report something using the @FixedRuntimeRep@ mechanism. -fixedRuntimeRepOrigin_maybe :: HasDebugCallStack => ErrorItem -> Maybe FixedRuntimeRepErrorInfo -fixedRuntimeRepOrigin_maybe item - -- An error that arose directly from a representation-polymorphism check. - | FRROrigin frr_orig <- errorItemOrigin item - = Just $ FRR_Info { frr_info_origin = frr_orig - , frr_info_not_concrete = Nothing } - -- Unsolved nominal equalities 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''. - | otherwise - = Nothing - -{- -Note [Constraints include ...] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -'givenConstraintsMsg' returns the "Constraints include ..." message enabled by --fshow-hole-constraints. For example, the following hole: - - foo :: (Eq a, Show a) => a -> String - foo x = _ - -would generate the message: - - Constraints include - Eq a (from foo.hs:1:1-36) - Show a (from foo.hs:1:1-36) - -Constraints are displayed in order from innermost (closest to the hole) to -outermost. There's currently no filtering or elimination of duplicates. - -************************************************************************ -* * - Equality errors -* * -************************************************************************ - -Note [Inaccessible code] -~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - data T a where - T1 :: T a - T2 :: T Bool - - f :: (a ~ Int) => T a -> Int - f T1 = 3 - f T2 = 4 -- Unreachable code - -Here the second equation is unreachable. The original constraint -(a~Int) from the signature gets rewritten by the pattern-match to -(Bool~Int), so the danger is that we report the error as coming from -the *signature* (#7293). So, for Given errors we replace the -env (and hence src-loc) on its CtLoc with that from the immediately -enclosing implication. - -Note [Error messages for untouchables] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider (#9109) - data G a where { GBool :: G Bool } - foo x = case x of GBool -> True - -Here we can't solve (t ~ Bool), where t is the untouchable result -meta-var 't', because of the (a ~ Bool) from the pattern match. -So we infer the type - f :: forall a t. G a -> t -making the meta-var 't' into a skolem. So when we come to report -the unsolved (t ~ Bool), t won't look like an untouchable meta-var -any more. So we don't assert that it is. --} - --- Don't have multiple equality errors from the same location --- E.g. (Int,Bool) ~ (Bool,Int) one error will do! -mkEqErr :: SolverReportErrCtxt -> [ErrorItem] -> TcM SolverReport -mkEqErr ctxt items - | item:_ <- filter (not . ei_suppress) items - = mkEqErr1 ctxt item - - | item:_ <- items -- they're all suppressed. still need an error message - -- for -fdefer-type-errors though - = mkEqErr1 ctxt item - - | otherwise - = panic "mkEqErr" -- guaranteed to have at least one item - -mkEqErr1 :: SolverReportErrCtxt -> ErrorItem -> TcM SolverReport -mkEqErr1 ctxt item -- Wanted only - -- 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 - ; let - report = add_relevant_bindings binds - $ add_report_hints hints - $ important ctxt err_msg - ; return report } - where - (ty1, ty2) = getEqPredTys (errorItemPred item) - --- | This function tries to reconstruct why a "Coercible ty1 ty2" constraint --- is left over. -mkCoercibleExplanation :: GlobalRdrEnv -> FamInstEnvs - -> TcType -> TcType -> Maybe CoercibleMsg -mkCoercibleExplanation rdr_env fam_envs ty1 ty2 - | Just (tc, tys) <- tcSplitTyConApp_maybe ty1 - , (rep_tc, _, _) <- tcLookupDataFamInst fam_envs tc tys - , Just msg <- coercible_msg_for_tycon rep_tc - = Just msg - | Just (tc, tys) <- splitTyConApp_maybe ty2 - , (rep_tc, _, _) <- tcLookupDataFamInst fam_envs tc tys - , Just msg <- coercible_msg_for_tycon rep_tc - = Just msg - | Just (s1, _) <- tcSplitAppTy_maybe ty1 - , Just (s2, _) <- tcSplitAppTy_maybe ty2 - , s1 `eqType` s2 - , has_unknown_roles s1 - = Just $ UnknownRoles s1 - | otherwise - = Nothing - where - coercible_msg_for_tycon tc - | isAbstractTyCon tc - = Just $ TyConIsAbstract tc - | isNewTyCon tc - , [data_con] <- tyConDataCons tc - , let dc_name = dataConName data_con - , isNothing (lookupGRE_Name rdr_env dc_name) - = Just $ OutOfScopeNewtypeConstructor tc data_con - | otherwise = Nothing - - has_unknown_roles ty - | Just (tc, tys) <- tcSplitTyConApp_maybe ty - = tys `lengthAtLeast` tyConArity tc -- oversaturated tycon - | Just (s, _) <- tcSplitAppTy_maybe ty - = has_unknown_roles s - | isTyVarTy ty - = True - | otherwise - = False - -mkEqErr_help :: SolverReportErrCtxt - -> ErrorItem - -> TcType -> TcType -> TcM (TcSolverReportMsg, [GhcHint]) -mkEqErr_help ctxt item ty1 ty2 - | Just casted_tv1 <- getCastedTyVar_maybe ty1 - = mkTyVarEqErr ctxt item casted_tv1 ty2 - | Just casted_tv2 <- getCastedTyVar_maybe ty2 - = mkTyVarEqErr ctxt item casted_tv2 ty1 - | otherwise - = do - err <- reportEqErr ctxt item ty1 ty2 - return (err, noHints) - -reportEqErr :: SolverReportErrCtxt - -> ErrorItem - -> TcType -> TcType - -> TcM TcSolverReportMsg -reportEqErr ctxt item ty1 ty2 - = do - mb_coercible_info <- - if errorItemEqRel item == ReprEq - then coercible_msg ty1 ty2 - else return Nothing - return $ - Mismatch - { mismatchMsg = mismatch - , mismatchTyVarInfo = Nothing - , mismatchAmbiguityInfo = eqInfos - , mismatchCoercibleInfo = mb_coercible_info } - where - mismatch = misMatchOrCND False ctxt item ty1 ty2 - eqInfos = eqInfoMsgs ty1 ty2 - -coercible_msg :: TcType -> TcType -> TcM (Maybe CoercibleMsg) -coercible_msg ty1 ty2 - = do - rdr_env <- getGlobalRdrEnv - fam_envs <- tcGetFamInstEnvs - return $ mkCoercibleExplanation rdr_env fam_envs ty1 ty2 - -mkTyVarEqErr :: SolverReportErrCtxt -> ErrorItem - -> (TcTyVar, TcCoercionN) -> TcType -> TcM (TcSolverReportMsg, [GhcHint]) --- 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' :: SolverReportErrCtxt -> ErrorItem - -> (TcTyVar, TcCoercionN) -> TcType -> TcM (TcSolverReportMsg, [GhcHint]) -mkTyVarEqErr' ctxt item (tv1, co1) 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) <- zonkTidyFRRInfos (cec_tidy ctxt) [frr_info] - return (FixedRuntimeRepError infos, []) - - -- Impredicativity is a simple error to understand; try it before - -- anything more complicated. - | check_eq_result `cterHasProblem` cteImpredicative - = do - tyvar_eq_info <- extraTyVarEqInfo (tv1, Nothing) ty2 - let - poly_msg = CannotUnifyWithPolytype item tv1 ty2 mb_tv_info - mb_tv_info - | isSkolemTyVar tv1 - = Just tyvar_eq_info - | otherwise - = Nothing - main_msg = - CannotUnifyVariable - { mismatchMsg = headline_msg - , cannotUnifyReason = poly_msg } - -- 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, []) - - | isSkolemTyVar tv1 -- ty2 won't be a meta-tyvar; we would have - -- swapped in Solver.Canonical.canEqTyVarHomo - || isTyVarTyVar tv1 && not (isTyVarTy ty2) - || errorItemEqRel item == ReprEq - -- The cases below don't really apply to ReprEq (except occurs check) - = do - tv_extra <- extraTyVarEqInfo (tv1, Nothing) ty2 - reason <- - if errorItemEqRel item == ReprEq - then RepresentationalEq tv_extra <$> coercible_msg ty1 ty2 - else return $ DifferentTyVars tv_extra - let main_msg = - CannotUnifyVariable - { mismatchMsg = headline_msg - , cannotUnifyReason = reason } - return (main_msg, add_sig) - - | cterHasOccursCheck check_eq_result - -- We report an "occurs check" even for a ~ F t a, where F is a type - -- function; it's not insoluble (because in principle F could reduce) - -- but we have certainly been unable to solve it - = let ambiguity_infos = eqInfoMsgs ty1 ty2 - - interesting_tyvars = filter (not . noFreeVarsOfType . tyVarKind) $ - filter isTyVar $ - fvVarList $ - tyCoFVsOfType ty1 `unionFV` tyCoFVsOfType ty2 - - occurs_err = - OccursCheck - { occursCheckInterestingTyVars = interesting_tyvars - , occursCheckAmbiguityInfos = ambiguity_infos } - main_msg = - CannotUnifyVariable - { mismatchMsg = headline_msg - , cannotUnifyReason = occurs_err } - - in return (main_msg, []) - - -- This is wrinkle (4) in Note [Equalities with incompatible kinds] in - -- GHC.Tc.Solver.Canonical - | hasCoercionHoleCo co1 || hasCoercionHoleTy ty2 - = return (mkBlockedEqErr item, []) - - -- If the immediately-enclosing implication has 'tv' a skolem, and - -- we know by now its an InferSkol kind of skolem, then presumably - -- it started life as a TyVarTv, else it'd have been unified, given - -- that there's no occurs-check or forall problem - | (implic:_) <- cec_encl ctxt - , Implic { ic_skols = skols } <- implic - , tv1 `elem` skols - = do - tv_extra <- extraTyVarEqInfo (tv1, Nothing) ty2 - let msg = Mismatch - { mismatchMsg = mismatch_msg - , mismatchTyVarInfo = Just tv_extra - , mismatchAmbiguityInfo = [] - , mismatchCoercibleInfo = Nothing } - return (msg, []) - - -- Check for skolem escape - | (implic:_) <- cec_encl ctxt -- Get the innermost context - , Implic { ic_skols = skols } <- implic - , let esc_skols = filter (`elemVarSet` (tyCoVarsOfType ty2)) skols - , not (null esc_skols) - = let main_msg = - CannotUnifyVariable - { mismatchMsg = mismatch_msg - , cannotUnifyReason = SkolemEscape item implic esc_skols } - - in return (main_msg, []) - - -- Nastiest case: attempt to unify an untouchable variable - -- So tv is a meta tyvar (or started that way before we - -- generalised it). So presumably it is an *untouchable* - -- meta tyvar or a TyVarTv, else it'd have been unified - -- See Note [Error messages for untouchables] - | (implic:_) <- cec_encl ctxt -- Get the innermost context - , Implic { ic_tclvl = lvl } <- implic - = assertPpr (not (isTouchableMetaTyVar lvl tv1)) - (ppr tv1 $$ ppr lvl) $ do -- See Note [Error messages for untouchables] - tv_extra <- extraTyVarEqInfo (tv1, Just implic) ty2 - let tv_extra' = tv_extra { thisTyVarIsUntouchable = Just implic } - msg = Mismatch - { mismatchMsg = mismatch_msg - , mismatchTyVarInfo = Just tv_extra' - , mismatchAmbiguityInfo = [] - , mismatchCoercibleInfo = Nothing } - return (msg, add_sig) - - | otherwise - = do - err <- reportEqErr ctxt item (mkTyVarTy tv1) ty2 - return (err, []) - -- 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 insoluble_occurs_check 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 - -- there is an error is not sufficient. See #21430. - mb_concrete_reason - | Just frr_orig <- isConcreteTyVar_maybe tv1 - , not (isConcrete ty2) - = Just $ frr_reason frr_orig tv1 ty2 - | Just (tv2, frr_orig) <- isConcreteTyVarTy_maybe ty2 - , not (isConcreteTyVar tv1) - = Just $ frr_reason frr_orig tv2 ty1 - -- NB: if it's an unsolved equality in which both sides are concrete - -- (e.g. a concrete type variable on both sides), then it's not a - -- representation-polymorphism problem. - | otherwise - = 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) } - - ty1 = mkTyVarTy tv1 - - check_eq_result = case ei_m_reason item of - Just (NonCanonicalReason result) -> result - _ -> checkTyVarEq tv1 ty2 - -- in T2627b, we report an error for F (F a0) ~ a0. Note that the type - -- variable is on the right, so we don't get useful info for the CIrredCan, - -- and have to compute the result of checkTyVarEq here. - - insoluble_occurs_check = check_eq_result `cterHasProblem` cteInsolubleOccurs - -eqInfoMsgs :: TcType -> TcType -> [AmbiguityInfo] --- Report (a) ambiguity if either side is a type function application --- e.g. F a0 ~ Int --- (b) warning about injectivity if both sides are the same --- type function application F a ~ F b --- See Note [Non-injective type functions] -eqInfoMsgs ty1 ty2 - = catMaybes [tyfun_msg, ambig_msg] - where - 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_tkvs@(ambig_kvs, ambig_tvs) = ambig_tkvs1 S.<> ambig_tkvs2 - - ambig_msg | isJust mb_fun1 || isJust mb_fun2 - , not (null ambig_kvs && null ambig_tvs) - = Just $ Ambiguity False ambig_tkvs - | otherwise - = Nothing - - tyfun_msg | Just tc1 <- mb_fun1 - , Just tc2 <- mb_fun2 - , tc1 == tc2 - , not (isInjectiveTyCon tc1 Nominal) - = Just $ NonInjectiveTyFam tc1 - | otherwise - = Nothing - -misMatchOrCND :: Bool -> SolverReportErrCtxt -> ErrorItem - -> TcType -> TcType -> MismatchMsg --- If oriented then ty1 is actual, ty2 is expected -misMatchOrCND insoluble_occurs_check ctxt item ty1 ty2 - | insoluble_occurs_check -- See Note [Insoluble occurs check] - || (isRigidTy ty1 && isRigidTy ty2) - || (ei_flavour item == Given) - || null givens - = -- If the equality is unconditionally insoluble - -- or there is no context, don't report the context - mkMismatchMsg item ty1 ty2 - - | otherwise - = CouldNotDeduce givens (item :| []) (Just $ CND_Extra level ty1 ty2) - - where - level = ctLocTypeOrKind_maybe (errorItemCtLoc item) `orElse` TypeLevel - givens = [ given | given <- getUserGivens ctxt, ic_given_eqs given /= NoGivenEqs ] - -- Keep only UserGivens that have some equalities. - -- See Note [Suppress redundant givens during error reporting] - --- These are for the "blocked" equalities, as described in TcCanonical --- Note [Equalities with incompatible kinds], wrinkle (2). 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] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When GHC is unable to solve a constraint and prints out an error message, it -will print out what given constraints are in scope to provide some context to -the programmer. But we shouldn't print out /every/ given, since some of them -are not terribly helpful to diagnose type errors. Consider this example: - - foo :: Int :~: Int -> a :~: b -> a :~: c - foo Refl Refl = Refl - -When reporting that GHC can't solve (a ~ c), there are two givens in scope: -(Int ~ Int) and (a ~ b). But (Int ~ Int) is trivially soluble (i.e., -redundant), so it's not terribly useful to report it in an error message. -To accomplish this, we discard any Implications that do not bind any -equalities by filtering the `givens` selected in `misMatchOrCND` (based on -the `ic_given_eqs` field of the Implication). Note that we discard givens -that have no equalities whatsoever, but we want to keep ones with only *local* -equalities, as these may be helpful to the user in understanding what went -wrong. - -But this is not enough to avoid all redundant givens! Consider this example, -from #15361: - - goo :: forall (a :: Type) (b :: Type) (c :: Type). - a :~~: b -> a :~~: c - goo HRefl = HRefl - -Matching on HRefl brings the /single/ given (* ~ *, a ~ b) into scope. -The (* ~ *) part arises due the kinds of (:~~:) being unified. More -importantly, (* ~ *) is redundant, so we'd like not to report it. However, -the Implication (* ~ *, a ~ b) /does/ bind an equality (as reported by its -ic_given_eqs field), so the test above will keep it wholesale. - -To refine this given, we apply mkMinimalBySCs on it to extract just the (a ~ b) -part. This works because mkMinimalBySCs eliminates reflexive equalities in -addition to superclasses (see Note [Remove redundant provided dicts] -in GHC.Tc.TyCl.PatSyn). --} - -extraTyVarEqInfo :: (TcTyVar, Maybe Implication) -> TcType -> TcM TyVarInfo --- Add on extra info about skolem constants --- NB: The types themselves are already tidied -extraTyVarEqInfo (tv1, mb_implic) ty2 - = do - tv1_info <- extraTyVarInfo tv1 - ty2_info <- ty_extra ty2 - return $ - TyVarInfo - { thisTyVar = tv1_info - , thisTyVarIsUntouchable = mb_implic - , otherTy = ty2_info } - where - ty_extra ty = case getCastedTyVar_maybe ty of - Just (tv, _) -> Just <$> extraTyVarInfo tv - Nothing -> return Nothing - -extraTyVarInfo :: TcTyVar -> TcM TyVar -extraTyVarInfo tv = assertPpr (isTyVar tv) (ppr tv) $ - case tcTyVarDetails tv of - SkolemTv skol_info lvl overlaps -> do - new_skol_info <- zonkSkolemInfo skol_info - 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_actual = uo_actual - , teq_mismatch_expected = uo_expected - , teq_mismatch_what = mb_thing - , teq_mb_same_occ = sameOccExtras ty2 ty1 }) - KindEqOrigin cty1 cty2 sub_o mb_sub_t_or_k -> - (mkBasicMismatchMsg NoEA item ty1 ty2) - { mismatch_whenMatching = Just $ WhenMatching cty1 cty2 sub_o mb_sub_t_or_k - , mismatch_mb_same_occ = mb_same_occ } - _ -> - (mkBasicMismatchMsg NoEA item ty1 ty2) - { mismatch_mb_same_occ = mb_same_occ } - 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 occurs check] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider [G] a ~ [a], [W] a ~ [a] (#13674). The Given is insoluble -so we don't use it for rewriting. The Wanted is also insoluble, and -we don't solve it from the Given. It's very confusing to say - Cannot solve a ~ [a] from given constraints a ~ [a] - -And indeed even thinking about the Givens is silly; [W] a ~ [a] is -just as insoluble as Int ~ Bool. - -Conclusion: if there's an insoluble occurs check (cteInsolubleOccurs) -then report it directly, not in the "cannot deduce X from Y" form. -This is done in misMatchOrCND (via the insoluble_occurs_check arg) - -(NB: there are potentially-soluble ones, like (a ~ F a b), and we don't -want to be as draconian with them.) --} - -sameOccExtras :: TcType -> TcType -> Maybe SameOccInfo --- See Note [Disambiguating (X ~ X) errors] -sameOccExtras ty1 ty2 - | Just (tc1, _) <- tcSplitTyConApp_maybe ty1 - , Just (tc2, _) <- tcSplitTyConApp_maybe ty2 - , let n1 = tyConName tc1 - n2 = tyConName tc2 - same_occ = nameOccName n1 == nameOccName n2 - same_pkg = moduleUnit (nameModule n1) == moduleUnit (nameModule n2) - , n1 /= n2 -- Different Names - , same_occ -- but same OccName - = Just $ SameOcc same_pkg n1 n2 - | 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] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -See #8278 - -Note [Reporting occurs-check errors] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Given (a ~ [a]), if 'a' is a rigid type variable bound by a user-supplied -type signature, then the best thing is to report that we can't unify -a with [a], because a is a skolem variable. That avoids the confusing -"occur-check" error message. - -But nowadays when inferring the type of a function with no type signature, -even if there are errors inside, we still generalise its signature and -carry on. For example - f x = x:x -Here we will infer something like - f :: forall a. a -> [a] -with a deferred error of (a ~ [a]). So in the deferred unsolved constraint -'a' is now a skolem, but not one bound by the programmer in the context! -Here we really should report an occurs check. - -So isUserSkolem distinguishes the two. - -Note [Non-injective type functions] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -It's very confusing to get a message like - Couldn't match expected type `Depend s' - against inferred type `Depend s1' -so mkTyFunInfoMsg adds: - NB: `Depend' is type function, and hence may not be injective - -Warn of loopy local equalities that were dropped. - - -************************************************************************ -* * - Type-class errors -* * -************************************************************************ --} - -mkDictErr :: HasDebugCallStack => SolverReportErrCtxt -> [ErrorItem] -> TcM SolverReport -mkDictErr ctxt orig_items - = assert (not (null items)) $ - do { inst_envs <- tcGetInstEnvs - ; let min_items = elim_superclasses items - lookups = map (lookup_cls_inst inst_envs) min_items - (no_inst_items, overlap_items) = partition is_no_inst lookups - - -- Report definite no-instance errors, - -- or (iff there are none) overlap errors - -- 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 } - where - filtered_items = filter (not . ei_suppress) orig_items - items | null filtered_items = orig_items -- all suppressed, but must report - -- something for -fdefer-type-errors - | otherwise = filtered_items -- common case - - no_givens = null (getUserGivens ctxt) - - is_no_inst (item, (matches, unifiers, _)) - = no_givens - && null matches - && (nullUnifiers unifiers || all (not . isAmbiguousTyVar) (tyCoVarsOfTypeList (errorItemPred item))) - - lookup_cls_inst inst_envs item - = (item, lookupInstEnv True inst_envs clas tys) - where - (clas, tys) = getClassPredTys (errorItemPred item) - - - -- When simplifying [W] Ord (Set a), we need - -- [W] Eq a, [W] Ord a - -- but we really only want to report the latter - elim_superclasses items = mkMinimalBySCs errorItemPred items - --- Note [mk_dict_err] --- ~~~~~~~~~~~~~~~~~~~ --- Different dictionary error messages are reported depending on the number of --- matches and unifiers: --- --- - No matches, regardless of unifiers: report "No instance for ...". --- - Two or more matches, regardless of unifiers: report "Overlapping instances for ...", --- and show the matching and unifying instances. --- - One match, one or more unifiers: report "Overlapping instances for", show the --- 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 - (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 - ; return (cannot_resolve_msg item candidate_insts rel_binds imp_errs field_suggestions) } - - -- Some matches => overlap errors - (Just matchesNE, Nothing) -> return $ - OverlappingInstances item (NE.map fst matchesNE) (getPotentialUnifiers 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 ] - where - orig = errorItemOrigin item - pred = errorItemPred item - (clas, tys) = getClassPredTys pred - - get_candidate_instances :: TcM [ClsInst] - -- See Note [Report candidate instances] - get_candidate_instances - | [ty] <- tys -- Only try for single-parameter classes - = do { instEnvs <- tcGetInstEnvs - ; return (filter (is_candidate_inst ty) - (classInstances instEnvs clas)) } - | otherwise = return [] - - is_candidate_inst ty inst -- See Note [Report candidate instances] - | [other_ty] <- is_tys inst - , Just (tc1, _) <- tcSplitTyConApp_maybe ty - , Just (tc2, _) <- tcSplitTyConApp_maybe other_ty - = let n1 = tyConName tc1 - n2 = tyConName tc2 - different_names = n1 /= n2 - same_occ_names = nameOccName n1 == nameOccName n2 - in different_names && same_occ_names - | otherwise = False - - -- See Note [Out-of-scope fields with -XOverloadedRecordDot] - record_field_suggestions :: TcM ([ImportError], [GhcHint]) - record_field_suggestions = flip (maybe $ return ([], noHints)) record_field $ \name -> - do { glb_env <- getGlobalRdrEnv - ; lcl_env <- getLocalRdrEnv - ; if occ_name_in_scope glb_env lcl_env name - then return ([], noHints) - else do { dflags <- getDynFlags - ; imp_info <- getImports - ; curr_mod <- getModule - ; hpt <- getHpt - ; return (unknownNameSuggestions WL_RecField dflags hpt curr_mod - glb_env emptyLocalRdrEnv imp_info (mkRdrUnqual name)) } } - - occ_name_in_scope glb_env lcl_env occ_name = not $ - null (lookupGlobalRdrEnv glb_env occ_name) && - isNothing (lookupLocalRdrOcc lcl_env occ_name) - - record_field = case orig of - HasFieldOrigin name -> Just (mkVarOccFS name) - _ -> Nothing - - cannot_resolve_msg :: 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, -but comes from some other module, then it may be helpful to point out -that there are some similarly named instances elsewhere. So we get -something like - No instance for (Num Int) arising from the literal ‘3’ - There are instances for similar types: - instance Num GHC.Types.Int -- Defined in ‘GHC.Num’ -Discussion in #9611. - -Note [Highlighting ambiguous type variables] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When we encounter ambiguous type variables (i.e. type variables -that remain metavariables after type inference), we need a few more -conditions before we can reason that *ambiguity* prevents constraints -from being solved: - - We can't have any givens, as encountering a typeclass error - with given constraints just means we couldn't deduce - a solution satisfying those constraints and as such couldn't - bind the type variable to a known type. - - If we don't have any unifiers, we don't even have potential - instances from which an ambiguity could arise. - - Lastly, I don't want to mess with error reporting for - unknown runtime types so we just fall back to the old message there. -Once these conditions are satisfied, we can safely say that ambiguity prevents -the constraint from being solved. - -Note [Out-of-scope fields with -XOverloadedRecordDot] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -With -XOverloadedRecordDot, when a field isn't in scope, the error that appears -is produces here, and it says - No instance for (GHC.Record.HasField "" ...). - -Additionally, though, we want to suggest similar field names that are in scope -or could be in scope with different import lists. - -However, we can still get an error about a missing HasField instance when a -field is in scope (if the types are wrong), and so it's important that we don't -suggest similar names here if the record field is in scope, either qualified or -unqualified, since qualification doesn't matter for -XOverloadedRecordDot. - -Example: - - import Data.Monoid (Alt(..)) - - foo = undefined.getAll - -results in - - No instance for (GHC.Records.HasField "getAll" r0 a0) - arising from selecting the field ‘getAll’ - Perhaps you meant ‘getAlt’ (imported from Data.Monoid) - Perhaps you want to add ‘getAll’ to the import list - in the import of ‘Data.Monoid’ --} - -{- -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 --- careful to zonk the Id's type first, so it has to be in the monad. --- We must be careful to pass it a zonked type variable, too. --- --- We always remove closed top-level bindings, though, --- since they are never relevant (cf #8233) - -relevantBindings :: Bool -- True <=> filter by tyvar; False <=> no filtering - -- See #8191 - -> SolverReportErrCtxt -> ErrorItem - -> TcM (SolverReportErrCtxt, RelevantBindings, ErrorItem) --- Also returns the zonked and tidied CtOrigin of the constraint -relevantBindings want_filtering ctxt item - = do { traceTc "relevantBindings" (ppr item) - ; (env1, tidy_orig) <- zonkTidyOrigin (cec_tidy ctxt) (ctLocOrigin loc) - - -- For *kind* errors, report the relevant bindings of the - -- enclosing *type* equality, because that's more useful for the programmer - ; let extra_tvs = case tidy_orig of - KindEqOrigin t1 t2 _ _ -> tyCoVarsOfTypes [t1,t2] - _ -> emptyVarSet - ct_fvs = tyCoVarsOfType (errorItemPred item) `unionVarSet` extra_tvs - - -- Put a zonked, tidied CtOrigin into the ErrorItem - loc' = setCtLocOrigin loc tidy_orig - item' = item { ei_loc = loc' } - - ; (env2, lcl_name_cache) <- zonkTidyTcLclEnvs env1 [lcl_env] - - ; relev_bds <- relevant_bindings want_filtering lcl_env lcl_name_cache ct_fvs - ; let ctxt' = ctxt { cec_tidy = env2 } - ; return (ctxt', relev_bds, item') } - where - loc = errorItemCtLoc item - lcl_env = ctLocEnv loc - --- slightly more general version, to work also with holes -relevant_bindings :: Bool - -> TcLclEnv - -> NameEnv Type -- Cache of already zonked and tidied types - -> TyCoVarSet - -> TcM RelevantBindings -relevant_bindings want_filtering lcl_env lcl_name_env ct_tvs - = do { dflags <- getDynFlags - ; traceTc "relevant_bindings" $ - vcat [ ppr ct_tvs - , pprWithCommas id [ ppr id <+> dcolon <+> ppr (idType id) - | TcIdBndr id _ <- tcl_bndrs lcl_env ] - , pprWithCommas id - [ ppr id | TcIdBndr_ExpType id _ _ <- tcl_bndrs lcl_env ] ] - - ; go dflags (maxRelevantBinds dflags) - emptyVarSet (RelevantBindings [] False) - (removeBindingShadowing $ tcl_bndrs lcl_env) - -- tcl_bndrs has the innermost bindings first, - -- which are probably the most relevant ones - } - where - run_out :: Maybe Int -> Bool - run_out Nothing = False - run_out (Just n) = n <= 0 - - dec_max :: Maybe Int -> Maybe Int - dec_max = fmap (\n -> n - 1) - - - go :: DynFlags -> Maybe Int -> TcTyVarSet - -> RelevantBindings - -> [TcBinder] - -> TcM RelevantBindings - go _ _ _ (RelevantBindings bds discards) [] - = return $ RelevantBindings (reverse bds) discards - go dflags n_left tvs_seen rels@(RelevantBindings bds discards) (tc_bndr : tc_bndrs) - = case tc_bndr of - TcTvBndr {} -> discard_it - TcIdBndr id top_lvl -> go2 (idName id) top_lvl - TcIdBndr_ExpType name et top_lvl -> - do { mb_ty <- readExpType_maybe et - -- et really should be filled in by now. But there's a chance - -- it hasn't, if, say, we're reporting a kind error en route to - -- checking a term. See test indexed-types/should_fail/T8129 - -- Or we are reporting errors from the ambiguity check on - -- a local type signature - ; case mb_ty of - Just _ty -> go2 name top_lvl - Nothing -> discard_it -- No info; discard - } - where - discard_it = go dflags n_left tvs_seen rels tc_bndrs - go2 id_name top_lvl - = do { let tidy_ty = case lookupNameEnv lcl_name_env id_name of - Just tty -> tty - Nothing -> pprPanic "relevant_bindings" (ppr id_name) - ; traceTc "relevantBindings 1" (ppr id_name <+> dcolon <+> ppr tidy_ty) - ; let id_tvs = tyCoVarsOfType tidy_ty - bd = (id_name, tidy_ty) - new_seen = tvs_seen `unionVarSet` id_tvs - - ; if (want_filtering && not (hasPprDebug dflags) - && id_tvs `disjointVarSet` ct_tvs) - -- We want to filter out this binding anyway - -- so discard it silently - then discard_it - - else if isTopLevel top_lvl && not (isNothing n_left) - -- It's a top-level binding and we have not specified - -- -fno-max-relevant-bindings, so discard it silently - then discard_it - - else if run_out n_left && id_tvs `subVarSet` tvs_seen - -- We've run out of n_left fuel and this binding only - -- mentions already-seen type variables, so discard it - then go dflags n_left tvs_seen (RelevantBindings bds True) -- Record that we have now discarded something - tc_bndrs - - -- Keep this binding, decrement fuel - else go dflags (dec_max n_left) new_seen - (RelevantBindings (bd:bds) discards) tc_bndrs } - ------------------------ -warnDefaulting :: TcTyVar -> [Ct] -> Type -> TcM () -warnDefaulting _ [] _ - = panic "warnDefaulting: empty Wanteds" -warnDefaulting the_tv wanteds@(ct:_) default_ty - = do { warn_default <- woptM Opt_WarnTypeDefaults - ; env0 <- tcInitTidyEnv - -- don't want to report all the superclass constraints, which - -- add unhelpful clutter - ; let filtered = filter (not . isWantedSuperclassOrigin . ctOrigin) wanteds - tidy_env = tidyFreeTyCoVars env0 $ - tyCoVarsOfCtsList (listToBag filtered) - tidy_wanteds = map (tidyCt tidy_env) filtered - tidy_tv = lookupVarEnv (snd tidy_env) the_tv - diag = TcRnWarnDefaulting tidy_wanteds tidy_tv default_ty - loc = ctLoc ct - ; setCtLocM loc $ diagnosticTc warn_default diag } - -{- -Note [Runtime skolems] -~~~~~~~~~~~~~~~~~~~~~~ -We want to give a reasonably helpful error message for ambiguity -arising from *runtime* skolems in the debugger. These -are created by in GHC.Runtime.Heap.Inspect.zonkRTTIType. --} - -{-********************************************************************** -* * - GHC API helper functions -* * -**********************************************************************-} - --- | If the 'TcSolverReportMsg' is a type mismatch between --- an actual and an expected type, return the actual and expected types --- (in that order). --- --- 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 - = \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 {} -> - [] - _ -> [] +{-# 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, mismatchMsg_ExpectedActuals + ) where + +import GHC.Prelude + +import GHC.Driver.Env (hsc_units) +import GHC.Driver.DynFlags +import GHC.Driver.Ppr +import GHC.Driver.Config.Diagnostic + +import GHC.Rename.Unbound + +import GHC.Tc.Types +import GHC.Tc.Utils.Monad +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.Instance.Family +import GHC.Tc.Utils.Instantiate +import {-# SOURCE #-} GHC.Tc.Errors.Hole ( findValidHoleFits, getHoleFitDispConfig ) + +import GHC.Types.Name +import GHC.Types.Name.Reader +import GHC.Types.Id +import GHC.Types.Var +import GHC.Types.Var.Set +import GHC.Types.Var.Env +import GHC.Types.Name.Env +import GHC.Types.SrcLoc +import GHC.Types.Basic +import GHC.Types.Error +import qualified GHC.Types.Unique.Map as UM + +import GHC.Unit.Module +import qualified GHC.LanguageExtensions as LangExt + +import GHC.Core.Predicate +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 + +import GHC.Utils.Error (diagReasonSeverity, pprLocMsgEnvelope ) +import GHC.Utils.Misc +import GHC.Utils.Outputable as O +import GHC.Utils.Panic +import GHC.Utils.FV ( fvVarList, unionFV ) + +import GHC.Data.Bag +import GHC.Data.List.SetOps ( equivClasses, nubOrdBy ) +import GHC.Data.Maybe +import qualified GHC.Data.Strict as Strict + +import Control.Monad ( unless, when, foldM, forM_ ) +import Data.Foldable ( toList ) +import Data.Function ( on ) +import Data.List ( partition, union, sort, sortBy ) +import Data.List.NonEmpty ( NonEmpty(..), nonEmpty ) +import qualified Data.List.NonEmpty as NE +import Data.Ord ( comparing ) + +{- +************************************************************************ +* * +\section{Errors and contexts} +* * +************************************************************************ + +ToDo: for these error messages, should we note the location as coming +from the insts, or just whatever seems to be around in the monad just +now? + +Note [Deferring coercion errors to runtime] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +While developing, sometimes it is desirable to allow compilation to succeed even +if there are type errors in the code. Consider the following case: + + module Main where + + a :: Int + a = 'a' + + main = print "b" + +Even though `a` is ill-typed, it is not used in the end, so if all that we're +interested in is `main` it is handy to be able to ignore the problems in `a`. + +Since we treat type equalities as evidence, this is relatively simple. Whenever +we run into a type mismatch in GHC.Tc.Utils.Unify, we normally just emit an error. But it +is always safe to defer the mismatch to the main constraint solver. If we do +that, `a` will get transformed into + + co :: Int ~ Char + co = ... + + a :: Int + a = 'a' `cast` co + +The constraint solver would realize that `co` is an insoluble constraint, and +emit an error with `reportUnsolved`. But we can also replace the right-hand side +of `co` with `error "Deferred type error: Int ~ Char"`. This allows the program +to compile, and it will run fine unless we evaluate `a`. This is what +`deferErrorsToRuntime` does. + +It does this by keeping track of which errors correspond to which coercion +in GHC.Tc.Errors. GHC.Tc.Errors.reportTidyWanteds does not print the errors +and does not fail if -fdefer-type-errors is on, so that we can continue +compilation. The errors are turned into warnings in `reportUnsolved`. +-} + +-- | Report unsolved goals as errors or warnings. We may also turn some into +-- deferred run-time errors if `-fdefer-type-errors` is on. +reportUnsolved :: WantedConstraints -> TcM (Bag EvBind) +reportUnsolved wanted + = do { binds_var <- newTcEvBinds + ; defer_errors <- goptM Opt_DeferTypeErrors + ; let type_errors | not defer_errors = ErrorWithoutFlag + | otherwise = WarningWithFlag Opt_WarnDeferredTypeErrors + + ; defer_holes <- goptM Opt_DeferTypedHoles + ; let expr_holes | not defer_holes = ErrorWithoutFlag + | otherwise = WarningWithFlag Opt_WarnTypedHoles + + ; partial_sigs <- xoptM LangExt.PartialTypeSignatures + ; let type_holes | not partial_sigs + = ErrorWithoutFlag + | otherwise + = WarningWithFlag Opt_WarnPartialTypeSignatures + + ; defer_out_of_scope <- goptM Opt_DeferOutOfScopeVariables + ; let out_of_scope_holes | not defer_out_of_scope + = ErrorWithoutFlag + | otherwise + = WarningWithFlag Opt_WarnDeferredOutOfScopeVariables + + ; report_unsolved type_errors expr_holes + type_holes out_of_scope_holes + binds_var wanted + + ; ev_binds <- getTcEvBindsMap binds_var + ; return (evBindMapBinds ev_binds)} + +-- | Report *all* unsolved goals as errors, even if -fdefer-type-errors is on +-- However, do not make any evidence bindings, because we don't +-- have any convenient place to put them. +-- NB: Type-level holes are OK, because there are no bindings. +-- See Note [Deferring coercion errors to runtime] +-- Used by solveEqualities for kind equalities +-- (see Note [Failure in local type signatures] in GHC.Tc.Solver) +reportAllUnsolved :: WantedConstraints -> TcM () +reportAllUnsolved wanted + = do { ev_binds <- newNoTcEvBinds + + ; partial_sigs <- xoptM LangExt.PartialTypeSignatures + ; let type_holes | not partial_sigs = ErrorWithoutFlag + | otherwise = WarningWithFlag Opt_WarnPartialTypeSignatures + + ; report_unsolved ErrorWithoutFlag + ErrorWithoutFlag type_holes ErrorWithoutFlag + ev_binds wanted } + +-- | Report all unsolved goals as warnings (but without deferring any errors to +-- run-time). See Note [Safe Haskell Overlapping Instances Implementation] in +-- "GHC.Tc.Solver" +warnAllUnsolved :: WantedConstraints -> TcM () +warnAllUnsolved wanted + = do { ev_binds <- newTcEvBinds + ; report_unsolved WarningWithoutFlag + WarningWithoutFlag + WarningWithoutFlag + WarningWithoutFlag + ev_binds wanted } + +-- | Report unsolved goals as errors or warnings. +report_unsolved :: DiagnosticReason -- Deferred type errors + -> DiagnosticReason -- Expression holes + -> DiagnosticReason -- Type holes + -> DiagnosticReason -- Out of scope holes + -> EvBindsVar -- cec_binds + -> WantedConstraints -> TcM () +report_unsolved type_errors expr_holes + type_holes out_of_scope_holes binds_var wanted + | isEmptyWC wanted + = return () + | otherwise + = do { traceTc "reportUnsolved {" $ + vcat [ text "type errors:" <+> ppr type_errors + , text "expr holes:" <+> ppr expr_holes + , text "type holes:" <+> ppr type_holes + , text "scope holes:" <+> ppr out_of_scope_holes ] + ; traceTc "reportUnsolved (before zonking and tidying)" (ppr wanted) + + ; wanted <- liftZonkM $ zonkWC wanted -- Zonk to reveal all information + + ; 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 + -- they are "bound" by other wanted constraints. They in + -- turn may mention variables bound further in, which makes + -- 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 ] + + ; warn_redundant <- woptM Opt_WarnRedundantConstraints + ; exp_syns <- goptM Opt_PrintExpandedSynonyms + ; let err_ctxt = CEC { cec_encl = [] + , cec_tidy = tidy_env + , cec_defer_type_errors = type_errors + , cec_expr_holes = expr_holes + , cec_type_holes = type_holes + , cec_out_of_scope_holes = out_of_scope_holes + , cec_suppress = insolubleWC wanted + -- See Note [Suppressing error messages] + -- Suppress low-priority errors if there + -- are insoluble errors anywhere; + -- See #15539 and c.f. setting ic_status + -- in GHC.Tc.Solver.setImplicationStatus + , cec_warn_redundant = warn_redundant + , cec_expand_syns = exp_syns + , cec_binds = binds_var } + + ; tc_lvl <- getTcLevel + ; reportWanteds err_ctxt tc_lvl wanted + ; traceTc "reportUnsolved }" empty } + +-------------------------------------------- +-- Internal functions +-------------------------------------------- + +-- | Make a report from a single 'TcSolverReportMsg'. +important :: SolverReportErrCtxt -> TcSolverReportMsg -> SolverReport +important ctxt doc + = SolverReport { sr_important_msg = SolverReportWithCtxt ctxt doc + , sr_supplementary = [] + , sr_hints = noHints + } + +add_relevant_bindings :: RelevantBindings -> SolverReport -> SolverReport +add_relevant_bindings binds report@(SolverReport { sr_supplementary = supp }) + = report { sr_supplementary = SupplementaryBindings binds : supp } + +-- | 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 +deferringAnyBindings (CEC { cec_defer_type_errors = ErrorWithoutFlag + , cec_expr_holes = ErrorWithoutFlag + , cec_out_of_scope_holes = ErrorWithoutFlag }) = False +deferringAnyBindings _ = True + +maybeSwitchOffDefer :: EvBindsVar -> SolverReportErrCtxt -> SolverReportErrCtxt +-- Switch off defer-type-errors inside CoEvBindsVar +-- See Note [Failing equalities with no evidence bindings] +maybeSwitchOffDefer evb ctxt + | CoEvBindsVar{} <- evb + = ctxt { cec_defer_type_errors = ErrorWithoutFlag + , cec_expr_holes = ErrorWithoutFlag + , cec_out_of_scope_holes = ErrorWithoutFlag } + | otherwise + = ctxt + +{- Note [Failing equalities with no evidence bindings] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If we go inside an implication that has no term evidence +(e.g. unifying under a forall), we can't defer type errors. You could +imagine using the /enclosing/ bindings (in cec_binds), but that may +not have enough stuff in scope for the bindings to be well typed. So +we just switch off deferred type errors altogether. See #14605. + +This is done by maybeSwitchOffDefer. It's also useful in one other +place: see Note [Wrapping failing kind equalities] in GHC.Tc.Solver. + +Note [Suppressing error messages] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The cec_suppress flag says "don't report any errors". Instead, just create +evidence bindings (as usual). It's used when more important errors have occurred. + +Specifically (see reportWanteds) + * If there are insoluble Givens, then we are in unreachable code and all bets + are off. So don't report any further errors. + * If there are any insolubles (eg Int~Bool), here or in a nested implication, + then suppress errors from the simple constraints here. Sometimes the + simple-constraint errors are a knock-on effect of the insolubles. + +This suppression behaviour is controlled by the Bool flag in +ReportErrorSpec, as used in reportWanteds. + +But we need to take care: flags can turn errors into warnings, and we +don't want those warnings to suppress subsequent errors (including +suppressing the essential addTcEvBind for them: #15152). So in +tryReporter we use askNoErrs to see if any error messages were +/actually/ produced; if not, we don't switch on suppression. + +A consequence is that warnings never suppress warnings, so turning an +error into a warning may allow subsequent warnings to appear that were +previously suppressed. (e.g. partial-sigs/should_fail/T14584) +-} + +reportImplic :: SolverReportErrCtxt -> Implication -> TcM () +reportImplic ctxt implic@(Implic { ic_skols = tvs + , ic_given = given + , ic_wanted = wanted, ic_binds = evb + , ic_status = status, ic_info = info + , ic_env = ct_loc_env + , ic_tclvl = tc_lvl }) + | BracketSkol <- info + , not insoluble + = return () -- For Template Haskell brackets report only + -- definite errors. The whole thing will be re-checked + -- later when we plug it in, and meanwhile there may + -- certainly be un-satisfied constraints + + | otherwise + = do { traceTc "reportImplic" $ vcat + [ text "tidy env:" <+> ppr (cec_tidy ctxt) + , text "skols: " <+> pprTyVars tvs + , text "tidy skols:" <+> pprTyVars tvs' ] + + ; when bad_telescope $ reportBadTelescope ctxt ct_loc_env info tvs + -- Do /not/ use the tidied tvs because then are in the + -- wrong order, so tidying will rename things wrongly + ; reportWanteds ctxt' tc_lvl wanted + + -- Report redundant (unused) constraints + ; warnRedundantConstraints ctxt' ct_loc_env info' dead_givens } + where + insoluble = isInsolubleStatus status + (env1, tvs') = tidyVarBndrs (cec_tidy ctxt) $ + scopedSort tvs + -- scopedSort: the ic_skols may not be in dependency order + -- (see Note [Skolems in an implication] in GHC.Tc.Types.Constraint) + -- but tidying goes wrong on out-of-order constraints; + -- so we sort them here before tidying + info' = tidySkolemInfoAnon env1 info + implic' = implic { ic_skols = tvs' + , ic_given = map (tidyEvVar env1) given + , ic_info = info' } + + ctxt1 = maybeSwitchOffDefer evb ctxt + ctxt' = ctxt1 { cec_tidy = env1 + , cec_encl = implic' : cec_encl ctxt + + , cec_suppress = insoluble || cec_suppress ctxt + -- Suppress inessential errors if there + -- are insolubles anywhere in the + -- tree rooted here, or we've come across + -- a suppress-worthy constraint higher up (#11541) + + , cec_binds = evb } + + dead_givens = case status of + IC_Solved { ics_dead = dead } -> dead + _ -> [] + + bad_telescope = case status of + IC_BadTelescope -> True + _ -> False + +warnRedundantConstraints :: SolverReportErrCtxt -> CtLocEnv -> SkolemInfoAnon -> [EvVar] -> TcM () +-- See Note [Tracking redundant constraints] in GHC.Tc.Solver +warnRedundantConstraints ctxt env info redundant_evs + | not (cec_warn_redundant ctxt) + = return () + + | null redundant_evs + = return () + + | SigSkol user_ctxt _ _ <- info + -- When dealing with a user-written type signature, + -- we want to add "In the type signature for f". + = report_redundant_msg True (setCtLocEnvLoc env (redundantConstraintsSpan user_ctxt)) + -- ^^^^ add "In the type signature..." + + | otherwise + -- But for InstSkol there already *is* a surrounding + -- "In the instance declaration for Eq [a]" context + -- and we don't want to say it twice. Seems a bit ad-hoc + = report_redundant_msg False env + -- ^^^^^ don't add "In the type signature..." + where + report_redundant_msg :: Bool -- whether to add "In the type signature..." to the diagnostic + -> CtLocEnv + -> TcRn () + report_redundant_msg show_info lcl_env + = do { msg <- + mkErrorReport lcl_env + (TcRnRedundantConstraints redundant_evs (info, show_info)) + (Just ctxt) [] [] + ; reportDiagnostic msg } + +reportBadTelescope :: SolverReportErrCtxt -> CtLocEnv -> SkolemInfoAnon -> [TcTyVar] -> TcM () +reportBadTelescope ctxt env (ForAllSkol telescope) skols + = do { msg <- mkErrorReport env + (TcRnSolverReport report ErrorWithoutFlag) + (Just ctxt) [] [] + ; reportDiagnostic msg } + where + report = SolverReportWithCtxt ctxt $ BadTelescope telescope skols + +reportBadTelescope _ _ skol_info skols + = pprPanic "reportBadTelescope" (ppr skol_info $$ ppr skols) + +-- | Should we completely ignore this constraint in error reporting? +-- It *must* be the case that any constraint for which this returns True +-- somehow causes an error to be reported elsewhere. +-- See Note [Constraints to ignore]. +ignoreConstraint :: Ct -> Bool +ignoreConstraint ct + = 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] +-- in GHC.Tc.Types.Constraint. Returns Nothing if we should just ignore +-- a constraint. See Note [Constraints to ignore]. +mkErrorItem :: Ct -> TcM (Maybe ErrorItem) +mkErrorItem ct + | ignoreConstraint ct + = do { traceTc "Ignoring constraint:" (ppr ct) + ; return Nothing } -- See Note [Constraints to ignore] + + | otherwise + = 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 {} -> (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 + _ -> Nothing + + ; return $ Just $ EI { ei_pred = ctPred ct + , ei_evdest = m_evdest + , ei_flavour = flav + , ei_loc = loc + , ei_m_reason = m_reason + , ei_suppress = suppress }} + +-- | Actually report this 'ErrorItem'. +unsuppressErrorItem :: ErrorItem -> ErrorItem +unsuppressErrorItem ei = ei { ei_suppress = False } + +---------------------------------------------------------------- +reportWanteds :: SolverReportErrCtxt -> TcLevel -> WantedConstraints -> TcM () +reportWanteds ctxt tc_lvl wc@(WC { wc_simple = simples, wc_impl = implics + , wc_errors = errs }) + | isEmptyWC wc = traceTc "reportWanteds empty WC" empty + | otherwise + = do { tidy_items1 <- mapMaybeM mkErrorItem tidy_cts + ; traceTc "reportWanteds 1" (vcat [ text "Simples =" <+> ppr simples + , text "Suppress =" <+> ppr (cec_suppress ctxt) + , text "tidy_cts =" <+> ppr tidy_cts + , text "tidy_items1 =" <+> ppr tidy_items1 + , text "tidy_errs =" <+> ppr tidy_errs ]) + + -- Catch an awkward (and probably rare) case in which /all/ errors are + -- 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 + -- (details in the defn of tidy_items) un-suppress the lot. This makes + -- sure we don't forget to report an error at all, which is + -- catastrophic: GHC proceeds to desguar and optimise the program, even + -- though it is full of type errors (#22702, #22793) + ; errs_already <- ifErrsM (return True) (return False) + ; let tidy_items + | not errs_already -- Have not already reported an error (perhaps + -- from an outer implication); see #21405 + , not (any ignoreConstraint simples) -- No error is ignorable (is reported elsewhere) + , all ei_suppress tidy_items1 -- All errors are suppressed + = map unsuppressErrorItem tidy_items1 + | otherwise + = tidy_items1 + + -- First, deal with any out-of-scope errors: + ; 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 $ + reportHoles tidy_items ctxt_for_scope_errs out_of_scope + + -- Next, deal with things that are utterly wrong + -- Like Int ~ Bool (incl nullary TyCons) + -- or Int ~ t a (AppTy on one side) + -- These /ones/ are not suppressed by the incoming context + -- (but will be by out-of-scope errors) + ; let ctxt_for_insols = ctxt { cec_suppress = not no_out_of_scope } + ; reportHoles tidy_items ctxt_for_insols other_holes + -- holes never suppress + + ; 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, reportable_items) = partition suppressItem tidy_items + ; traceTc "reportWanteds suppressed:" (ppr suppressed_items) + ; (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 } + ; (_, leftovers) <- tryReporters ctxt2 report2 items1 + ; massertPpr (null leftovers) + (text "The following unsolved Wanted constraints \ + \have not been reported to the user:" + $$ ppr leftovers) + + ; mapBagM_ (reportImplic ctxt2) implics + -- NB ctxt2: don't suppress inner insolubles if there's only a + -- wanted insoluble here; but do suppress inner insolubles + -- if there's a *given* insoluble here (= inaccessible code) + + -- 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], [(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 + -- It's crucial that anything that is considered insoluble + -- (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 = [ -- 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 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) + , ("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 + + is_given_eq item pred + | Given <- ei_flavour item + , EqPred {} <- pred = True + | otherwise = False + -- I think all given residuals are equalities + + -- Things like (Int ~N Bool) + utterly_wrong _ (EqPred NomEq ty1 ty2) = isRigidTy ty1 && isRigidTy ty2 + utterly_wrong _ _ = False + + -- Things like (a ~N Int) + very_wrong _ (EqPred NomEq ty1 ty2) = isSkolemTy tc_lvl ty1 && isRigidTy ty2 + very_wrong _ _ = False + + -- Representation-polymorphism errors, to be reported using mkFRRErr. + is_FRR item _ = isJust $ fixedRuntimeRepOrigin_maybe item + + -- Things like (a ~N b) or (a ~N F Bool) + skolem_eq _ (EqPred NomEq ty1 _) = isSkolemTy tc_lvl ty1 + skolem_eq _ _ = False + + -- Things like (F a ~N Int) + non_tv_eq _ (EqPred NomEq ty1 _) = not (isTyVarTy ty1) + non_tv_eq _ _ = False + + -- Catch TypeError and Unsatisfiable. + -- Here, we want any nested TypeErrors to bubble up, so we use + -- 'containsUserTypeError' and not 'isTopLevelUserTypeError'. + -- + -- 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 _ _ + = False + + is_equality _(EqPred {}) = True + is_equality _ _ = False + + is_dict _ (ClassPred {}) = True + is_dict _ _ = False + + is_ip _ (ClassPred cls _) = isIPClass cls + is_ip _ _ = False + + is_irred _ (IrredPred {}) = True + is_irred _ _ = False + + is_qc _ (ForAllPred {}) = True + is_qc _ _ = False + + given_eq_spec -- See Note [Given errors] + | has_gadt_match_here + = ("insoluble1a", is_given_eq, True, mkGivenErrorReporter) + | otherwise + = ("insoluble1b", is_given_eq, False, ignoreErrorReporter) + -- False means don't suppress subsequent errors + -- Reason: we don't report all given errors + -- (see mkGivenErrorReporter), and we should only suppress + -- subsequent errors if we actually report this one! + -- #13446 is an example + + -- See Note [Given errors] + has_gadt_match_here = has_gadt_match (cec_encl ctxt) + has_gadt_match [] = False + has_gadt_match (implic : implics) + | PatSkol {} <- ic_info implic + , ic_given_eqs implic /= NoGivenEqs + , ic_warn_inaccessible implic + -- Don't bother doing this if -Winaccessible-code isn't enabled. + -- See Note [Avoid -Winaccessible-code when deriving] in GHC.Tc.TyCl.Instance. + = True + | otherwise + = 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 + | Just tv <- getTyVar_maybe ty + = isSkolemTyVar tv + || (isTyVarTyVar tv && isTouchableMetaTyVar tc_lvl tv) + -- The last case is for touchable TyVarTvs + -- we postpone untouchables to a latter test (too obscure) + + | otherwise + = False + +isTyFun_maybe :: Type -> Maybe TyCon +isTyFun_maybe ty = case tcSplitTyConApp_maybe ty of + Just (tc,_) | isTypeFamilyTyCon tc -> Just tc + _ -> Nothing + +{- Note [Suppressing confusing errors] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +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 are suppressed? + +(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 + op :: a -> b -> b + + foo _ = op True Nothing + + bar _ = op False [] + + Here, we could infer + foo :: C Bool (Maybe a) => p -> Maybe a + bar :: C Bool [a] => p -> [a] + + (The unused arguments suppress the monomorphism restriction.) The problem + is that these types can't both be correct, as they violate the functional + dependency. Yet reporting an error here is awkward: we must + non-deterministically choose either foo or bar to reject. We thus want + to report this problem only when there is nothing else to report. + See typecheck/should_fail/T13506 for an example of when to suppress + the error. The case above is actually accepted, because foo and bar + are checked separately, and thus the two fundep constraints never + encounter each other. It is test case typecheck/should_compile/FunDepOrigin1. + + This case applies only when both fundeps are *Wanted* fundeps; when + both are givens, the error represents unreachable code. For + a Given/Wanted case, see #9612. + +Mechanism: + +We use the `suppress` function within reportWanteds to filter out these two +cases, then report all other errors. Lastly, we return to these suppressed +ones and report them only if there have been no errors so far. + +Note [Constraints to ignore] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Some constraints are meant only to aid the solver by unification; a failure +to solve them is not necessarily an error to report to the user. It is critical +that compilation is aborted elsewhere if there are any ignored constraints here; +they will remain unfilled, and might have been used to rewrite another constraint. + +Currently, the constraints to ignore are: + +(CIG1) Constraints generated in order to unify associated type instance parameters + with class parameters. Here are two illustrative examples: + + class C (a :: k) where + type F (b :: k) + + instance C True where + type F a = Int + + instance C Left where + type F (Left :: a -> Either a b) = Bool + + In the first instance, we want to infer that `a` has type Bool. So we emit + a constraint unifying kappa (the guessed type of `a`) with Bool. All is well. + + In the second instance, we process the associated type instance only + after fixing the quantified type variables of the class instance. We thus + have skolems a1 and b1 such that the class instance is for (Left :: a1 -> Either a1 b1). + Unifying a1 and b1 with a and b in the type instance will fail, but harmlessly so. + checkConsistentFamInst checks for this, and will fail if anything has gone + awry. Really the equality constraints emitted are just meant as an aid, not + a requirement. This is test case T13972. + + We detect this case by looking for an origin of AssocFamPatOrigin; constraints + with this origin are dropped entirely during error message reporting. + + 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). +See Note [The Unsatisfiable constraint] in GHC.TypeError. + +Its implementation consists of the following: + + A. The definitions. + + The Unsatisfiable class is defined in GHC.TypeError, in base. + It consists of the following definitions: + + type Unsatisfiable :: ErrorMessage -> Constraint + class Unsatisfiable msg where + unsatisfiableLifted :: a + + unsatisfiable :: forall {rep} (msg :: ErrorMessage) (a :: TYPE rep). Unsatisfiable msg => a + unsatisfiable = unsatisfiableLifted @msg @((##) -> a) (##) + + The class TyCon as well as the unsatisfiable Id have known-key Names + in GHC; they are not wired-in. + + B. Unsatisfiable instances. + + The Unsatisfiable typeclass has no instances (see GHC.Tc.Instance.Class.matchGlobalInst). + + Users are prevented from writing instances in GHC.Tc.Validity.check_special_inst_head. + This is done using the same mechanism as for, say, Coercible or WithDict. + + C. Using [G] Unsatisfiable msg to solve any Wanted. + + In GHC.Tc.Solver.simplifyTopWanteds, after defaulting happens, when an + implication contains Givens of the form [G] Unsatisfiable msg, and the + implication supports term-level evidence (as per Note [Coercion evidence only] + in GHC.Tc.Types.Evidence), we use any such Given to solve all the Wanteds + in that implication. See GHC.Tc.Solver.useUnsatisfiableGivens. + + The way we construct the evidence terms is slightly complicated by + Type vs Constraint considerations; see Note [Evidence terms from Unsatisfiable Givens] + in GHC.Tc.Solver. + + The proposal explains why this happens after defaulting: if there are other + ways to solve the Wanteds, we would prefer to use that, as that will make + user programs "as defined as possible". + + Wrinkle [Ambiguity] + + We also use an Unsatisfiable Given to solve Wanteds when performing an + ambiguity check. See the call to "useUnsatisfiableGivens" in + GHC.Tc.Solver.simplifyAmbiguityCheck. + + This is, for example, required to typecheck the definition + of "unsatisfiable" itself: + + unsatisfiable :: forall {rep} (msg :: ErrorMessage) (a :: TYPE rep). Unsatisfiable msg => a + + The ambiguity check on this type signature will produce + + [G] Unsatisfiable msg1, [W] Unsatisfiable msg2 + + and we want to ensure the Given solves the Wanted, to accept the definition. + + NB: + + An alternative would be to add a functional dependency on Unsatisfiable: + + class Unsatisfiable msg | -> msg + + Then we would unify msg1 and msg2 in the above constraint solving problem, + and would be able to solve the Wanted using the Given in the normal way. + However, adding such a functional dependency solely for this purpose + could have undesirable consequences. For example, one might have + + [W] Unsatisfiable (Text "msg1"), [W] Unsatisfiable (Text "msg2") + + and W-W fundep interaction would produce the insoluble constraint + + [W] "msg1" ~ "msg2" + + which we definitely wouldn't want to report to the user. + + D. Adding "meth = unsatisfiable @msg" method bindings. + + When a class instance has an "Unsatisfiable msg" constraint in its context, + and the user has omitted methods, we add method bindings of the form + "meth = unsatisfiable @msg". + See GHC.Tc.TyCl.Instance.tcMethods, in particular "tc_default". + + Example: + + class C a where { op :: a -> a } + instance Unsatisfiable Msg => C [a] where {} + + elaborates to + + instance Unsatisfiable Msg => C [a] where { op = unsatisfiable @Msg } + + due to the (Unsatisfiable Msg) constraint in the instance context. + + We also switch off the "missing methods" warning in this situation. + See "checkMinimalDefinition" in GHC.Tc.TyCl.Instance.tcMethods. + + Note that we do this even when there is a default method available. This + ensures we run into the unsatisfiable error message when deferring type + errors; otherwise we could end up with a runtime loop as seen in #23816. + + E. Switching off functional dependency coverage checks when there is + an "Unsatisfiable msg" context. + + This is because we want to allow users to rule out certain instances with + an "unsatisfiable" error, even when that would violate a functional + dependency. For example: + + class C a b | a -> b + instance Unsatisfiable (Text "No") => C a b + + See GHC.Tc.Instance.FunDeps.checkInstCoverage. + + F. Error reporting of "Unsatisfiable msg" constraints. + + This is done in GHC.Tc.Errors.reportWanteds: we detect when a constraint + is of the form "Unsatisfiable msg" and just emit the custom message + as an error to the user. + + This is the only way that "Unsatisfiable msg" constraints are reported, + which makes their behaviour much more predictable than TypeError. +-} + + +-------------------------------------------- +-- Reporters +-------------------------------------------- + +type Reporter + = SolverReportErrCtxt -> NonEmpty ErrorItem -> TcM () +type ReporterSpec + = ( String -- Name + , ErrorItem -> Pred -> Bool -- Pick these ones + , Bool -- True <=> suppress subsequent reporters + , Reporter) -- The reporter itself + +mkSkolReporter :: Reporter +-- Suppress duplicates with either the same LHS, or same location +-- Pre-condition: all items are equalities +mkSkolReporter ctxt items + = mapM_ (reportGroup (mkEqErr ctxt) ctxt) (group (toList items)) + where + group [] = [] + group (item:items) = (item :| yeses) : group noes + where + (yeses, noes) = partition (group_with item) items + + group_with item1 item2 + | EQ <- cmp_loc item1 item2 = True + | eq_lhs_type item1 item2 = True + | otherwise = False + +reportHoles :: [ErrorItem] -- other (tidied) constraints + -> SolverReportErrCtxt -> [Hole] -> TcM () +reportHoles tidy_items ctxt holes + = do + diag_opts <- initDiagOpts <$> getDynFlags + let severity = diagReasonSeverity diag_opts (cec_type_holes ctxt) + holes' = filter (keepThisHole severity) holes + -- Zonk and tidy all the TcLclEnvs before calling `mkHoleError` + -- because otherwise types will be zonked and tidied many times over. + (tidy_env', lcl_name_cache) <- liftZonkM $ + zonkTidyTcLclEnvs (cec_tidy ctxt) (map (ctl_env . hole_loc) holes') + let ctxt' = ctxt { cec_tidy = tidy_env' } + forM_ holes' $ \hole -> do { msg <- mkHoleError lcl_name_cache tidy_items ctxt' hole + ; reportDiagnostic msg } + +keepThisHole :: Severity -> Hole -> Bool +-- See Note [Skip type holes rapidly] +keepThisHole sev hole + = case hole_sort hole of + ExprHole {} -> True + TypeHole -> keep_type_hole + ConstraintHole -> keep_type_hole + where + keep_type_hole = case sev of + SevIgnore -> False + _ -> True + +-- | zonkTidyTcLclEnvs takes a bunch of 'CtLocEnv's, each from a Hole. +-- It returns a ('Name' :-> 'Type') mapping which gives the zonked, tidied +-- type for each Id in any of the binder stacks in the 'CtLocEnv's. +-- Since there is a huge overlap between these stacks, is is much, +-- much faster to do them all at once, avoiding duplication. +zonkTidyTcLclEnvs :: TidyEnv -> [CtLocEnv] -> ZonkM (TidyEnv, NameEnv Type) +zonkTidyTcLclEnvs tidy_env lcls = foldM go (tidy_env, emptyNameEnv) (concatMap ctl_bndrs lcls) + where + go envs tc_bndr = case tc_bndr of + TcTvBndr {} -> return envs + TcIdBndr id _top_lvl -> go_one (idName id) (idType id) envs + TcIdBndr_ExpType name et _top_lvl -> + do { mb_ty <- liftIO $ readExpType_maybe et + -- et really should be filled in by now. But there's a chance + -- it hasn't, if, say, we're reporting a kind error en route to + -- checking a term. See test indexed-types/should_fail/T8129 + -- Or we are reporting errors from the ambiguity check on + -- a local type signature + ; case mb_ty of + Just ty -> go_one name ty envs + Nothing -> return envs + } + go_one name ty (tidy_env, name_env) = do + if name `elemNameEnv` name_env + then return (tidy_env, name_env) + else do + (tidy_env', tidy_ty) <- zonkTidyTcType tidy_env ty + return (tidy_env', extendNameEnv name_env name tidy_ty) + +reportNotConcreteErrs :: SolverReportErrCtxt -> [NotConcreteError] -> TcM () +reportNotConcreteErrs _ [] = return () +reportNotConcreteErrs ctxt errs@(err0:_) + = do { msg <- mkErrorReport (ctLocEnv (nce_loc err0)) diag (Just ctxt) [] [] + ; reportDiagnostic msg } + + where + + frr_origins = acc_errors errs + diag = TcRnSolverReport + (SolverReportWithCtxt ctxt (FixedRuntimeRepError frr_origins)) + ErrorWithoutFlag + + -- Accumulate the different kind of errors arising from syntactic equality. + -- (Only SynEq_FRR origin for the moment.) + acc_errors = go [] + where + go frr_errs [] = frr_errs + go frr_errs (err:errs) + | frr_errs <- go frr_errs errs + = case err of + NCE_FRR + { nce_frr_origin = frr_orig } -> + FRR_Info + { frr_info_origin = frr_orig + , 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 +compile it while suppressing partial-type-signature warnings. Then +we don't want to spend ages constructing error messages and lists of +relevant bindings that we never display! This happened in #14766, in +which partial type signatures in a Happy-generated parser cause a huge +increase in compile time. + +The function ignoreThisHole short-circuits the error/warning generation +machinery, in cases where it is definitely going to be a no-op. +-} + +mkUserTypeErrorReporter :: Reporter +mkUserTypeErrorReporter ctxt + = mapM_ $ \item -> do { let err = important ctxt $ mkUserTypeError item + ; maybeReportError ctxt (item :| []) err + ; addSolverDeferredBinding err item } + +mkUserTypeError :: ErrorItem -> TcSolverReportMsg +mkUserTypeError item + | Just msg <- getUserTypeErrorMsg pty + = UserTypeError msg + | Just msg <- isUnsatisfiableCt_maybe pty + = UnsatisfiableError msg + | otherwise + = pprPanic "mkUserTypeError" (ppr item) + 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 = + case cec_encl ctxt of + -- cec_encl is always non-empty when mkGivenErrorReporter is called + outer_implic:_ -> outer_implic + _ -> pprPanic "mkGivenErrorReporter" (ppr item) + + loc' = setCtLocEnv (ei_loc item) (ic_env implic) + item' = item { ei_loc = loc' } + -- For given constraints we overwrite the env (and hence src-loc) + -- with one from the immediately-enclosing implication. + -- See Note [Inaccessible code] + + ; eq_err_msg <- mkEqErr_help ctxt item' ty1 ty2 + ; let 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) + +ignoreErrorReporter :: Reporter +-- Discard Given errors that don't come from +-- a pattern match; maybe we should warn instead? +ignoreErrorReporter ctxt items + = do { traceTc "mkGivenErrorReporter no" (ppr items $$ ppr (cec_encl ctxt)) + ; return () } + + +{- Note [Given errors] +~~~~~~~~~~~~~~~~~~~~~~ +Given constraints represent things for which we have (or will have) +evidence, so they aren't errors. But if a Given constraint is +insoluble, this code is inaccessible, and we might want to at least +warn about that. A classic case is + + data T a where + T1 :: T Int + T2 :: T a + T3 :: T Bool + + f :: T Int -> Bool + f T1 = ... + f T2 = ... + f T3 = ... -- We want to report this case as inaccessible + +We'd like to point out that the T3 match is inaccessible. It +will have a Given constraint [G] Int ~ Bool. + +But we don't want to report ALL insoluble Given constraints. See Trac +#12466 for a long discussion. For example, if we aren't careful +we'll complain about + f :: ((Int ~ Bool) => a -> a) -> Int +which arguably is OK. It's more debatable for + g :: (Int ~ Bool) => Int -> Int +but it's tricky to distinguish these cases so we don't report +either. + +The bottom line is this: has_gadt_match looks for an enclosing +pattern match which binds some equality constraints. If we +find one, we report the insoluble Given. +-} + +mkGroupReporter :: (SolverReportErrCtxt -> NonEmpty ErrorItem -> TcM SolverReport) + -- Make error message for a group + -> Reporter -- Deal with lots of constraints +-- 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) ctxt) (equivClasses cmp_loc (toList items)) + +eq_lhs_type :: ErrorItem -> ErrorItem -> Bool +eq_lhs_type item1 item2 + = case (classifyPredType (errorItemPred item1), classifyPredType (errorItemPred item2)) of + (EqPred eq_rel1 ty1 _, EqPred eq_rel2 ty2 _) -> + (eq_rel1 == eq_rel2) && (ty1 `eqType` ty2) + _ -> pprPanic "mkSkolReporter" (ppr item1 $$ ppr item2) + +cmp_loc :: ErrorItem -> ErrorItem -> Ordering +cmp_loc item1 item2 = get item1 `compare` get item2 + where + get ei = realSrcSpanStart (ctLocSpan (errorItemCtLoc ei)) + -- Reduce duplication by reporting only one error from each + -- /starting/ location even if the end location differs + +reportGroup :: (NonEmpty ErrorItem -> TcM SolverReport) -> Reporter +reportGroup 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) + , text "cec_defer_type_errors =" <+> ppr (cec_defer_type_errors ctxt) ] + ; maybeReportError ctxt items err + -- But see Note [Always warn with -fdefer-type-errors] + ; traceTc "reportGroup" (ppr 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 + -- abort, we need bindings for all (e.g. #12156) + +-- See Note [No deferring for multiplicity errors] +nonDeferrableOrigin :: CtOrigin -> Bool +nonDeferrableOrigin (NonLinearPatternOrigin {}) = True +nonDeferrableOrigin (OmittedFieldOrigin {}) = True +nonDeferrableOrigin (UsageEnvironmentOf {}) = True +nonDeferrableOrigin (FRROrigin {}) = True +nonDeferrableOrigin _ = False + +maybeReportError :: SolverReportErrCtxt + -> NonEmpty ErrorItem -- items covered by the Report + -> SolverReport -> TcM () +maybeReportError ctxt items@(item1:|_) (SolverReport { sr_important_msg = important + , sr_supplementary = supp + , sr_hints = hints }) + = unless (cec_suppress ctxt -- Some worse error has occurred, so suppress this diagnostic + || all ei_suppress items) $ + -- if they're all to be suppressed, report nothing + -- if at least one is not suppressed, do report: + -- the function that generates the error message + -- should look for an unsuppressed error item + 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 + msg <- mkErrorReport (ctLocEnv (errorItemCtLoc item1)) diag (Just ctxt) supp hints + reportDiagnostic msg + +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 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 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 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 EvNonCanonical err_tm + ; fillCoercionHole hole (mkCoVarCo co_var) } } +addDeferredBinding _ _ _ _ _ = return () -- Do not set any evidence for Given + +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) + 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 + err_str = showSDoc dflags $ + err_msg $$ text "(deferred type error)" + + ; return $ evDelayedError ty err_str } + +tryReporters :: SolverReportErrCtxt -> [ReporterSpec] -> [ErrorItem] -> TcM (SolverReportErrCtxt, [ErrorItem]) +-- Use the first reporter in the list whose predicate says True +tryReporters ctxt reporters items + = do { let (vis_items, invis_items) + = partition (isVisibleOrigin . errorItemOrigin) items + ; traceTc "tryReporters {" (ppr vis_items $$ ppr invis_items) + ; (ctxt', items') <- go ctxt reporters vis_items invis_items + ; traceTc "tryReporters }" (ppr items') + ; return (ctxt', items') } + where + go ctxt [] vis_items invis_items + = return (ctxt, vis_items ++ invis_items) + + go ctxt (r : rs) vis_items invis_items + -- always look at *visible* Origins before invisible ones + -- this is the whole point of isVisibleOrigin + = do { (ctxt', vis_items') <- tryReporter ctxt r vis_items + ; (ctxt'', invis_items') <- tryReporter ctxt' r invis_items + ; go ctxt'' rs vis_items' invis_items' } + -- Carry on with the rest, because we must make + -- deferred bindings for them if we have -fdefer-type-errors + -- But suppress their error messages + +tryReporter :: SolverReportErrCtxt -> ReporterSpec -> [ErrorItem] -> TcM (SolverReportErrCtxt, [ErrorItem]) +tryReporter ctxt (str, keep_me, suppress_after, reporter) items = case nonEmpty yeses of + Nothing -> pure (ctxt, items) + Just yeses -> do + { traceTc "tryReporter{ " (text str <+> ppr yeses) + ; (_, no_errs) <- askNoErrs (reporter ctxt yeses) + ; let suppress_now = not no_errs && suppress_after + -- See Note [Suppressing error messages] + ctxt' = ctxt { cec_suppress = suppress_now || cec_suppress ctxt } + ; traceTc "tryReporter end }" (text str <+> ppr (cec_suppress ctxt) <+> ppr suppress_after) + ; return (ctxt', nos) } + where + (yeses, nos) = partition keep items + keep item = keep_me item (classifyPredType (errorItemPred item)) + +-- | Wrap an input 'TcRnMessage' with additional contextual information, +-- such as relevant bindings or valid hole fits. +mkErrorReport :: CtLocEnv + -> TcRnMessage + -- ^ The main payload of the message. + -> Maybe SolverReportErrCtxt + -- ^ The context to add, after the main diagnostic + -- but before the supplementary information. + -- Nothing <=> don't add any context. + -> [SupplementaryInfo] + -- ^ Supplementary information, to be added at the end of the message. + -> [GhcHint] + -- ^ Suggested fixes + -> TcM (MsgEnvelope TcRnMessage) +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 [] 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) } + +{- Note [Always warn with -fdefer-type-errors] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When -fdefer-type-errors is on we warn about *all* type errors, even +if cec_suppress is on. This can lead to a lot more warnings than you +would get errors without -fdefer-type-errors, but if we suppress any of +them you might get a runtime error that wasn't warned about at compile +time. + +To be consistent, we should also report multiple warnings from a single +location in mkGroupReporter, when -fdefer-type-errors is on. But that +is perhaps a bit *over*-consistent! + +With #10283, you can now opt out of deferred type error warnings. + +Note [No deferring for multiplicity errors] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +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 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 delayed error would +shadow the type mismatch warnings (#20083). As a solution, we refuse to defer +submultiplicity constraints. Test: T20083. + +To determine whether a constraint arose from a submultiplicity check, we +look at the CtOrigin. All calls to tcSubMult use origins which are not +used outside of linear types. + +In the future, we should compile 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] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we need to defer a type error where the destination for the evidence +is a coercion hole. We can't just put the error in the hole, because we can't +make an erroneous coercion. (Remember that coercions are erased for runtime.) +Instead, we invent a new EvVar, bind it to an error and then make a coercion +from that EvVar, filling the hole with that coercion. Because coercions' +types are unlifted, the error is guaranteed to be hit before we get to the +coercion. + +************************************************************************ +* * + Irreducible predicate errors +* * +************************************************************************ +-} + +mkIrredErr :: SolverReportErrCtxt -> NonEmpty ErrorItem -> TcM SolverReport +mkIrredErr ctxt items + = do { (ctxt, binds, item1) <- relevantBindings True ctxt item1 + ; let msg = important ctxt $ mkPlainMismatchMsg $ + CouldNotDeduce (getUserGivens ctxt) (item1 :| others) Nothing + ; return $ add_relevant_bindings binds msg } + where + item1:|others = tryFilter (not . ei_suppress) items + +{- 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! + +There are two cases to consider: + +1. For out-of-scope variables we always report an error, unless -fdefer-out-of-scope-variables is on, + in which case the messages are discarded. See also #12170 and #12406. If deferring, report a warning + only if -Wout-of-scope-variables is on. + +2. For the general case, when -XPartialTypeSignatures is on, warnings (instead of errors) are generated + for holes in partial type signatures, unless -Wpartial-type-signatures is not on, in which case + the messages are discarded. If deferring, report a warning only if -Wtyped-holes is on. + +The above can be summarised into the following table: + +| Hole Type | Active Flags | Outcome | +|--------------|----------------------------------------------------------|------------------| +| out-of-scope | None | Error | +| out-of-scope | -fdefer-out-of-scope-variables, -Wout-of-scope-variables | Warning | +| out-of-scope | -fdefer-out-of-scope-variables | Ignore (discard) | +| type | None | Error | +| type | -XPartialTypeSignatures, -Wpartial-type-signatures | Warning | +| type | -XPartialTypeSignatures | Ignore (discard) | +| expression | None | Error | +| expression | -Wdefer-typed-holes, -Wtyped-holes | Warning | +| expression | -Wdefer-typed-holes | Ignore (discard) | + +See also 'reportUnsolved'. + +-} + +---------------- +-- | 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_sort = sort, hole_occ = occ, hole_loc = ct_loc }) + | isOutOfScopeHole hole + = do { (imp_errs, hints) + <- unknownNameSuggestions (ctl_rdr lcl_env) what_look occ + ; let + err = SolverReportWithCtxt ctxt + $ ReportHoleError hole OutOfScopeHole + supp = [ SupplementaryImportErrors imps | imps <- maybeToList (NE.nonEmpty imp_errs) ] + + ; 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 +mkHoleError lcl_name_cache tidy_simples ctxt + hole@(Hole { hole_ty = hole_ty + , hole_sort = sort + , hole_loc = ct_loc }) + = do { rel_binds + <- relevant_bindings False lcl_env lcl_name_cache (tyCoVarsOfType hole_ty) + -- The 'False' means "don't filter the bindings"; see #8191 + + ; show_hole_constraints <- goptM Opt_ShowHoleConstraints + ; let relevant_cts + | ExprHole _ <- sort, show_hole_constraints + = givenConstraints ctxt + | otherwise + = [] + + ; show_valid_hole_fits <- goptM Opt_ShowValidHoleFits + ; (ctxt, hole_fits) <- if show_valid_hole_fits + then validHoleFits ctxt tidy_simples hole + else return (ctxt, noValidHoleFits) + ; (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 cts | cts <- maybeToList (NE.nonEmpty relevant_cts) ] + ++ [ SupplementaryHoleFits hole_fits ] + + ; maybeAddDeferredBindings hole (SolverReport err supp noHints) + ; let msg = TcRnSolverReport err reason + ; mkErrorReport lcl_env msg (Just ctxt) supp noHints + } + + where + lcl_env = ctLocEnv ct_loc + +-- | For all the skolem type variables in a type, zonk the skolem info and group together +-- all the type variables with the same origin. +zonkAndGroupSkolTvs :: Type -> ZonkM ([(SkolemInfoAnon, [TcTyVar])], [TcTyVar]) +zonkAndGroupSkolTvs hole_ty = do + zonked_info <- mapM zonk_skolem_info skolem_list + return (zonked_info, other_tvs) + where + zonk_skolem_info (sk, tv) = + do { sk <- zonkSkolemInfoAnon $ getSkolemInfo sk + ; return (sk, fst <$> tv) } + tvs = tyCoVarsOfTypeList hole_ty + (skol_tvs, other_tvs) = partition (isTcTyVar <&&> isSkolemTyVar) tvs + + group_skolems :: UM.UniqMap SkolemInfo ([(TcTyVar, Int)]) + group_skolems = bagToList <$> + UM.listToUniqMap_C unionBags + [(skolemSkolInfo tv, unitBag (tv, n)) | tv <- skol_tvs | n <- [0..]] + + skolem_list = sortBy (comparing (sort . map snd . snd)) + $ UM.nonDetUniqMapToList group_skolems + +{- 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 :: Hole + -> SolverReport + -> TcM () +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 <- mkSolverErrorTerm (hole_loc hole) ref_ty report + -- NB: ref_ty, not hole_ty. hole_ty might be rewritten. + -- 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 +validHoleFits :: SolverReportErrCtxt -- ^ The context we're in, i.e. the + -- implications and the tidy environment + -> [ErrorItem] -- ^ Unsolved simple constraints + -> Hole -- ^ The hole + -> TcM (SolverReportErrCtxt, ValidHoleFits) + -- ^ We return the new context + -- with a possibly updated + -- tidy environment, and + -- the valid hole fits. +validHoleFits ctxt@(CEC { cec_encl = implics + , cec_tidy = lcl_env}) simps hole + = do { (tidy_env, fits) <- findValidHoleFits lcl_env implics (mapMaybe mk_wanted simps) hole + ; return (ctxt {cec_tidy = tidy_env}, fits) } + where + mk_wanted :: ErrorItem -> Maybe CtEvidence + mk_wanted (EI { ei_pred = pred, ei_evdest = m_dest, ei_loc = loc }) + | Just dest <- m_dest + = Just $ CtWanted $ + WantedCt { ctev_pred = pred + , ctev_dest = dest + , ctev_loc = loc + , ctev_rewriters = emptyRewriterSet } + | otherwise + = Nothing -- The ErrorItem was a Given + + +-- See Note [Constraints include ...] +givenConstraints :: SolverReportErrCtxt -> [(Type, RealSrcSpan)] +givenConstraints ctxt + = do { implic@Implic{ ic_given = given } <- cec_encl ctxt + ; constraint <- given + ; return (varType constraint, getCtLocEnvLoc (ic_env implic)) } + +---------------- + +mkIPErr :: SolverReportErrCtxt -> NonEmpty ErrorItem -> TcM SolverReport +-- What would happen if an item is suppressed because of +-- Note [Wanteds rewrite Wanteds] in GHC.Tc.Types.Constraint? Very unclear +-- what's best. Let's not worry about this. +mkIPErr ctxt (item1:|others) + = do { (ctxt, binds, item1) <- relevantBindings True ctxt item1 + ; let msg = important ctxt $ UnboundImplicitParams (item1 :| others) + ; return $ add_relevant_bindings binds msg } + +---------------- + +-- | Report a representation-polymorphism error to the user: +-- a type is required to have a fixed runtime representation, +-- but doesn't. +-- +-- See Note [Reporting representation-polymorphism errors] in GHC.Tc.Types.Origin. +mkFRRErr :: HasDebugCallStack => SolverReportErrCtxt -> NonEmpty ErrorItem -> TcM SolverReport +mkFRRErr ctxt items + = do { -- Process the error items. + ; (_tidy_env, frr_infos) <- + liftZonkM $ zonkTidyFRRInfos (cec_tidy ctxt) $ + -- 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 . fixedRuntimeRepOrigin_maybe) $ + toList items + ; return $ important ctxt $ FixedRuntimeRepError frr_infos } + +-- | Whether to report something using the @FixedRuntimeRep@ mechanism. +fixedRuntimeRepOrigin_maybe :: HasDebugCallStack => ErrorItem -> Maybe FixedRuntimeRepErrorInfo +fixedRuntimeRepOrigin_maybe item + -- An error that arose directly from a representation-polymorphism check. + | FRROrigin frr_orig <- orig + = Just $ FRR_Info { frr_info_origin = frr_orig + , frr_info_not_concrete = Nothing + , frr_info_other_origin = Nothing + } + -- A nominal equality involving a concrete type variable, + -- such as @alpha[conc] ~# rr[sk]@ or @beta[conc] ~# RR@ for a + -- type family application @RR@. + | EqPred NomEq ty1 ty2 <- classifyPredType (errorItemPred item) + = if | Just (tv1, ConcreteFRR frr1) <- isConcreteTyVarTy_maybe ty1 + -> Just $ FRR_Info frr1 (Just (tv1, ty2)) (Just 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 ...] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +'givenConstraintsMsg' returns the "Constraints include ..." message enabled by +-fshow-hole-constraints. For example, the following hole: + + foo :: (Eq a, Show a) => a -> String + foo x = _ + +would generate the message: + + Constraints include + Eq a (from foo.hs:1:1-36) + Show a (from foo.hs:1:1-36) + +Constraints are displayed in order from innermost (closest to the hole) to +outermost. There's currently no filtering or elimination of duplicates. + +************************************************************************ +* * + Equality errors +* * +************************************************************************ + +Note [Inaccessible code] +~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + data T a where + T1 :: T a + T2 :: T Bool + + f :: (a ~ Int) => T a -> Int + f T1 = 3 + f T2 = 4 -- Unreachable code + +Here the second equation is unreachable. The original constraint +(a~Int) from the signature gets rewritten by the pattern-match to +(Bool~Int), so the danger is that we report the error as coming from +the *signature* (#7293). So, for Given errors we replace the +env (and hence src-loc) on its CtLoc with that from the immediately +enclosing implication. + +Note [Error messages for untouchables] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider (#9109) + data G a where { GBool :: G Bool } + foo x = case x of GBool -> True + +Here we can't solve (t ~ Bool), where t is the untouchable result +meta-var 't', because of the (a ~ Bool) from the pattern match. +So we infer the type + f :: forall a t. G a -> t +making the meta-var 't' into a skolem. So when we come to report +the unsolved (t ~ Bool), t won't look like an untouchable meta-var +any more. So we don't assert that it is. +-} + +-- Don't have multiple equality errors from the same location +-- E.g. (Int,Bool) ~ (Bool,Int) one error will do! +mkEqErr :: SolverReportErrCtxt -> NonEmpty ErrorItem -> TcM SolverReport +mkEqErr ctxt items + | item1 :| _ <- tryFilter (not . ei_suppress) items + = mkEqErr1 ctxt item1 + +mkEqErr1 :: SolverReportErrCtxt -> ErrorItem -> TcM SolverReport +mkEqErr1 ctxt item -- Wanted only + -- givens handled in mkGivenErrorReporter + = do { (ctxt, binds, item) <- relevantBindings True ctxt item + ; traceTc "mkEqErr1" (ppr item $$ pprCtOrigin (errorItemOrigin item)) + ; err_msg <- mkEqErr_help ctxt item ty1 ty2 + ; let + report = add_relevant_bindings binds + $ important ctxt err_msg + ; return report } + where + (ty1, ty2) = getEqPredTys (errorItemPred item) + +-- | This function tries to reconstruct why a "Coercible ty1 ty2" constraint +-- is left over. +mkCoercibleExplanation :: GlobalRdrEnv -> FamInstEnvs + -> TcType -> TcType -> Maybe CoercibleMsg +mkCoercibleExplanation rdr_env fam_envs ty1 ty2 + | Just (tc, tys) <- tcSplitTyConApp_maybe ty1 + , (rep_tc, _, _) <- tcLookupDataFamInst fam_envs tc tys + , Just msg <- coercible_msg_for_tycon rep_tc + = Just msg + | Just (tc, tys) <- splitTyConApp_maybe ty2 + , (rep_tc, _, _) <- tcLookupDataFamInst fam_envs tc tys + , Just msg <- coercible_msg_for_tycon rep_tc + = Just msg + | Just (s1, _) <- tcSplitAppTy_maybe ty1 + , Just (s2, _) <- tcSplitAppTy_maybe ty2 + , s1 `eqType` s2 + , has_unknown_roles s1 + = Just $ UnknownRoles s1 + | otherwise + = Nothing + where + coercible_msg_for_tycon tc + | isAbstractTyCon tc + = Just $ TyConIsAbstract tc + | isNewTyCon tc + , [data_con] <- tyConDataCons tc + , let dc_name = dataConName data_con + , isNothing (lookupGRE_Name rdr_env dc_name) + = Just $ OutOfScopeNewtypeConstructor tc data_con + | otherwise = Nothing + + has_unknown_roles ty + | Just (tc, tys) <- tcSplitTyConApp_maybe ty + = tys `lengthAtLeast` tyConArity tc -- oversaturated tycon + | Just (s, _) <- tcSplitAppTy_maybe ty + = has_unknown_roles s + | isTyVarTy ty + = True + | otherwise + = False + +mkEqErr_help :: SolverReportErrCtxt + -> ErrorItem + -> TcType -> TcType -> TcM TcSolverReportMsg +mkEqErr_help ctxt item ty1 ty2 + | Just (tv1, _co) <- getCastedTyVar_maybe ty1 + = mkTyVarEqErr ctxt item tv1 ty2 + + -- ToDo: explain.. Cf T2627b Dual (Dual a) ~ a + | Just (tv2, _co) <- getCastedTyVar_maybe ty2 + = mkTyVarEqErr ctxt item tv2 ty1 + + | otherwise + = reportEqErr ctxt item ty1 ty2 + +reportEqErr :: SolverReportErrCtxt + -> ErrorItem + -> TcType -> TcType + -> TcM TcSolverReportMsg +reportEqErr ctxt item ty1 ty2 + = do + mb_coercible_info <- if errorItemEqRel item == ReprEq + then coercible_msg ty1 ty2 + else return Nothing + tv_info <- case getTyVar_maybe ty2 of + Nothing -> return Nothing + Just tv2 -> Just <$> extraTyVarEqInfo (tv2, Nothing) ty1 + return $ Mismatch { mismatchMsg = mismatch + , mismatchTyVarInfo = tv_info + , mismatchAmbiguityInfo = eqInfos + , mismatchCoercibleInfo = mb_coercible_info } + where + mismatch = misMatchOrCND ctxt item ty1 ty2 + eqInfos = eqInfoMsgs ty1 ty2 + +coercible_msg :: TcType -> TcType -> TcM (Maybe CoercibleMsg) +coercible_msg ty1 ty2 + = do + rdr_env <- getGlobalRdrEnv + fam_envs <- tcGetFamInstEnvs + return $ mkCoercibleExplanation rdr_env fam_envs ty1 ty2 + +mkTyVarEqErr :: SolverReportErrCtxt -> ErrorItem + -> TcTyVar -> TcType -> TcM TcSolverReportMsg +-- tv1 and ty2 are already tidied +mkTyVarEqErr ctxt item tv1 ty2 + = do { traceTc "mkTyVarEqErr" (ppr item $$ ppr tv1 $$ ppr ty2) + ; mkTyVarEqErr' ctxt item tv1 ty2 } + +mkTyVarEqErr' :: SolverReportErrCtxt -> ErrorItem + -> 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 + + -- Impredicativity is a simple error to understand; + -- try it before anything more complicated. + | check_eq_result `cterHasProblem` cteImpredicative + = do + tyvar_eq_info <- extraTyVarEqInfo (tv1, Nothing) ty2 + let + poly_msg = CannotUnifyWithPolytype item tv1 ty2 mb_tv_info + mb_tv_info + | isSkolemTyVar tv1 + = Just tyvar_eq_info + | otherwise + = Nothing + main_msg = + CannotUnifyVariable + { mismatchMsg = headline_msg + , cannotUnifyReason = poly_msg } + -- 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 + + | isSkolemTyVar tv1 -- ty2 won't be a meta-tyvar; we would have + -- swapped in Solver.Equality.canEqTyVarHomo + || isTyVarTyVar tv1 && not (isTyVarTy ty2) + || errorItemEqRel item == ReprEq + -- The cases below don't really apply to ReprEq (except occurs check) + = do + tv_extra <- extraTyVarEqInfo (tv1, Nothing) ty2 + reason <- if errorItemEqRel item == ReprEq + then RepresentationalEq tv_extra <$> coercible_msg ty1 ty2 + else return $ DifferentTyVars tv_extra + let main_msg = CannotUnifyVariable + { mismatchMsg = headline_msg + , cannotUnifyReason = reason } + return main_msg + + | tv1 `elemVarSet` tyCoVarsOfType ty2 + -- We report an "occurs check" even for a ~ F t a, where F is a type + -- function; it's not insoluble (because in principle F could reduce) + -- but we have certainly been unable to solve it + -- + -- Use tyCoVarsOfType because it might have begun as the canonical + -- constraint (Dual (Dual a)) ~ a, and been swizzled by mkEqnErr_help + = let ambiguity_infos = eqInfoMsgs ty1 ty2 + + interesting_tyvars = filter (not . noFreeVarsOfType . tyVarKind) $ + filter isTyVar $ + fvVarList $ + tyCoFVsOfType ty1 `unionFV` tyCoFVsOfType ty2 + + occurs_err = + OccursCheck + { occursCheckInterestingTyVars = interesting_tyvars + , occursCheckAmbiguityInfos = ambiguity_infos } + main_msg = + CannotUnifyVariable + { mismatchMsg = headline_msg + , cannotUnifyReason = occurs_err } + + 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 + -- it started life as a TyVarTv, else it'd have been unified, given + -- that there's no occurs-check or forall problem + | (implic:_) <- cec_encl ctxt + , Implic { ic_skols = skols } <- implic + , tv1 `elem` skols + = do + tv_extra <- extraTyVarEqInfo (tv1, Nothing) ty2 + let msg = Mismatch + { mismatchMsg = mismatch_msg + , mismatchTyVarInfo = Just tv_extra + , mismatchAmbiguityInfo = [] + , mismatchCoercibleInfo = Nothing } + return msg + + -- Check for skolem escape + | (implic:_) <- cec_encl ctxt -- Get the innermost context + , Implic { ic_skols = skols } <- implic + , let esc_skols = filter (`elemVarSet` (tyCoVarsOfType ty2)) skols + , not (null esc_skols) + = let main_msg = + CannotUnifyVariable + { mismatchMsg = mismatch_msg + , cannotUnifyReason = SkolemEscape item implic esc_skols } + + in return main_msg + + -- Nastiest case: attempt to unify an untouchable variable + -- So tv is a meta tyvar (or started that way before we + -- generalised it). So presumably it is an *untouchable* + -- meta tyvar or a TyVarTv, else it'd have been unified + -- See Note [Error messages for untouchables] + | (implic:_) <- cec_encl ctxt -- Get the innermost context + , Implic { ic_tclvl = lvl } <- implic + = 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 + { mismatchMsg = mismatch_msg + , mismatchTyVarInfo = Just tv_extra' + , mismatchAmbiguityInfo = [] + , mismatchCoercibleInfo = Nothing } + return msg + + | otherwise + = 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 + + -- The following doesn't use the cterHasProblem mechanism because + -- we need to retrieve the ConcreteTvOrigin. Just knowing whether + -- there is an error is not sufficient. See #21430. + mb_concrete_reason + | Just frr_orig <- isConcreteTyVar_maybe tv1 + , not (isConcreteType ty2) + = Just $ frr_reason frr_orig tv1 ty2 + | Just (tv2, frr_orig) <- isConcreteTyVarTy_maybe ty2 + , not (isConcreteTyVar tv1) + = Just $ frr_reason frr_orig tv2 ty1 + -- NB: if it's an unsolved equality in which both sides are concrete + -- (e.g. a concrete type variable on both sides), then it's not a + -- representation-polymorphism problem. + | otherwise + = 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_other_origin = Just (errorItemOrigin item) } + + ty1 = mkTyVarTy tv1 + + check_eq_result = case ei_m_reason item of + Just (NonCanonicalReason result) -> result + _ -> cteOK + +eqInfoMsgs :: TcType -> TcType -> [AmbiguityInfo] +-- Report (a) ambiguity if either side is a type function application +-- e.g. F a0 ~ Int +-- (b) warning about injectivity if both sides are the same +-- type function application F a ~ F b +-- See Note [Non-injective type functions] +eqInfoMsgs ty1 ty2 + = catMaybes [tyfun_msg, ambig_msg] + where + mb_fun1 = isTyFun_maybe ty1 + mb_fun2 = isTyFun_maybe ty2 + + ambig_tkvs1@(kvs1, tvs1) = ambigTkvsOfTy ty1 + ambig_tkvs2@(kvs2, tvs2) = ambigTkvsOfTy 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_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) + = Just $ Ambiguity False ambig_tkvs + | otherwise + = Nothing + + tyfun_msg | Just tc1 <- mb_fun1 + , Just tc2 <- mb_fun2 + , tc1 == tc2 + , not (isInjectiveTyCon tc1 Nominal) + = Just $ NonInjectiveTyFam tc1 + | otherwise + = Nothing + +misMatchOrCND :: SolverReportErrCtxt -> ErrorItem + -> TcType -> TcType -> MismatchMsg +-- If oriented then ty1 is actual, ty2 is expected +misMatchOrCND ctxt item ty1 ty2 + | insoluble_item -- See Note [Insoluble mis-match] + || (isRigidTy ty1 && isRigidTy ty2) + || (ei_flavour item == Given) + || null givens + = -- If the equality is unconditionally insoluble + -- or there is no context, don't report the context + mkMismatchMsg item ty1 ty2 + + | otherwise + = CouldNotDeduce givens (item :| []) (Just $ CND_Extra level ty1 ty2) + + where + insoluble_item = case ei_m_reason item of + Nothing -> False + Just r -> isInsolubleReason r + + level = ctLocTypeOrKind_maybe (errorItemCtLoc item) `orElse` TypeLevel + givens = [ given | given <- getUserGivens ctxt, ic_given_eqs given /= NoGivenEqs ] + -- Keep only UserGivens that have some equalities. + -- See Note [Suppress redundant givens during error reporting] + +{- +Note [Suppress redundant givens during error reporting] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When GHC is unable to solve a constraint and prints out an error message, it +will print out what given constraints are in scope to provide some context to +the programmer. But we shouldn't print out /every/ given, since some of them +are not terribly helpful to diagnose type errors. Consider this example: + + foo :: Int :~: Int -> a :~: b -> a :~: c + foo Refl Refl = Refl + +When reporting that GHC can't solve (a ~ c), there are two givens in scope: +(Int ~ Int) and (a ~ b). But (Int ~ Int) is trivially soluble (i.e., +redundant), so it's not terribly useful to report it in an error message. +To accomplish this, we discard any Implications that do not bind any +equalities by filtering the `givens` selected in `misMatchOrCND` (based on +the `ic_given_eqs` field of the Implication). Note that we discard givens +that have no equalities whatsoever, but we want to keep ones with only *local* +equalities, as these may be helpful to the user in understanding what went +wrong. + +But this is not enough to avoid all redundant givens! Consider this example, +from #15361: + + goo :: forall (a :: Type) (b :: Type) (c :: Type). + a :~~: b -> a :~~: c + goo HRefl = HRefl + +Matching on HRefl brings the /single/ given (* ~ *, a ~ b) into scope. +The (* ~ *) part arises due the kinds of (:~~:) being unified. More +importantly, (* ~ *) is redundant, so we'd like not to report it. However, +the Implication (* ~ *, a ~ b) /does/ bind an equality (as reported by its +ic_given_eqs field), so the test above will keep it wholesale. + +To refine this given, we apply mkMinimalBySCs on it to extract just the (a ~ b) +part. This works because mkMinimalBySCs eliminates reflexive equalities in +addition to superclasses (see Note [Remove redundant provided dicts] +in GHC.Tc.TyCl.PatSyn). +-} + +extraTyVarEqInfo :: (TcTyVar, Maybe Implication) -> TcType -> TcM TyVarInfo +-- Add on extra info about skolem constants +-- NB: The types themselves are already tidied +extraTyVarEqInfo (tv1, mb_implic) ty2 + = do + tv1_info <- extraTyVarInfo tv1 + ty2_info <- ty_extra ty2 + return $ + TyVarInfo + { thisTyVar = tv1_info + , thisTyVarIsUntouchable = mb_implic + , otherTy = ty2_info } + where + ty_extra ty = case getCastedTyVar_maybe ty of + Just (tv, _) -> Just <$> extraTyVarInfo tv + Nothing -> return Nothing + +extraTyVarInfo :: TcTyVar -> TcM TyVar +extraTyVarInfo tv = assertPpr (isTyVar tv) (ppr tv) $ + case tcTyVarDetails tv of + SkolemTv skol_info lvl overlaps -> do + new_skol_info <- liftZonkM $ zonkSkolemInfo skol_info + return $ mkTcTyVar (tyVarName tv) (tyVarKind tv) (SkolemTv new_skol_info lvl overlaps) + _ -> return 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_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 + , teq_mb_same_occ = sameOccExtras ty2 ty1 }) + KindEqOrigin cty1 cty2 sub_o mb_sub_t_or_k -> BasicMismatch + { mismatch_ea = NoEA + , mismatch_item = item + , mismatch_ty1 = ty1 + , mismatch_ty2 = ty2 + , mismatch_whenMatching = Just $ WhenMatching cty1 cty2 sub_o mb_sub_t_or_k + , mismatch_mb_same_occ = mb_same_occ + } + _ -> BasicMismatch + { mismatch_ea = NoEA + , mismatch_item = item + , mismatch_ty1 = ty1 + , mismatch_ty2 = ty2 + , mismatch_whenMatching = Nothing + , mismatch_mb_same_occ = mb_same_occ + } + where + orig = errorItemOrigin item + mb_same_occ = sameOccExtras ty2 ty1 + +{- Note [Insoluble mis-match] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider [G] a ~ [a], [W] a ~ [a] (#13674). The Given is insoluble +so we don't use it for rewriting. The Wanted is also insoluble, and +we don't solve it from the Given. It's very confusing to say + Cannot solve a ~ [a] from given constraints a ~ [a] + +And indeed even thinking about the Givens is silly; [W] a ~ [a] is +just as insoluble as Int ~ Bool. + +Exactly the same is true if we have [G] Int ~ Bool, [W] Int ~ Bool. + +Conclusion: if there's an insoluble constraint (isInsolubleReason), +then report it directly, not in the "cannot deduce X from Y" form. +This is done in misMatchOrCND (via the insoluble_occurs_check arg) + +(NB: there are potentially-soluble ones, like (a ~ F a b), and we don't +want to be as draconian with them.) +-} + +sameOccExtras :: TcType -> TcType -> Maybe SameOccInfo +-- See Note [Disambiguating (X ~ X) errors] +sameOccExtras ty1 ty2 + | Just (tc1, _) <- tcSplitTyConApp_maybe ty1 + , Just (tc2, _) <- tcSplitTyConApp_maybe ty2 + , let n1 = tyConName tc1 + n2 = tyConName tc2 + same_occ = nameOccName n1 == nameOccName n2 + same_pkg = moduleUnit (nameModule n1) == moduleUnit (nameModule n2) + , n1 /= n2 -- Different Names + , same_occ -- but same OccName + = Just $ SameOcc same_pkg n1 n2 + | otherwise + = Nothing + +{- Note [Disambiguating (X ~ X) errors] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +See #8278 + +Note [Reporting occurs-check errors] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Given (a ~ [a]), if 'a' is a rigid type variable bound by a user-supplied +type signature, then the best thing is to report that we can't unify +a with [a], because a is a skolem variable. That avoids the confusing +"occur-check" error message. + +But nowadays when inferring the type of a function with no type signature, +even if there are errors inside, we still generalise its signature and +carry on. For example + f x = x:x +Here we will infer something like + f :: forall a. a -> [a] +with a deferred error of (a ~ [a]). So in the deferred unsolved constraint +'a' is now a skolem, but not one bound by the programmer in the context! +Here we really should report an occurs check. + +So isUserSkolem distinguishes the two. + +Note [Non-injective type functions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +It's very confusing to get a message like + Couldn't match expected type `Depend s' + against inferred type `Depend s1' +so mkTyFunInfoMsg adds: + NB: `Depend' is type function, and hence may not be injective + +Warn of loopy local equalities that were dropped. + + +************************************************************************ +* * + Type-class errors +* * +************************************************************************ +-} + +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 + ; let min_items = elim_superclasses items + lookups = map (lookup_cls_inst inst_envs) min_items + (no_inst_items, overlap_items) = partition is_no_inst lookups + + -- Report definite no-instance errors, + -- or (iff there are none) overlap errors + -- 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, (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 + + no_givens = null (getUserGivens ctxt) + + is_no_inst (item, (matches, unifiers, _)) + = no_givens + && null matches + && (nullUnifiers unifiers || all (not . isAmbiguousTyVar) (tyCoVarsOfTypeList (errorItemPred item))) + + lookup_cls_inst inst_envs item + = (item, lookupInstEnv True inst_envs clas tys) + where + (clas, tys) = getClassPredTys (errorItemPred item) + + + -- When simplifying [W] Ord (Set a), we need + -- [W] Eq a, [W] Ord a + -- but we really only want to report the latter + elim_superclasses = mkMinimalBySCs errorItemPred . toList + +-- Note [mk_dict_err] +-- ~~~~~~~~~~~~~~~~~~~ +-- Different dictionary error messages are reported depending on the number of +-- matches and unifiers: +-- +-- - No matches, regardless of unifiers: report "No instance for ...". +-- - Two or more matches, regardless of unifiers: report "Overlapping instances for ...", +-- and show the matching and unifying instances. +-- - One match, one or more unifiers: report "Overlapping instances for", show the +-- 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, ([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 (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) 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 + ] + where + orig = errorItemOrigin item + pred = errorItemPred item + (clas, tys) = getClassPredTys pred + unifiers = getCoherentUnifiers pot_unifiers + + get_candidate_instances :: TcM [ClsInst] + -- See Note [Report candidate instances] + get_candidate_instances + | [ty] <- tys -- Only try for single-parameter classes + = do { instEnvs <- tcGetInstEnvs + ; return (filter (is_candidate_inst ty) + (classInstances instEnvs clas)) } + | otherwise = return [] + + is_candidate_inst ty inst -- See Note [Report candidate instances] + | [other_ty] <- is_tys inst + , Just (tc1, _) <- tcSplitTyConApp_maybe ty + , Just (tc2, _) <- tcSplitTyConApp_maybe other_ty + = let n1 = tyConName tc1 + n2 = tyConName tc2 + different_names = n1 /= n2 + same_occ_names = nameOccName n1 == nameOccName n2 + in different_names && same_occ_names + | otherwise = False + + -- See Note [Out-of-scope fields with -XOverloadedRecordDot] + record_field_suggestions :: ErrorItem -> TcM ([ImportError], [GhcHint]) + record_field_suggestions item = flip (maybe $ return ([], noHints)) record_field $ \name -> + do { glb_env <- getGlobalRdrEnv + ; lcl_env <- getLocalRdrEnv + ; let field_name_hints = report_no_fieldnames item + ; (errs, hints) <- if occ_name_in_scope glb_env lcl_env name + then return ([], noHints) + else unknownNameSuggestions emptyLocalRdrEnv WL_RecField (mkRdrUnqual name) + ; pure (errs, hints ++ field_name_hints) + } + + -- get type names from instance + -- resolve the type - if it's in scope is it a record? + -- if it's a record, report an error - the record name + the field that could not be found + report_no_fieldnames :: ErrorItem -> [GhcHint] + 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 GetFieldOrigin in record_field + , Just (_, [_symbol, x, r, a]) <- tcSplitTyConApp_maybe (varType evvar) + , Just (r_tycon, _) <- tcSplitTyConApp_maybe r + , Just x_name <- isStrLitTy x + -- we check that this is a record type by checking whether it has any + -- fields (in scope) + , not . null $ tyConFieldLabels r_tycon + = [RemindRecordMissingField x_name r a] + | otherwise = [] + + occ_name_in_scope glb_env lcl_env occ_name = not $ + null (lookupGRE glb_env (LookupOccName occ_name (RelevantGREsFOS WantNormal))) && + isNothing (lookupLocalRdrOcc lcl_env occ_name) + + record_field = case orig of + GetFieldOrigin name -> Just (mkVarOccFS name) + _ -> Nothing + +{- Note [Report candidate instances] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If we have an unsolved (Num Int), where `Int` is not the Prelude Int, +but comes from some other module, then it may be helpful to point out +that there are some similarly named instances elsewhere. So we get +something like + No instance for (Num Int) arising from the literal ‘3’ + There are instances for similar types: + instance Num GHC.Types.Int -- Defined in ‘GHC.Num’ +Discussion in #9611. + +Note [Highlighting ambiguous type variables] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When we encounter ambiguous type variables (i.e. type variables +that remain metavariables after type inference), we need a few more +conditions before we can reason that *ambiguity* prevents constraints +from being solved: + - We can't have any givens, as encountering a typeclass error + with given constraints just means we couldn't deduce + a solution satisfying those constraints and as such couldn't + bind the type variable to a known type. + - If we don't have any unifiers, we don't even have potential + instances from which an ambiguity could arise. + - Lastly, I don't want to mess with error reporting for + unknown runtime types so we just fall back to the old message there. +Once these conditions are satisfied, we can safely say that ambiguity prevents +the constraint from being solved. + +Note [Out-of-scope fields with -XOverloadedRecordDot] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +With -XOverloadedRecordDot, when a field isn't in scope, the error that appears +is produces here, and it says + No instance for (GHC.Record.HasField "" ...). + +Additionally, though, we want to suggest similar field names that are in scope +or could be in scope with different import lists. + +However, we can still get an error about a missing HasField instance when a +field is in scope (if the types are wrong), and so it's important that we don't +suggest similar names here if the record field is in scope, either qualified or +unqualified, since qualification doesn't matter for -XOverloadedRecordDot. + +Example: + + import Data.Monoid (Alt(..)) + + foo = undefined.getAll + +results in + + No instance for (GHC.Records.HasField "getAll" r0 a0) + arising from selecting the field ‘getAll’ + Perhaps you meant ‘getAlt’ (imported from Data.Monoid) + Perhaps you want to add ‘getAll’ to the import list + in the import of ‘Data.Monoid’ +-} + +----------------------- +-- relevantBindings looks at the value environment and finds values whose +-- types mention any of the offending type variables. It has to be +-- careful to zonk the Id's type first, so it has to be in the monad. +-- We must be careful to pass it a zonked type variable, too. +-- +-- We always remove closed top-level bindings, though, +-- since they are never relevant (cf #8233) + +relevantBindings :: Bool -- True <=> filter by tyvar; False <=> no filtering + -- See #8191 + -> SolverReportErrCtxt -> ErrorItem + -> TcM (SolverReportErrCtxt, RelevantBindings, ErrorItem) +-- Also returns the zonked and tidied CtOrigin of the constraint +relevantBindings want_filtering ctxt item + = do { traceTc "relevantBindings" (ppr item) + ; (env1, tidy_orig) <- liftZonkM $ zonkTidyOrigin (cec_tidy ctxt) (ctLocOrigin loc) + + -- For *kind* errors, report the relevant bindings of the + -- enclosing *type* equality, because that's more useful for the programmer + ; let extra_tvs = case tidy_orig of + KindEqOrigin t1 t2 _ _ -> tyCoVarsOfTypes [t1,t2] + _ -> emptyVarSet + ct_fvs = tyCoVarsOfType (errorItemPred item) `unionVarSet` extra_tvs + + -- Put a zonked, tidied CtOrigin into the ErrorItem + loc' = setCtLocOrigin loc tidy_orig + item' = item { ei_loc = loc' } + + ; (env2, lcl_name_cache) <- liftZonkM $ zonkTidyTcLclEnvs env1 [lcl_env] + + ; relev_bds <- relevant_bindings want_filtering lcl_env lcl_name_cache ct_fvs + ; let ctxt' = ctxt { cec_tidy = env2 } + ; return (ctxt', relev_bds, item') } + where + loc = errorItemCtLoc item + lcl_env = ctLocEnv loc + +-- slightly more general version, to work also with holes +relevant_bindings :: Bool + -> CtLocEnv + -> NameEnv Type -- Cache of already zonked and tidied types + -> TyCoVarSet + -> TcM RelevantBindings +relevant_bindings want_filtering lcl_env lcl_name_env ct_tvs + = do { dflags <- getDynFlags + ; traceTc "relevant_bindings" $ + vcat [ ppr ct_tvs + , pprWithCommas id [ ppr id <+> dcolon <+> ppr (idType id) + | TcIdBndr id _ <- ctl_bndrs lcl_env ] + , pprWithCommas id + [ ppr id | TcIdBndr_ExpType id _ _ <- ctl_bndrs lcl_env ] ] + + ; go dflags (maxRelevantBinds dflags) + emptyVarSet (RelevantBindings [] False) + (removeBindingShadowing $ ctl_bndrs lcl_env) + -- tcl_bndrs has the innermost bindings first, + -- which are probably the most relevant ones + } + where + run_out :: Maybe Int -> Bool + run_out Nothing = False + run_out (Just n) = n <= 0 + + dec_max :: Maybe Int -> Maybe Int + dec_max = fmap (\n -> n - 1) + + + go :: DynFlags -> Maybe Int -> TcTyVarSet + -> RelevantBindings + -> [TcBinder] + -> TcM RelevantBindings + go _ _ _ (RelevantBindings bds discards) [] + = return $ RelevantBindings (reverse bds) discards + go dflags n_left tvs_seen rels@(RelevantBindings bds discards) (tc_bndr : tc_bndrs) + = case tc_bndr of + TcTvBndr {} -> discard_it + TcIdBndr id top_lvl -> go2 (idName id) top_lvl + TcIdBndr_ExpType name et top_lvl -> + do { mb_ty <- liftIO $ readExpType_maybe et + -- et really should be filled in by now. But there's a chance + -- it hasn't, if, say, we're reporting a kind error en route to + -- checking a term. See test indexed-types/should_fail/T8129 + -- Or we are reporting errors from the ambiguity check on + -- a local type signature + ; case mb_ty of + Just _ty -> go2 name top_lvl + Nothing -> discard_it -- No info; discard + } + where + discard_it = go dflags n_left tvs_seen rels tc_bndrs + go2 id_name top_lvl + = do { let tidy_ty = case lookupNameEnv lcl_name_env id_name of + Just tty -> tty + Nothing -> pprPanic "relevant_bindings" (ppr id_name) + ; traceTc "relevantBindings 1" (ppr id_name <+> dcolon <+> ppr tidy_ty) + ; let id_tvs = tyCoVarsOfType tidy_ty + bd = (id_name, tidy_ty) + new_seen = tvs_seen `unionVarSet` id_tvs + + ; if (want_filtering && not (hasPprDebug dflags) + && id_tvs `disjointVarSet` ct_tvs) + -- We want to filter out this binding anyway + -- so discard it silently + then discard_it + + else if isTopLevel top_lvl && not (isNothing n_left) + -- It's a top-level binding and we have not specified + -- -fno-max-relevant-bindings, so discard it silently + then discard_it + + else if run_out n_left && id_tvs `subVarSet` tvs_seen + -- We've run out of n_left fuel and this binding only + -- mentions already-seen type variables, so discard it + then go dflags n_left tvs_seen (RelevantBindings bds True) -- Record that we have now discarded something + tc_bndrs + + -- Keep this binding, decrement fuel + else go dflags (dec_max n_left) new_seen + (RelevantBindings (bd:bds) discards) tc_bndrs } + +----------------------- +warnDefaulting :: [Ct] -> TcTyVar -> Type -> TcM () +warnDefaulting [] _ _ + = panic "warnDefaulting: empty Wanteds" +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 + -- add unhelpful clutter + ; let filtered = filter (not . isWantedSuperclassOrigin . ctOrigin) wanteds + tidy_env = tidyFreeTyCoVars env0 $ + tyCoVarsOfCtsList (listToBag filtered) + tidy_wanteds = map (tidyCt tidy_env) filtered + tidy_tv = lookupVarEnv (snd tidy_env) the_tv + diag = TcRnWarnDefaulting tidy_wanteds tidy_tv default_ty + loc = ctLoc ct + ; setCtLocM loc $ diagnosticTc warn_default diag } + +{- +Note [Runtime skolems] +~~~~~~~~~~~~~~~~~~~~~~ +We want to give a reasonably helpful error message for ambiguity +arising from *runtime* skolems in the debugger. These +are created by in GHC.Runtime.Heap.Inspect.zonkRTTIType. +-} + +{-********************************************************************** +* * + GHC API helper functions +* * +**********************************************************************-} + +-- | If the 'TcSolverReportMsg' is a type mismatch between +-- an actual and an expected type, return the actual and expected types +-- (in that order). +-- +-- 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 -> Maybe (Type, Type) +solverReportMsg_ExpectedActuals + = \case + Mismatch { mismatchMsg = mismatch_msg } -> + mismatchMsg_ExpectedActuals mismatch_msg + _ -> Nothing + +-- | Filter the list by the given predicate, but if that would be empty, +-- just give back the original list. +-- We use this as we must report something for fdefer-type-errors. +tryFilter :: (a -> Bool) -> NonEmpty a -> NonEmpty a +tryFilter f as = fromMaybe as $ nonEmpty (filter f (toList as)) 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 @@ -1,5 +1,6 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE MultiWayIf #-} {-# LANGUAGE ExistentialQuantification #-} module GHC.Tc.Errors.Hole @@ -10,7 +11,6 @@ , isFlexiTyVar , tcFilterHoleFits , getLocalBindings - , pprHoleFit , addHoleFitDocs , getHoleFitSortingAlg , getHoleFitDispConfig @@ -23,7 +23,7 @@ , sortHoleFitsBySize - -- Re-exported from GHC.Tc.Errors.Hole.FitTypes + -- Re-exported from GHC.Tc.Errors.Hole.Plugin , HoleFitPlugin (..), HoleFitPluginR (..) ) where @@ -38,13 +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.Core.Type +import GHC.Tc.Zonk.TcType +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 ( pprNameProvenance , GlobalRdrElt (..) - , globalRdrEnvElts, greMangledName, grePrintableName ) -import GHC.Builtin.Names ( gHC_ERR ) +import GHC.Types.Name.Reader +import GHC.Builtin.Names ( gHC_INTERNAL_ERR, gHC_INTERNAL_UNSAFE_COERCE ) +import GHC.Builtin.Types ( tupleDataConName, unboxedSumDataConName ) import GHC.Types.Id import GHC.Types.Var.Set import GHC.Types.Var.Env @@ -52,10 +57,9 @@ 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.Session +import GHC.Driver.DynFlags import GHC.Data.Maybe import GHC.Utils.FV ( fvVarList, fvVarSet, unionFV, mkFVs, FV ) @@ -72,18 +76,23 @@ 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) import GHC.Tc.Errors.Hole.FitTypes +import GHC.Tc.Errors.Hole.Plugin import qualified Data.Set as Set import GHC.Types.SrcLoc 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 ...] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -397,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 @@ -465,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 -> @@ -492,67 +501,10 @@ ; 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 (grePrintableName 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, _) <- zonkTidyOrigin tidy_orig (ctLocOrigin ct_loc) - ; go env1 [] (removeBindingShadowing $ tcl_bndrs lcl_env) } + = do { (env1, _) <- liftZonkM $ zonkTidyOrigin tidy_orig (ctLocOrigin ct_loc) + ; go env1 [] (removeBindingShadowing $ ctl_bndrs lcl_env) } where lcl_env = ctLocEnv ct_loc @@ -584,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 @@ -605,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 @@ -615,9 +568,11 @@ ; traceTc "numPlugins are:" $ ppr (length candidatePlugins) ; (searchDiscards, subs) <- tcFilterHoleFits findVLimit hole (hole_ty, []) cands - ; (tidy_env, tidy_subs) <- zonkSubs tidy_env subs + ; (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 @@ -636,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) <- 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) <- zonkTidyTcType tidy_env hole_ty + ; (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 @@ -663,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 @@ -679,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) @@ -725,17 +702,16 @@ -- We zonk the hole fits so that the output aligns with the rest -- of the typed hole error message output. -zonkSubs :: TidyEnv -> [HoleFit] -> TcM (TidyEnv, [HoleFit]) +zonkSubs :: 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 -> TcM (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 + ; (env, m') <- zonkTidyTcTypes env m ; (env, wrp') <- zonkTidyTcTypes env wrp ; let zFit = hf {hfType = ty', hfMatches = m', hfWrap = wrp'} ; return (env, zFit ) } @@ -744,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 @@ -755,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) @@ -782,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 @@ -797,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) = @@ -818,8 +794,8 @@ _ -> discard_it } _ -> discard_it } where - -- We want to filter out undefined and the likes from GHC.Err - not_trivial id = nameModule_maybe (idName id) /= Just gHC_ERR + -- We want to filter out undefined and the likes from GHC.Err (#17940) + 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)) @@ -831,10 +807,7 @@ Just (dataConWrapId con, dataConNonlinearType con) _ -> Nothing } where name = case hfc of -#if __GLASGOW_HASKELL__ < 901 - IdHFCand id -> idName id -#endif - GreHFCand gre -> greMangledName gre + GreHFCand gre -> greName gre NameHFCand name -> name discard_it = go subs seen maxleft ty elts keep_it eid eid_ty wrp ms = go (fit:subs) (extendVarSet seen eid) @@ -903,7 +876,7 @@ -- holes must be for this to be a match. ; if fits then do { -- Zonking is expensive, so we only do it if required. - z_wrp_tys <- zonkTcTypes (unfoldWrapper wrp) + z_wrp_tys <- liftZonkM $ zonkTcTypes (unfoldWrapper wrp) ; if null ref_vars then return (Just (z_wrp_tys, [])) else do { let -- To be concrete matches, matches have to @@ -914,7 +887,7 @@ Just tv -> tv `elemVarSet` fvSet _ -> True allConcrete = all notAbstract z_wrp_tys - ; z_vars <- zonkTcTyVars ref_vars + ; z_vars <- liftZonkM $ zonkTcTyVars ref_vars ; let z_mtvs = mapMaybe getTyVar_maybe z_vars ; allFilled <- not <$> anyM isFlexiTyVar z_mtvs ; allowAbstract <- goptM Opt_AbstractRefHoleFits @@ -954,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. @@ -982,28 +955,33 @@ tcSubTypeSigma orig (ExprSigCtxt NoRRC) ty hole_ty ; traceTc "Checking hole fit {" empty ; traceTc "wanteds are: " $ ppr wanted - ; if isEmptyWC wanted && isEmptyBag th_relevant_cts - then do { traceTc "}" empty - ; return (True, wrap) } - else do { fresh_binds <- newTcEvBinds - -- The relevant constraints may contain HoleDests, so we must - -- take care to clone them as well (to avoid #15370). - ; cloned_relevants <- mapBagM cloneWantedCtEv th_relevant_cts - -- We wrap the WC in the nested implications, for details, see - -- Note [Checking hole fits] - ; let wrapInImpls cts = foldl (flip (setWCAndBinds fresh_binds)) cts th_implics - final_wc = wrapInImpls $ addSimples wanted $ - mapBag mkNonCanonical cloned_relevants - -- We add the cloned relevants to the wanteds generated - -- by the call to tcSubType_NC, for details, see - -- Note [Relevant constraints]. There's no need to clone - -- the wanteds, because they are freshly generated by the - -- call to`tcSubtype_NC`. - ; traceTc "final_wc is: " $ ppr final_wc - -- See Note [Speeding up valid hole-fits] - ; (rem, _) <- tryTc $ runTcSEarlyAbort $ simplifyTopWanteds final_wc - ; traceTc "}" empty - ; return (any isSolvedWC rem, wrap) } } + ; if | isEmptyWC wanted, isEmptyBag th_relevant_cts + -> do { traceTc "}" empty + ; return (True, wrap) } + + | checkInsoluble wanted -- See Note [Fast path for tcCheckHoleFit] + -> return (False, wrap) + + | otherwise + -> do { fresh_binds <- newTcEvBinds + -- The relevant constraints may contain HoleDests, so we must + -- take care to clone them as well (to avoid #15370). + ; cloned_relevants <- mapBagM cloneWantedCtEv th_relevant_cts + -- We wrap the WC in the nested implications, for details, see + -- Note [Checking hole fits] + ; let wrapInImpls cts = foldl (flip (setWCAndBinds fresh_binds)) cts th_implics + final_wc = wrapInImpls $ addSimples wanted $ + mapBag mkNonCanonical cloned_relevants + -- We add the cloned relevants to the wanteds generated + -- by the call to tcSubType_NC, for details, see + -- Note [Relevant constraints]. There's no need to clone + -- the wanteds, because they are freshly generated by the + -- call to`tcSubtype_NC`. + ; traceTc "final_wc is: " $ ppr final_wc + -- See Note [Speeding up valid hole-fits] + ; (rem, _) <- tryTc $ runTcSEarlyAbort $ simplifyTopWanteds final_wc + ; traceTc "}" empty + ; return (any isSolvedWC rem, wrap) } } where orig = ExprHoleOrigin (hole_occ <$> th_hole) @@ -1013,3 +991,52 @@ -> WantedConstraints -- The new constraints. setWCAndBinds binds imp wc = mkImplicWC $ unitBag $ imp { ic_wanted = wc , ic_binds = binds } + +{- Note [Fast path for tcCheckHoleFit] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In `tcCheckHoleFit` we compare (with `tcSubTypeSigma`) the type of the hole +with the type of zillions of in-scope functions, to see which would "fit". +Most of these checks fail! They generate obviously-insoluble constraints. +For these very-common cases we don't want to crank up the full constraint +solver. It's much more efficient to do a quick-and-dirty check for insolubility. + +Now, `tcSubTypeSigma` uses the on-the-fly unifier in GHC.Tc.Utils.Unify, +it has already done the dirt-simple unification. So our quick-and-dirty +check can simply look for constraints like (Int ~ Bool). We don't need +to worry about (Maybe Int ~ Maybe Bool). + +The quick-and-dirty check is in `checkInsoluble`. It can make a big +difference: For test hard_hole_fits, compile-time allocation goes down by 37%! +-} + + +checkInsoluble :: WantedConstraints -> Bool +-- See Note [Fast path for tcCheckHoleFit] +checkInsoluble (WC { wc_simple = simples }) + = any is_insol simples + where + is_insol ct = case classifyPredType (ctPred ct) of + EqPred r t1 t2 -> definitelyNotEqual (eqRelRole r) t1 t2 + _ -> False + +definitelyNotEqual :: Role -> TcType -> TcType -> Bool +-- See Note [Fast path for tcCheckHoleFit] +-- Specifically, does not need to recurse under type constructors +definitelyNotEqual r t1 t2 + = go t1 t2 + where + go t1 t2 + | Just t1' <- coreView t1 = go t1' t2 + | Just t2' <- coreView t2 = go t1 t2' + + go (TyConApp tc _) t2 | isGenerativeTyCon tc r = go_tc tc t2 + go t1 (TyConApp tc _) | isGenerativeTyCon tc r = go_tc tc t1 + go (FunTy {ft_af = af1}) (FunTy {ft_af = af2}) = af1 /= af2 + go _ _ = False + + go_tc :: TyCon -> TcType -> Bool + -- The TyCon is generative, and is not a saturated FunTy + go_tc tc1 (TyConApp tc2 _) | isGenerativeTyCon tc2 r = tc1 /= tc2 + go_tc _ (FunTy {}) = True + go_tc _ (ForAllTy {}) = True + go_tc _ _ = False 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,39 +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.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] -> TcM (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,13 +1,11 @@ {-# LANGUAGE ExistentialQuantification #-} module GHC.Tc.Errors.Hole.FitTypes ( - TypedHole (..), HoleFit (..), HoleFitCandidate (..), - CandPlugin, FitPlugin, HoleFitPlugin (..), HoleFitPluginR (..), + TypedHole (..), HoleFit (..), TcHoleFit(..), HoleFitCandidate (..), hfIsLcl, pprHoleFitCand ) where import GHC.Prelude -import GHC.Tc.Types import GHC.Tc.Types.Constraint import GHC.Tc.Utils.TcType @@ -48,7 +46,7 @@ instance Eq HoleFitCandidate where IdHFCand i1 == IdHFCand i2 = i1 == i2 NameHFCand n1 == NameHFCand n2 = n1 == n2 - GreHFCand gre1 == GreHFCand gre2 = gre_name gre1 == gre_name gre2 + GreHFCand gre1 == GreHFCand gre2 = greName gre1 == greName gre2 _ == _ = False instance Outputable HoleFitCandidate where @@ -63,11 +61,11 @@ getName hfc = case hfc of IdHFCand cid -> idName cid NameHFCand cname -> cname - GreHFCand cgre -> greMangledName cgre + GreHFCand cgre -> greName cgre getOccName hfc = case hfc of IdHFCand cid -> occName cid NameHFCand cname -> occName cname - GreHFCand cgre -> occName (greMangledName cgre) + GreHFCand cgre -> occName $ greName cgre instance HasOccName HoleFitCandidate where occName = getOccName @@ -79,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. @@ -90,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 @@ -109,42 +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 - --- | A plugin for modifying the candidate hole fits *before* they're checked. -type CandPlugin = TypedHole -> [HoleFitCandidate] -> TcM [HoleFitCandidate] - --- | A plugin for modifying hole fits *after* they've been found. -type FitPlugin = TypedHole -> [HoleFit] -> TcM [HoleFit] - --- | A HoleFitPlugin is a pair of candidate and fit plugins. -data HoleFitPlugin = HoleFitPlugin - { candPlugin :: CandPlugin - , fitPlugin :: FitPlugin } - --- | HoleFitPluginR adds a TcRef to hole fit plugins so that plugins can --- track internal state. Note the existential quantification, ensuring that --- the state cannot be modified from outside the plugin. -data HoleFitPluginR = forall s. HoleFitPluginR - { hfPluginInit :: TcM (TcRef s) - -- ^ Initializes the TcRef to be passed to the plugin - , hfPluginRun :: TcRef s -> HoleFitPlugin - -- ^ The function defining the plugin itself - , hfPluginStop :: TcRef s -> TcM () - -- ^ Cleanup of state, guaranteed to be called even on error - } diff --git a/GHC/Tc/Errors/Hole/FitTypes.hs-boot b/GHC/Tc/Errors/Hole/FitTypes.hs-boot deleted file mode 100644 --- a/GHC/Tc/Errors/Hole/FitTypes.hs-boot +++ /dev/null @@ -1,30 +0,0 @@ --- This boot file is in place to break the loop where: --- + GHC.Tc.Types needs 'HoleFitPlugin', --- + which needs 'GHC.Tc.Errors.Hole.FitTypes' --- + which needs 'GHC.Tc.Types' -module GHC.Tc.Errors.Hole.FitTypes where - -import GHC.Base (Int, Maybe) -import GHC.Types.Var (Id) -import GHC.Types.Name (Name) -import GHC.Types.Name.Reader (GlobalRdrElt) -import GHC.Tc.Utils.TcType (TcType) -import GHC.Hs.Doc (HsDocString) -import GHC.Utils.Outputable (SDoc) - -data HoleFitCandidate - = IdHFCand Id - | NameHFCand Name - | GreHFCand GlobalRdrElt - -data HoleFitPlugin -data HoleFit = - HoleFit { hfId :: Id - , hfCand :: HoleFitCandidate - , hfType :: TcType - , hfRefLvl :: Int - , hfWrap :: [TcType] - , hfMatches :: [TcType] - , hfDoc :: Maybe [HsDocString] - } - | RawHoleFit SDoc diff --git a/GHC/Tc/Errors/Hole/Plugin.hs b/GHC/Tc/Errors/Hole/Plugin.hs new file mode 100644 --- /dev/null +++ b/GHC/Tc/Errors/Hole/Plugin.hs @@ -0,0 +1,29 @@ +{-# LANGUAGE ExistentialQuantification #-} +module GHC.Tc.Errors.Hole.Plugin(CandPlugin, FitPlugin, HoleFitPlugin (..), HoleFitPluginR (..)) where + +import GHC.Tc.Errors.Hole.FitTypes +import GHC.Tc.Types ( TcRef, TcM ) + + +-- | A plugin for modifying the candidate hole fits *before* they're checked. +type CandPlugin = TypedHole -> [HoleFitCandidate] -> TcM [HoleFitCandidate] + +-- | A plugin for modifying hole fits *after* they've been found. +type FitPlugin = TypedHole -> [HoleFit] -> TcM [HoleFit] + +-- | A HoleFitPlugin is a pair of candidate and fit plugins. +data HoleFitPlugin = HoleFitPlugin + { candPlugin :: CandPlugin + , fitPlugin :: FitPlugin } + +-- | HoleFitPluginR adds a TcRef to hole fit plugins so that plugins can +-- track internal state. Note the existential quantification, ensuring that +-- the state cannot be modified from outside the plugin. +data HoleFitPluginR = forall s. HoleFitPluginR + { hfPluginInit :: TcM (TcRef s) + -- ^ Initializes the TcRef to be passed to the plugin + , hfPluginRun :: TcRef s -> HoleFitPlugin + -- ^ The function defining the plugin itself + , hfPluginStop :: TcRef s -> TcM () + -- ^ Cleanup of state, guaranteed to be called even on error + } diff --git a/GHC/Tc/Errors/Hole/Plugin.hs-boot b/GHC/Tc/Errors/Hole/Plugin.hs-boot new file mode 100644 --- /dev/null +++ b/GHC/Tc/Errors/Hole/Plugin.hs-boot @@ -0,0 +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,4123 +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(..) - ) - where - -import GHC.Prelude - -import GHC.Builtin.Names -import GHC.Builtin.Types ( boxedRepDataConTyCon, tYPETyCon ) - -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 (coAxiomTyCon, coAxiomSingleBranch) -import GHC.Core.ConLike -import GHC.Core.FamInstEnv ( famInstAxiom ) -import GHC.Core.InstEnv -import GHC.Core.TyCo.Rep (Type(..)) -import GHC.Core.TyCo.Ppr (pprWithExplicitKindsWhen, - pprSourceTyCon, pprTyVars, pprWithTYPE) -import GHC.Core.PatSyn ( patSynName, pprPatSynType ) -import GHC.Core.Predicate -import GHC.Core.Type - -import GHC.Driver.Flags -import GHC.Driver.Backend -import GHC.Hs - -import GHC.Tc.Errors.Types -import GHC.Tc.Types.Constraint -import {-# SOURCE #-} GHC.Tc.Types( getLclEnvLoc, lclEnvInGeneratedCode ) -import GHC.Tc.Types.Origin -import GHC.Tc.Types.Rank (Rank(..)) -import GHC.Tc.Utils.TcType - -import GHC.Types.Error -import GHC.Types.FieldLabel (flIsOverloaded) -import GHC.Types.Hint (UntickedPromotedThing(..), pprUntickedConstructor, isBareSymbol) -import GHC.Types.Hint.Ppr () -- Outputable GhcHint -import GHC.Types.Basic -import GHC.Types.Error.Codes ( constructorCode ) -import GHC.Types.Id -import GHC.Types.Name -import GHC.Types.Name.Reader ( GreName(..), pprNameProvenance - , RdrName, rdrNameOcc, greMangledName ) -import GHC.Types.Name.Set -import GHC.Types.SrcLoc -import GHC.Types.TyThing -import GHC.Types.Unique.Set ( nonDetEltsUniqSet ) -import GHC.Types.Var -import GHC.Types.Var.Set -import GHC.Types.Var.Env - -import GHC.Unit.State (pprWithUnitState, UnitState) -import GHC.Unit.Module -import GHC.Unit.Module.Warnings ( pprWarningTxtForMsg ) - -import GHC.Data.Bag -import GHC.Data.FastString -import GHC.Data.List.SetOps ( nubOrdBy ) -import GHC.Data.Maybe -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.Function (on) -import Data.List ( groupBy, sortBy, tails - , partition, unfoldr ) -import Data.Ord ( comparing ) -import Data.Bifunctor -import GHC.Types.Name.Env -import qualified Language.Haskell.TH as TH - -data TcRnMessageOpts = TcRnMessageOpts { tcOptsShowContext :: !Bool -- ^ Whether we show the error context or not - } - -defaultTcRnMessageOpts :: TcRnMessageOpts -defaultTcRnMessageOpts = TcRnMessageOpts { tcOptsShowContext = True } - - -instance Diagnostic TcRnMessage where - type DiagnosticOpts TcRnMessage = TcRnMessageOpts - defaultDiagnosticOpts = defaultTcRnMessageOpts - diagnosticMessage opts = \case - TcRnUnknownMessage (UnknownDiagnostic @e m) - -> diagnosticMessage (defaultDiagnosticOpts @e) 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 - -> if tcOptsShowContext opts - then main_msg `unionDecoratedSDoc` ctxt_msg - else main_msg - where - main_msg = diagnosticMessage opts msg - ctxt_msg = mkSimpleDecorated (inHsDocContext ctxt) - TcRnSolverReport msg _ _ - -> mkSimpleDecorated $ pprSolverReportWithCtxt msg - 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 - 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 name - -> mkDecorated [dodgy_msg (text "import") name (dodgy_msg_insert name :: IE GhcPs)] - TcRnDodgyExports name - -> mkDecorated [dodgy_msg (text "export") name (dodgy_msg_insert name :: IE GhcRn)] - 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)] - 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 (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 "The constructor has no labelled fields") ] - 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" - TcRnIllegalHsBootFileDecl - -> mkSimpleDecorated $ - text "Illegal declarations in an hs-boot file" - 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" - TcRnAbstractClassInst clas - -> mkSimpleDecorated $ - text "Cannot define instance for abstract class" <+> - quotes (ppr (className clas)) - TcRnNoClassInstHead tau - -> mkSimpleDecorated $ - hang (text "Instance head is not headed by a class:") 2 (pprType tau) - 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)) ] - 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) - TcRnIllegalClassInst tcf - -> mkSimpleDecorated $ - vcat [ text "Illegal instance for a" <+> ppr tcf - , text "A class instance must be for a class" ] - TcRnOversaturatedVisibleKindArg ty - -> mkSimpleDecorated $ - text "Illegal oversaturated visible kind argument:" <+> - quotes (char '@' <> pprParendType ty) - TcRnBadAssociatedType clas tc - -> mkSimpleDecorated $ - hsep [ text "Class", quotes (ppr clas) - , text "does not have an associated type", quotes (ppr tc) ] - 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 inst - -> mkSimpleDecorated $ - hsep [ text "Orphan instance:" - , pprInstanceHdr 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 child ie1 ie2 - -> mkSimpleDecorated $ - hsep [ quotes (ppr child) - , 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 child - parents = map ppr parent_names - TcRnConflictingExports occ child1 gre1 ie1 child2 gre2 ie2 - -> mkSimpleDecorated $ - vcat [ text "Conflicting exports for" <+> quotes (ppr occ) <> colon - , ppr_export child1 gre1 ie1 - , ppr_export child2 gre2 ie2 - ] - where - ppr_export child gre ie = nest 3 (hang (quotes (ppr ie) <+> text "exports" <+> - quotes (ppr_name child)) - 2 (pprNameProvenance gre)) - - -- DuplicateRecordFields means that nameOccName might be a - -- mangled $sel-prefixed thing, in which case show the correct OccName - -- alone (but otherwise show the Name so it will have a module - -- qualifier) - ppr_name (FieldGreName fl) | flIsOverloaded fl = ppr fl - | otherwise = ppr (flSelector fl) - ppr_name (NormalGreName name) = ppr name - TcRnAmbiguousField rupd parent_type - -> mkSimpleDecorated $ - vcat [ text "The record update" <+> ppr rupd - <+> text "with type" <+> ppr parent_type - <+> text "is ambiguous." - , text "This will not be supported by -XDuplicateRecordFields in future releases of GHC." - ] - 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 ]) - TcRnNoConstructorHasAllFields conflictingFields - -> mkSimpleDecorated $ - hang (text "No constructor has all these fields:") - 2 (pprQuotedList conflictingFields) - TcRnMixedSelectors data_name data_sels pat_name pat_syn_sels - -> mkSimpleDecorated $ - text "Cannot use a mixture of pattern synonym and record selectors" $$ - text "Record selectors defined by" - <+> quotes (ppr data_name) - <> colon - <+> pprWithCommas ppr data_sels $$ - text "Pattern synonym selectors defined by" - <+> quotes (ppr pat_name) - <> colon - <+> pprWithCommas ppr pat_syn_sels - 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 - TcRnNoPossibleParentForFields rbinds - -> mkSimpleDecorated $ - hang (text "No type has all these fields:") - 2 (pprQuotedList fields) - where fields = map (hfbLHS . unLoc) rbinds - TcRnBadOverloadedRecordUpdate _rbinds - -> mkSimpleDecorated $ - text "Record update is ambiguous, and requires a type signature" - 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 - 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" - - TcRnSpecialClassInst cls because_safeHaskell - -> mkSimpleDecorated $ - 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 - 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) - 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 Nothing -> - hang innerMsg 2 $ text "because its data constructor is not in scope" - NewtypeDataConNotInScope (Just 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" - TcRnNotARecordSelector field - -> mkSimpleDecorated $ - hsep [quotes (ppr field), text "is not a record selector"] - 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" - TcRnSplicePolymorphicLocalVar ident - -> mkSimpleDecorated $ - text "Can't splice the polymorphic local variable" <+> quotes (ppr ident) - 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 ty - -> mkSimpleDecorated $ - text "Record syntax is illegal here:" <+> ppr ty - TcRnUnexpectedTypeSplice ty - -> mkSimpleDecorated $ - text "Unexpected type splice:" <+> 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 pred - -> text "it has an unpromotable context" - <+> quotes (ppr pred) - 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" - 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" - TcRnNameByTemplateHaskellQuote name -> mkSimpleDecorated $ - text "Cannot redefine a Name retrieved by a Template Haskell quote:" <+> ppr name - TcRnIllegalBindingOfBuiltIn name -> mkSimpleDecorated $ - text "Illegal binding of built-in syntax:" <+> ppr name - 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 | pragma_warning_import_mod == pragma_warning_defined_mod = empty - | otherwise = text ", but defined in" <+> ppr pragma_warning_defined_mod - TcRnIllegalHsigDefaultMethods name meths - -> mkSimpleDecorated $ - text "Illegal default method" <> plural (NE.toList meths) <+> text "in class definition of" <+> ppr name <+> text "in hsig file" - 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)] - TcRnNoExplicitAssocTypeOrDefaultDeclaration name - -> mkSimpleDecorated $ - text "No explicit" <+> text "associated type" - <+> text "or default declaration for" - <+> quotes (ppr name) - 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 - - TcRnTypedTHWithPolyType ty - -> mkSimpleDecorated $ - vcat [ text "Illegal polytype:" <+> ppr ty - , text "The type of a Typed Template Haskell expression must" <+> - text "not have any quantification." ] - TcRnSpliceThrewException 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" - TcRnInvalidTopDecl _decl - -> mkSimpleDecorated $ - text "Only function, value, annotation, and foreign import declarations may be added with addTopDecls" - TcRnNonExactName 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.") - TcRnAddInvalidCorePlugin plugin - -> mkSimpleDecorated $ - hang - (text "addCorePlugin: invalid plugin module " - <+> text (show plugin) - ) - 2 - (text "Plugins in the current package can't be specified.") - TcRnAddDocToNonLocalDefn doc_loc - -> mkSimpleDecorated $ - text "Can't add documentation to" <+> ppr_loc doc_loc <+> - 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" - - TcRnFailedToLookupThInstName 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" - TcRnCannotReifyInstance ty - -> mkSimpleDecorated $ - hang (text "reifyInstances:" <+> quotes (ppr ty)) - 2 (text "is not a class constraint or type family application") - TcRnCannotReifyOutOfScopeThing 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 - TcRnCannotReifyThingNotInTypeEnv name - -> mkSimpleDecorated $ - quotes (ppr name) <+> text "is not in the type environment at a reify" - TcRnNoRolesAssociatedWithThing thing - -> mkSimpleDecorated $ - text "No roles associated with" <+> (ppr thing) - TcRnCannotRepresentType 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" - TcRnRunSpliceFailure mCallingFnName (ConversionFail what reason) - -> mkSimpleDecorated - . addCallingFn - . addSpliceInfo - $ pprConversionFailReason reason - where - addCallingFn rest = - case mCallingFnName of - Nothing -> rest - Just callingFn -> - hang (text ("Error in a declaration passed to " ++ callingFn ++ ":")) - 2 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)) - TcRnReportCustomQuasiError _ msg -> mkSimpleDecorated $ text msg - TcRnInterfaceLookupError _ sdoc -> mkSimpleDecorated sdoc - 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)) - ] - TcRnBadBootFamInstDecl {} - -> mkSimpleDecorated $ - text "Illegal family instance in hs-boot file" - TcRnIllegalFamilyInstance tycon - -> mkSimpleDecorated $ - vcat [ text "Illegal family instance for" <+> quotes (ppr tycon) - , nest 2 $ parens (ppr tycon <+> text "is not an indexed type family")] - TcRnMissingClassAssoc name - -> mkSimpleDecorated $ - text "Associated type" <+> quotes (ppr name) <+> - text "must be inside a class instance" - TcRnBadFamInstDecl tc_name - -> mkSimpleDecorated $ - text "Illegal family instance for" <+> quotes (ppr tc_name) - TcRnNotOpenFamily tc - -> mkSimpleDecorated $ - text "Illegal instance for closed family" <+> quotes (ppr tc) - 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 - TcRnIllegalStaticFormInSplice e -> mkSimpleDecorated $ - sep [ text "static forms cannot be used in splices:" - , nest 2 $ 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))) - - 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." ] - TcRnCannotDefaultConcrete frr - -> mkSimpleDecorated $ - ppr (frr_context frr) $$ - text "cannot be assigned a fixed runtime representation," <+> - text "not even by defaulting." - - 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 - TcRnRedundantConstraints {} - -> WarningWithFlag Opt_WarnRedundantConstraints - TcRnInaccessibleCode {} - -> 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 - 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 - TcRnIllegalHsBootFileDecl - -> ErrorWithoutFlag - TcRnRecursivePatternSynonym{} - -> ErrorWithoutFlag - TcRnPartialTypeSigTyVarMismatch{} - -> ErrorWithoutFlag - TcRnPartialTypeSigBadQuantifier{} - -> ErrorWithoutFlag - TcRnMissingSignature what exported overridden - -> WarningWithFlag $ missingSignatureWarningFlag what exported overridden - TcRnPolymorphicBinderMissingSig{} - -> WarningWithFlag Opt_WarnMissingLocalSignatures - TcRnOverloadedSig{} - -> ErrorWithoutFlag - TcRnTupleConstraintInst{} - -> ErrorWithoutFlag - TcRnAbstractClassInst{} - -> ErrorWithoutFlag - TcRnNoClassInstHead{} - -> ErrorWithoutFlag - TcRnUserTypeError{} - -> ErrorWithoutFlag - TcRnConstraintInKind{} - -> ErrorWithoutFlag - TcRnUnboxedTupleOrSumTypeFuncArg{} - -> ErrorWithoutFlag - TcRnLinearFuncInKind{} - -> ErrorWithoutFlag - TcRnForAllEscapeError{} - -> ErrorWithoutFlag - TcRnVDQInTermType{} - -> ErrorWithoutFlag - TcRnBadQuantPredHead{} - -> ErrorWithoutFlag - TcRnIllegalTupleConstraint{} - -> ErrorWithoutFlag - TcRnNonTypeVarArgInConstraint{} - -> ErrorWithoutFlag - TcRnIllegalImplicitParam{} - -> ErrorWithoutFlag - TcRnIllegalConstraintSynonymOfKind{} - -> ErrorWithoutFlag - TcRnIllegalClassInst{} - -> ErrorWithoutFlag - TcRnOversaturatedVisibleKindArg{} - -> ErrorWithoutFlag - TcRnBadAssociatedType{} - -> 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 - TcRnAmbiguousField{} - -> WarningWithFlag Opt_WarnAmbiguousFields - TcRnMissingFields{} - -> WarningWithFlag Opt_WarnMissingFields - TcRnFieldUpdateInvalidType{} - -> ErrorWithoutFlag - TcRnNoConstructorHasAllFields{} - -> ErrorWithoutFlag - TcRnMixedSelectors{} - -> ErrorWithoutFlag - TcRnMissingStrictFields{} - -> ErrorWithoutFlag - TcRnNoPossibleParentForFields{} - -> ErrorWithoutFlag - TcRnBadOverloadedRecordUpdate{} - -> 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 - TcRnLazyGADTPattern - -> ErrorWithoutFlag - TcRnArrowProcGADTPattern - -> ErrorWithoutFlag - TcRnSpecialClassInst {} - -> 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 - 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 - TcRnNotARecordSelector{} - -> ErrorWithoutFlag - TcRnRecSelectorEscapedTyVar{} - -> ErrorWithoutFlag - TcRnPatSynNotBidirectional{} - -> ErrorWithoutFlag - TcRnSplicePolymorphicLocalVar{} - -> ErrorWithoutFlag - TcRnIllegalDerivingItem{} - -> ErrorWithoutFlag - TcRnUnexpectedAnnotation{} - -> ErrorWithoutFlag - TcRnIllegalRecordSyntax{} - -> ErrorWithoutFlag - TcRnUnexpectedTypeSplice{} - -> 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 - TcRnNameByTemplateHaskellQuote{} - -> ErrorWithoutFlag - TcRnIllegalBindingOfBuiltIn{} - -> ErrorWithoutFlag - TcRnPragmaWarning{} - -> WarningWithFlag Opt_WarnWarningsDeprecations - TcRnIllegalHsigDefaultMethods{} - -> ErrorWithoutFlag - TcRnBadGenericMethod{} - -> ErrorWithoutFlag - TcRnWarningMinimalDefIncomplete{} - -> WarningWithoutFlag - TcRnDefaultMethodForPragmaLacksBinding{} - -> ErrorWithoutFlag - TcRnIgnoreSpecialisePragmaOnDefMethod{} - -> WarningWithoutFlag - TcRnBadMethodErr{} - -> ErrorWithoutFlag - TcRnNoExplicitAssocTypeOrDefaultDeclaration{} - -> WarningWithFlag (Opt_WarnMissingMethods) - TcRnIllegalTypeData - -> ErrorWithoutFlag - TcRnTypeDataForbids{} - -> ErrorWithoutFlag - TcRnIllegalNewtype{} - -> ErrorWithoutFlag - TcRnTypedTHWithPolyType{} - -> ErrorWithoutFlag - TcRnSpliceThrewException{} - -> ErrorWithoutFlag - TcRnInvalidTopDecl{} - -> ErrorWithoutFlag - TcRnNonExactName{} - -> ErrorWithoutFlag - TcRnAddInvalidCorePlugin{} - -> ErrorWithoutFlag - TcRnAddDocToNonLocalDefn{} - -> ErrorWithoutFlag - TcRnFailedToLookupThInstName{} - -> ErrorWithoutFlag - TcRnCannotReifyInstance{} - -> ErrorWithoutFlag - TcRnCannotReifyOutOfScopeThing{} - -> ErrorWithoutFlag - TcRnCannotReifyThingNotInTypeEnv{} - -> ErrorWithoutFlag - TcRnNoRolesAssociatedWithThing{} - -> ErrorWithoutFlag - TcRnCannotRepresentType{} - -> ErrorWithoutFlag - TcRnRunSpliceFailure{} - -> ErrorWithoutFlag - TcRnReportCustomQuasiError isError _ - -> if isError then ErrorWithoutFlag else WarningWithoutFlag - TcRnInterfaceLookupError{} - -> ErrorWithoutFlag - TcRnUnsatisfiedMinimalDef{} - -> WarningWithFlag (Opt_WarnMissingMethods) - TcRnMisplacedInstSig{} - -> ErrorWithoutFlag - TcRnBadBootFamInstDecl{} - -> ErrorWithoutFlag - TcRnIllegalFamilyInstance{} - -> ErrorWithoutFlag - TcRnMissingClassAssoc{} - -> ErrorWithoutFlag - TcRnBadFamInstDecl{} - -> ErrorWithoutFlag - TcRnNotOpenFamily{} - -> ErrorWithoutFlag - TcRnNoRebindableSyntaxRecordDot{} - -> ErrorWithoutFlag - TcRnNoFieldPunsRecordDot{} - -> ErrorWithoutFlag - TcRnIllegalStaticExpression{} - -> ErrorWithoutFlag - TcRnIllegalStaticFormInSplice{} - -> ErrorWithoutFlag - TcRnListComprehensionDuplicateBinding{} - -> ErrorWithoutFlag - TcRnEmptyStmtsGroup{} - -> ErrorWithoutFlag - TcRnLastStmtNotExpr{} - -> ErrorWithoutFlag - TcRnUnexpectedStatementInContext{} - -> ErrorWithoutFlag - TcRnSectionWithoutParentheses{} - -> ErrorWithoutFlag - TcRnIllegalImplicitParameterBindings{} - -> ErrorWithoutFlag - TcRnIllegalTupleSection{} - -> ErrorWithoutFlag - TcRnLoopySuperclassSolve{} - -> WarningWithFlag Opt_WarnLoopySuperclassSolve - TcRnCannotDefaultConcrete{} - -> 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 - TcRnRedundantConstraints{} - -> noHints - TcRnInaccessibleCode{} - -> 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 - 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 - TcRnIllegalHsBootFileDecl - -> noHints - TcRnRecursivePatternSynonym{} - -> noHints - TcRnPartialTypeSigTyVarMismatch{} - -> noHints - TcRnPartialTypeSigBadQuantifier{} - -> noHints - TcRnMissingSignature {} - -> noHints - TcRnPolymorphicBinderMissingSig{} - -> noHints - TcRnOverloadedSig{} - -> noHints - TcRnTupleConstraintInst{} - -> noHints - TcRnAbstractClassInst{} - -> noHints - TcRnNoClassInstHead{} - -> 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] - TcRnIllegalClassInst{} - -> noHints - TcRnOversaturatedVisibleKindArg{} - -> noHints - TcRnBadAssociatedType{} - -> 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 - TcRnMonomorphicBindings bindings - -> case bindings of - [] -> noHints - (x:xs) -> [SuggestAddTypeSignatures $ NamedBindings (x NE.:| xs)] - TcRnOrphanInstance{} - -> [SuggestFixOrphanInstance] - 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 - TcRnAmbiguousField{} - -> noHints - TcRnMissingFields{} - -> noHints - TcRnFieldUpdateInvalidType{} - -> noHints - TcRnNoConstructorHasAllFields{} - -> noHints - TcRnMixedSelectors{} - -> noHints - TcRnMissingStrictFields{} - -> noHints - TcRnNoPossibleParentForFields{} - -> noHints - TcRnBadOverloadedRecordUpdate{} - -> noHints - 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 - TcRnLazyGADTPattern - -> noHints - TcRnArrowProcGADTPattern - -> noHints - TcRnSpecialClassInst {} - -> 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 - 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{} <- why -> [SuggestImportingDataCon] - | UnliftedFFITypesNeeded <- why -> [suggestExtension LangExt.UnliftedFFITypes] - _ -> noHints - TcRnInvalidCIdentifier{} - -> noHints - TcRnExpectedValueId{} - -> noHints - TcRnNotARecordSelector{} - -> noHints - TcRnRecSelectorEscapedTyVar{} - -> [SuggestPatternMatchingSyntax] - TcRnPatSynNotBidirectional{} - -> noHints - TcRnSplicePolymorphicLocalVar{} - -> noHints - TcRnIllegalDerivingItem{} - -> noHints - TcRnUnexpectedAnnotation{} - -> noHints - TcRnIllegalRecordSyntax{} - -> noHints - TcRnUnexpectedTypeSplice{} - -> 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] - TcRnNameByTemplateHaskellQuote{} - -> noHints - TcRnIllegalBindingOfBuiltIn{} - -> noHints - TcRnPragmaWarning{} - -> noHints - TcRnIllegalHsigDefaultMethods{} - -> noHints - TcRnBadGenericMethod{} - -> noHints - TcRnWarningMinimalDefIncomplete{} - -> noHints - TcRnDefaultMethodForPragmaLacksBinding{} - -> noHints - TcRnIgnoreSpecialisePragmaOnDefMethod{} - -> noHints - TcRnBadMethodErr{} - -> noHints - TcRnNoExplicitAssocTypeOrDefaultDeclaration{} - -> noHints - TcRnIllegalTypeData - -> [suggestExtension LangExt.TypeData] - TcRnTypeDataForbids{} - -> noHints - TcRnIllegalNewtype{} - -> noHints - TcRnTypedTHWithPolyType{} - -> noHints - TcRnSpliceThrewException{} - -> noHints - TcRnInvalidTopDecl{} - -> noHints - TcRnNonExactName{} - -> noHints - TcRnAddInvalidCorePlugin{} - -> noHints - TcRnAddDocToNonLocalDefn{} - -> noHints - TcRnFailedToLookupThInstName{} - -> noHints - TcRnCannotReifyInstance{} - -> noHints - TcRnCannotReifyOutOfScopeThing{} - -> noHints - TcRnCannotReifyThingNotInTypeEnv{} - -> noHints - TcRnNoRolesAssociatedWithThing{} - -> noHints - TcRnCannotRepresentType{} - -> noHints - TcRnRunSpliceFailure{} - -> noHints - TcRnReportCustomQuasiError{} - -> noHints - TcRnInterfaceLookupError{} - -> noHints - TcRnUnsatisfiedMinimalDef{} - -> noHints - TcRnMisplacedInstSig{} - -> [suggestExtension LangExt.InstanceSigs] - TcRnBadBootFamInstDecl{} - -> noHints - TcRnIllegalFamilyInstance{} - -> noHints - TcRnMissingClassAssoc{} - -> noHints - TcRnBadFamInstDecl{} - -> [suggestExtension LangExt.TypeFamilies] - TcRnNotOpenFamily{} - -> noHints - TcRnNoRebindableSyntaxRecordDot{} - -> noHints - TcRnNoFieldPunsRecordDot{} - -> noHints - TcRnIllegalStaticExpression{} - -> [suggestExtension LangExt.StaticPointers] - TcRnIllegalStaticFormInSplice{} - -> 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] - 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 - TcRnCannotDefaultConcrete{} - -> [SuggestAddTypeSignatures UnnamedBinding] - - 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' - -dodgy_msg :: (Outputable a, Outputable b) => SDoc -> a -> b -> SDoc -dodgy_msg kind tc ie - = sep [ text "The" <+> kind <+> text "item" - <+> quotes (ppr ie) - <+> text "suggests that", - quotes (ppr tc) <+> text "has (in-scope) constructors or class methods,", - text "but it has none" ] - -dodgy_msg_insert :: forall p . (Anno (IdP (GhcPass p)) ~ SrcSpanAnnN) => IdP (GhcPass p) -> IE (GhcPass p) -dodgy_msg_insert tc = IEThingAll noAnn ii - where - ii :: LIEWrappedName (GhcPass p) - ii = noLocA (IEName noExtField $ noLocA tc) - -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 - RecordFieldConstructor{} -> text "construction" - RecordFieldPattern{} -> text "pattern" - RecordFieldUpdate -> text "update" - -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 flag is associated with the given missing signature? -missingSignatureWarningFlag :: MissingSignature -> Exported -> Bool -> WarningFlag -missingSignatureWarningFlag (MissingTopLevelBindingSig {}) exported overridden - | IsExported <- exported - , not overridden - = Opt_WarnMissingExportedSignatures - | otherwise - = Opt_WarnMissingSignatures -missingSignatureWarningFlag (MissingPatSynSig {}) exported overridden - | IsExported <- exported - , not overridden - = Opt_WarnMissingExportedPatternSynonymSignatures - | otherwise - = Opt_WarnMissingPatternSynonymSignatures -missingSignatureWarningFlag (MissingTyConKindSig {}) _ _ - = Opt_WarnMissingKindSignatures - -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) - -{- ********************************************************************* -* * - 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 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 }) - = hang (pprMismatchMsg ctxt mismatch_msg) - 2 (vcat ( 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. - -> isConcrete (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 _ (UntouchableVariable tv implic) - | Implic { ic_given = given, ic_info = skol_info } <- implic - = 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 (getLclEnvLoc (ic_env implic)) ] -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 (getLclEnvLoc (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 (getLclEnvLoc (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 - -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 }) = - mk_msg tv1 $$ 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)) - 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 greMangledName 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 - where - what = pprNonVarNameSpace (occNameSpace (rdrNameOcc rdr_name)) - -scopeErrorHints :: NotInScopeError -> [GhcHint] -scopeErrorHints scope_err = - case scope_err of - NotInScope -> noHints - NoExactName {} -> [SuggestDumpSlices] - SameName {} -> [SuggestDumpSlices] - MissingBinding _ hints -> hints - NoTopLevelBinding -> noHints - UnknownSubordinate {} -> 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 (getLclEnvLoc (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 = lclEnvInGeneratedCode (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 -> - text "RecGadtC must have at least one constructor name" - GadtNoCons -> - text "GadtC 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" +{-# 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 @@ -1,4045 +1,7064 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE KindSignatures #-} - -module GHC.Tc.Errors.Types ( - -- * Main types - TcRnMessage(..) - , mkTcRnUnknownMessage - , TcRnMessageDetailed(..) - , TypeDataForbids(..) - , ErrInfo(..) - , FixedRuntimeRepProvenance(..) - , pprFixedRuntimeRepProvenance - , ShadowedNameProvenance(..) - , RecordFieldPart(..) - , IllegalNewtypeReason(..) - , 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(..) - , ConversionFailReason(..) - , UnrepresentableTypeDescr(..) - , LookupTHInstNameErrReason(..) - , SplicePhase(..) - , THDeclDescriptor(..) - , RunSpliceFailReason(..) - , ThingBeingConverted(..) - , IllegalDecls(..) - , EmptyStatementGroupErrReason(..) - , UnexpectedStatement(..) - ) where - -import GHC.Prelude - -import GHC.Hs -import {-# SOURCE #-} GHC.Tc.Types (TcIdSigInfo, TcTyThing) -import {-# SOURCE #-} 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(..) ) -import GHC.Tc.Types.Rank (Rank) -import GHC.Tc.Utils.TcType (IllegalForeignTypeReason, TcType) -import GHC.Types.Error -import GHC.Types.Hint (UntickedPromotedThing(..)) -import GHC.Types.ForeignCall (CLabelString) -import GHC.Types.Name (Name, OccName, getSrcLoc, getSrcSpan) -import qualified GHC.Types.Name.Occurrence as OccName -import GHC.Types.Name.Reader -import GHC.Types.SrcLoc -import GHC.Types.TyThing (TyThing) -import GHC.Types.Var (Id, TyCoVar, TyVar, TcTyVar) -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) -import GHC.Core.Coercion.Axiom (CoAxBranch) -import GHC.Core.ConLike (ConLike) -import GHC.Core.DataCon (DataCon) -import GHC.Core.FamInstEnv (FamInst) -import GHC.Core.InstEnv (ClsInst) -import GHC.Core.PatSyn (PatSyn) -import GHC.Core.Predicate (EqRel, predTypeEqRel) -import GHC.Core.TyCon (TyCon, TyConFlavour) -import GHC.Core.Type (Kind, Type, ThetaType, PredType) -import GHC.Driver.Backend (Backend) -import GHC.Unit.State (UnitState) -import GHC.Types.Basic -import GHC.Utils.Misc (capitalise, filterOut) -import qualified GHC.LanguageExtensions as LangExt -import GHC.Data.FastString (FastString) -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 (WarningTxt) -import qualified Language.Haskell.TH.Syntax as TH - -import GHC.Generics ( Generic ) - -{- -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 (UnknownDiagnostic diag) - --- | 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 -> 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 the '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. - - {-| 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 - - {-| 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 - {-| TcRnDodgyImports is a warning (controlled with -Wdodgy-imports) that occurs when - a datatype 'T' is imported with all constructors, i.e. 'T(..)', but has been exported - abstractly, i.e. 'T'. - - Test cases: rename/should_compile/T7167 - -} - TcRnDodgyImports :: RdrName -> TcRnMessage - {-| TcRnDodgyExports is a warning (controlled by -Wdodgy-exports) that occurs when a datatype - 'T' is exported with all constructors, i.e. 'T(..)', but is it just a type synonym or a - type/data family. - - 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 :: Name -> 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 - - {-| TcRnDuplicateWarningDecls is an error that occurs whenever - a warning is declared twice. - - Examples(s): - None. - - Test cases: - None. - -} - TcRnDuplicateWarningDecls :: !(LocatedN RdrName) -> !RdrName -> TcRnMessage - - {-| TcRnDuplicateWarningDecls 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 record. - - Examples(s): None. - - Test cases: None. - -} - 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 - - {-| TcRnIllegalWildcardsInConstructor is an error that occurs whenever - the record wildcards '..' are used inside a constructor without labeled fields. - - Examples(s): None - - Test cases: None - -} - 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 - - {-| TcRnIllegalHsBootFileDecl is an error that occurs when an hs-boot file - contains declarations that are not allowed, such as bindings. - - Example(s): None - - Test cases: None - -} - TcRnIllegalHsBootFileDecl :: 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 - - Test cases: - T11077 (top-level bindings) - T12484 (pattern synonyms) - T19564 (kind signatures) - -} - TcRnMissingSignature :: MissingSignature - -> Exported - -> Bool -- ^ True: -Wmissing-signatures overrides -Wmissing-exported-signatures, - -- or -Wmissing-pattern-synonym-signatures overrides -Wmissing-exported-pattern-synonym-signatures - -> 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 - - {-| TcRnAbstractClassInst is an error that occurs whenever an instance - of an abstract class is specified. - - Examples(s): - -- 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 - - -- Main.hs - import A - main = print (f :: Int) - - Test cases: typecheck/should_fail/T13068 - -} - TcRnAbstractClassInst :: !Class -> TcRnMessage - - {-| TcRnNoClassInstHead is an error that occurs whenever an instance - head is not headed by a class. - - Examples(s): - instance c - - Test cases: typecheck/rename/T5513 - typecheck/rename/T16385 - -} - TcRnNoClassInstHead :: !Type -> 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 - - {-| TcRnIllegalClassInst is an error that occurs whenever a class instance is specified - for a non-class. - - Examples(s): - type C1 a = (Show (a -> Bool)) - instance C1 Int where - - Test cases: polykinds/T13267 - -} - TcRnIllegalClassInst :: !TyConFlavour -> 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 - - {-| TcRnBadAssociatedType is an error that occurs whenever a class doesn't have an - 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 - -} - TcRnBadAssociatedType :: {-Class-} !Name -> {-TyCon-} !Name -> 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 - - {-| TcRnMonomorphicBindings is a warning (controlled by -Wmonomorphism-restriction) - that arise 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 -Wwarn-orphans) - that arises when a typeclass instance is an \"orphan\", i.e. if it appears - in a module in which neither the class 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 :: ClsInst -> 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 :: InjectivityErrReason -> TyCon -> NE.NonEmpty CoAxBranch -> 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 :: GreName -> 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 -> TyThing -> GreName -> [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 - -> GreName -- ^ Name of first export - -> GlobalRdrElt -- ^ Provenance for definition site of first export - -> IE GhcPs -- ^ Export decl of first export - -> GreName -- ^ Name of second export - -> GlobalRdrElt -- ^ Provenance for definition site of second export - -> IE GhcPs -- ^ Export decl of second export - -> TcRnMessage - - {-| TcRnAmbiguousField is a warning controlled by -Wambiguous-fields occurring - when a record update's type cannot be precisely determined. 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 - -} - TcRnAmbiguousField - :: 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 - - {-| TcRnNoConstructorHasAllFields is an error that occurs when a record update - has fields that no single constructor encompasses. - - Example(s): - data Foo = A { x :: Bool } - | B { y :: Int } - foo = (A False) { x = True, y = 5 } - - Test cases: overloadedrecflds/should_fail/overloadedrecfldsfail08 - patsyn/should_fail/mixed-pat-syn-record-sels - typecheck/should_fail/T7989 - -} - TcRnNoConstructorHasAllFields :: [FieldLabelString] -> TcRnMessage - - {- TcRnMixedSelectors is an error for when a mixture of pattern synonym and - record selectors are used in the same record update block. - - Example(s): - data Rec = Rec { foo :: Int, bar :: String } - pattern Pat { f1, f2 } = Rec { foo = f1, bar = f2 } - illegal :: Rec -> Rec - illegal r = r { f1 = 1, bar = "two" } - - Test cases: patsyn/should_fail/records-mixing-fields - -} - TcRnMixedSelectors - :: Name -- ^ Record - -> [Id] -- ^ Record selectors - -> Name -- ^ Pattern synonym - -> [Id] -- ^ Pattern selectors - -> 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 - - {- TcRnNoPossibleParentForFields is an error thrown when the fields used in a - record update block do not all belong to any one type. - - Example(s): - data R1 = R1 { x :: Int, y :: Int } - data R2 = R2 { y :: Int, z :: Int } - update r = r { x = 1, y = 2, z = 3 } - - Test cases: overloadedrecflds/should_fail/overloadedrecfldsfail01 - overloadedrecflds/should_fail/overloadedrecfldsfail14 - -} - TcRnNoPossibleParentForFields :: [LHsRecUpdField GhcRn] -> TcRnMessage - - {- TcRnBadOverloadedRecordUpdate is an error for a record update that cannot - be pinned down to any one constructor and thus must be given a type signature. - - Example(s): - data R1 = R1 { x :: Int } - data R2 = R2 { x :: Int } - update r = r { x = 1 } -- needs a type signature - - Test cases: overloadedrecflds/should_fail/overloadedrecfldsfail01 - -} - TcRnBadOverloadedRecordUpdate :: [LHsRecUpdField GhcRn] -> 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 - {-| TcRnSpecialClassInst is an error that occurs when a user - attempts to define an 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 - - -} - TcRnSpecialClassInst :: !Class - -> !Bool -- ^ Whether the error is due to Safe Haskell being enabled - -> 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 - - {-| 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: 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 - - {-| 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 - - {- TcRnNotARecordSelector is an error for when something that is not a record - selector is used in a record pattern. - - Example(s): - data Rec = MkRec { field :: Int } - r = Mkrec 1 - r' = r { notAField = 2 } - - Test cases: rename/should_fail/rnfail054 - typecheck/should_fail/tcfail114 - -} - TcRnNotARecordSelector :: !Name -> 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 - - {- TcRnSplicePolymorphicLocalVar 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 - -} - TcRnSplicePolymorphicLocalVar :: !Id -> 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 :: !(HsType GhcRn) -> TcRnMessage - - {- TcRnUnexpectedTypeSplice is an error for a typed template haskell splice - appearing unexpectedly. - - Example(s): none - - Test cases: none - -} - TcRnUnexpectedTypeSplice :: !(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 () 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 - - {- 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 - -} - 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 - - {- 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 - - {- TcRnNameByTemplateHaskellQuote is an error that occurs when one tries - to use a Template Haskell splice to define a top-level identifier with - an already existing name. - - (See issue #13968 (closed) on GHC's issue tracker for more details) - - Example(s): - - $(pure [ValD (VarP 'succ) (NormalB (ConE 'True)) []]) - - Test cases: - T13968 - -} - TcRnNameByTemplateHaskellQuote :: !RdrName -> TcRnMessage - - {- TcRnIllegalBindingOfBuiltIn is an error that occurs when one uses built-in - syntax for data constructors or class names. - - Use an OccName here because we don't want to print Prelude.(,) - - Test cases: - rename/should_fail/T14907b - rename/should_fail/rnfail042 - -} - TcRnIllegalBindingOfBuiltIn :: !OccName -> 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 :: ModuleName - } -> 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 - {-| 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: - testsuite/tests/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: - testsuite/tests/warnings/minimal/WarnMinimal.hs: - -} - TcRnWarningMinimalDefIncomplete :: ClassMinimalDef -> TcRnMessage - - {-| TcRnDefaultMethodForPragmaLacksBinding is an error that occurs when - a default method pragma is missing an accompanying binding. - - Test cases: - testsuite/tests/typecheck/should_fail/T5084.hs - testsuite/tests/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: - testsuite/tests/th/T12387 - -} - TcRnBadMethodErr - :: { badMethodErrClassName :: !Name - , badMethodErrMethodName :: !Name - } -> TcRnMessage - {-| TcRnNoExplicitAssocTypeOrDefaultDeclaration is an error that occurs - when a class instance does not provide an expected associated type - or default declaration. - - Test cases: - testsuite/tests/deriving/should_compile/T14094 - testsuite/tests/indexed-types/should_compile/Simple2 - testsuite/tests/typecheck/should_compile/tc254 - -} - TcRnNoExplicitAssocTypeOrDefaultDeclaration - :: 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: - testsuite/tests/gadt/T14719 - testsuite/tests/indexed-types/should_fail/T14033 - testsuite/tests/indexed-types/should_fail/T2334A - testsuite/tests/linear/should_fail/LinearGADTNewtype - testsuite/tests/parser/should_fail/readFail008 - testsuite/tests/polykinds/T11459 - testsuite/tests/typecheck/should_fail/T15523 - testsuite/tests/typecheck/should_fail/T15796 - testsuite/tests/typecheck/should_fail/T17955 - testsuite/tests/typecheck/should_fail/T18891a - testsuite/tests/typecheck/should_fail/T21447 - testsuite/tests/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: - testsuite/tests/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: - testsuite/tests/type-data/should_fail/TDDeriving - testsuite/tests/type-data/should_fail/TDRecordsGADT - testsuite/tests/type-data/should_fail/TDRecordsH98 - testsuite/tests/type-data/should_fail/TDStrictnessGADT - testsuite/tests/type-data/should_fail/TDStrictnessH98 - -} - TcRnTypeDataForbids :: !TypeDataForbids -> TcRnMessage - - {-| TcRnTypedTHWithPolyType 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 - -} - TcRnTypedTHWithPolyType :: !TcType -> TcRnMessage - - {-| TcRnSpliceThrewException is an error that occurrs 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 - -} - TcRnSpliceThrewException - :: !SplicePhase - -> !SomeException - -> !String -- ^ Result of showing the exception (cannot be done safely outside IO) - -> !(LHsExpr GhcTc) - -> !Bool -- True <=> Print the expression - -> TcRnMessage - - {-| TcRnInvalidTopDecl 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: - -} - TcRnInvalidTopDecl :: !(HsDecl GhcPs) -> TcRnMessage - - {-| TcRnNonExactName is a template haskell error for when a declaration being - added is bound to a name that is not fully known. - - Example(s): - - Test cases: - -} - TcRnNonExactName :: !RdrName -> TcRnMessage - - {-| TcRnAddInvalidCorePlugin 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: - -} - TcRnAddInvalidCorePlugin - :: !String -- ^ Module name - -> TcRnMessage - - {-| TcRnAddDocToNonLocalDefn 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 - -} - TcRnAddDocToNonLocalDefn :: !TH.DocLoc -> TcRnMessage - - {-| TcRnFailedToLookupThInstName is a template haskell error that occurrs when looking up an - instance fails. - - Example(s): - - Test cases: showIface/should_fail/THPutDocNonExistent - -} - TcRnFailedToLookupThInstName :: !TH.Type -> !LookupTHInstNameErrReason -> TcRnMessage - - {-| TcRnCannotReifyInstance 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: - -} - TcRnCannotReifyInstance :: !Type -> TcRnMessage - - {-| TcRnCannotReifyOutOfScopeThing 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 - -} - TcRnCannotReifyOutOfScopeThing :: !TH.Name -> TcRnMessage - - {-| TcRnCannotReifyThingNotInTypeEnv 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: - -} - TcRnCannotReifyThingNotInTypeEnv :: !Name -> TcRnMessage - - {-| TcRnNoRolesAssociatedWithName 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: - -} - TcRnNoRolesAssociatedWithThing :: !TcTyThing -> TcRnMessage - - {-| TcRnCannotRepresentThing 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: - -} - TcRnCannotRepresentType :: !UnrepresentableTypeDescr -> !Type -> TcRnMessage - - {-| TcRnRunSpliceFailure 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/T17379a - th/T17379b - 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 - -} - TcRnRunSpliceFailure - :: !(Maybe String) -- ^ Name of the function used to run the splice - -> !RunSpliceFailReason - -> TcRnMessage - - {-| TcRnUserErrReported is an error or warning thrown using 'qReport' from - the 'Quasi' instance of 'TcM'. - - Example(s): - - Test cases: - -} - TcRnReportCustomQuasiError - :: !Bool -- True => Error, False => Warning - -> !String -- Error body - -> TcRnMessage - - {-| TcRnInterfaceLookupError is an error resulting from looking up a name in an interface file. - - Example(s): - - Test cases: - -} - TcRnInterfaceLookupError :: !Name -> !SDoc -> 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: - testsuite/tests/typecheck/prog001/typecheck.prog001 - testsuite/tests/typecheck/should_compile/tc126 - testsuite/tests/typecheck/should_compile/T7903 - testsuite/tests/typecheck/should_compile/tc116 - testsuite/tests/typecheck/should_compile/tc175 - testsuite/tests/typecheck/should_compile/HasKey - testsuite/tests/typecheck/should_compile/tc125 - testsuite/tests/typecheck/should_compile/tc078 - testsuite/tests/typecheck/should_compile/tc161 - testsuite/tests/typecheck/should_fail/T5051 - testsuite/tests/typecheck/should_compile/T21583 - testsuite/tests/backpack/should_compile/bkp47 - testsuite/tests/backpack/should_fail/bkpfail25 - testsuite/tests/parser/should_compile/T2245 - testsuite/tests/parser/should_compile/read014 - testsuite/tests/indexed-types/should_compile/Class3 - testsuite/tests/indexed-types/should_compile/Simple2 - testsuite/tests/indexed-types/should_fail/T7862 - testsuite/tests/deriving/should_compile/deriving-1935 - testsuite/tests/deriving/should_compile/T9968a - testsuite/tests/deriving/should_compile/drv003 - testsuite/tests/deriving/should_compile/T4966 - testsuite/tests/deriving/should_compile/T14094 - testsuite/tests/perf/compiler/T15304 - testsuite/tests/warnings/minimal/WarnMinimal - testsuite/tests/simplCore/should_compile/simpl020 - testsuite/tests/deSugar/should_compile/T14546d - testsuite/tests/ghci/scripts/T5820 - testsuite/tests/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: - testsuite/tests/module/mod45 - -} - TcRnMisplacedInstSig :: Name -> (LHsSigType GhcRn) -> TcRnMessage - {- | 'TcRnBadBootFamInstDecl' is an error that is triggered by a - type family instance being declared in an hs-boot file. - - Test case: - testsuite/tests/indexed-types/should_fail/HsBootFam - -} - TcRnBadBootFamInstDecl :: {} -> TcRnMessage - {- | 'TcRnIllegalFamilyInstance' is an error that occurs when an associated - type or data family is given a top-level instance. - - Test case: - testsuite/tests/indexed-types/should_fail/T3092 - -} - TcRnIllegalFamilyInstance :: TyCon -> TcRnMessage - {- | 'TcRnMissingClassAssoc' is an error that occurs when a class instance - for a class with an associated type or data family is missing a corresponding - family instance declaration. - - Test case: - testsuite/tests/indexed-types/should_fail/SimpleFail7 - -} - TcRnMissingClassAssoc :: TyCon -> TcRnMessage - {- | 'TcRnBadFamInstDecl' is an error that is triggered by a type or data family - instance without the @TypeFamilies@ extension. - - Test case: - testsuite/tests/indexed-types/should_fail/BadFamInstDecl - -} - TcRnBadFamInstDecl :: TyCon -> TcRnMessage - {- | 'TcRnNotOpenFamily' is an error that is triggered by attempting to give - a top-level (open) type family instance for a closed type family. - - Test cases: - testsuite/tests/indexed-types/should_fail/Overlap7 - testsuite/tests/indexed-types/should_fail/Overlap3 - -} - TcRnNotOpenFamily :: TyCon -> 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 - - {-| TcRnIllegalStaticFormInSplice is an error when a user attempts to define - a static pointer in a Template Haskell splice. - - Example(s): - - Test cases: th/TH_StaticPointers02 - -} - TcRnIllegalStaticFormInSplice :: 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 - - {-| 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 - - {- TcRnCannotDefaultConcrete is an error occurring when a concrete - type variable cannot be defaulted. - - Test cases: - T23153 - -} - TcRnCannotDefaultConcrete - :: !FixedRuntimeRepOrigin - -> TcRnMessage - - - 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" - -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 - --- | 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 - = RecordFieldConstructor !Name - | RecordFieldPattern !Name - | RecordFieldUpdate - --- | 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 - --- | 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 - -instance Outputable Exported where - ppr IsNotExported = text "IsNotExported" - ppr IsExported = text "IsExported" - --------------------------------------------------------------------------------- --- --- 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 Type - - -- | We want to report an out of scope variable or a typed hole. - -- See 'HoleError'. - | ReportHoleError Hole HoleError - - -- | Trying to unify an untouchable variable, e.g. a variable from an outer scope. - -- - -- Test case: Simple14 - | UntouchableVariable - { untouchableTyVar :: TyVar - , untouchableTyVarImplication :: Implication - } - - -- | 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.Canonical, - -- wrinkle (2). 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 - --- | 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 - - -- | 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 - 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)" - -data PromotionErr - = TyConPE -- TyCon used in a kind before we are ready - -- data T :: T -> * where ... - | ClassPE -- Ditto Class - - | FamDataConPE -- Data constructor for a data family - -- See Note [AFamDataCon: not promoting data family constructors] - -- in GHC.Tc.Utils.Env. - | ConstrainedDataConPE PredType - -- Data constructor with a non-equality context - -- See Note [Constraints in kinds] in GHC.Core.TyCo.Rep - | PatSynPE -- Pattern synonyms - -- See Note [Don't promote pattern synonyms] in GHC.Tc.Utils.Env - - | 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) - -instance Outputable PromotionErr where - ppr ClassPE = text "ClassPE" - ppr TyConPE = text "TyConPE" - ppr PatSynPE = text "PatSynPE" - ppr FamDataConPE = text "FamDataConPE" - ppr (ConstrainedDataConPE pred) = text "ConstrainedDataConPE" - <+> parens (ppr pred) - ppr RecDataConPE = text "RecDataConPE" - ppr NoDataKindsDC = text "NoDataKindsDC" - ppr TermVariablePE = text "TermVariablePE" - -pprPECategory :: PromotionErr -> SDoc -pprPECategory = text . capitalise . peCategory - -peCategory :: PromotionErr -> String -peCategory ClassPE = "class" -peCategory TyConPE = "type constructor" -peCategory PatSynPE = "pattern synonym" -peCategory FamDataConPE = "data constructor" -peCategory ConstrainedDataConPE{} = "data constructor" -peCategory RecDataConPE = "data constructor" -peCategory NoDataKindsDC = "data constructor" -peCategory TermVariablePE = "term variable" - --- | 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 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 - --- | 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 +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE TypeApplications #-} +{-# 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 new file mode 100644 --- /dev/null +++ b/GHC/Tc/Errors/Types/PromotionErr.hs @@ -0,0 +1,124 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE LambdaCase #-} + +module GHC.Tc.Errors.Types.PromotionErr ( PromotionErr(..) + , pprPECategory + , peCategory + , TermLevelUseErr(..) + , TermLevelUseCtxt(..) + , pprTermLevelUseCtxt + , teCategory + ) where + +import GHC.Prelude +import GHC.Core.Type (ThetaType) +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 + -- data T :: T -> * where ... + | ClassPE -- Ditto Class + + | FamDataConPE -- Data constructor for a data family + -- See Note [AFamDataCon: not promoting data family constructors] + -- in GHC.Tc.Utils.Env. + | ConstrainedDataConPE ThetaType -- Data constructor with a context + -- See Note [No constraints in kinds] in GHC.Tc.Validity + | PatSynPE -- Pattern synonyms + -- See Note [Don't promote pattern synonyms] in GHC.Tc.Utils.Env + + | RecDataConPE -- Data constructor in a recursive loop + -- See Note [Recursion and promoting data constructors] in GHC.Tc.TyCl + | TermVariablePE -- See Note [Demotion of unqualified variables] in GHC.Rename.Env + | TypeVariablePE -- See Note [Type variable scoping errors during typechecking] + deriving (Generic) + +instance Outputable PromotionErr where + ppr ClassPE = text "ClassPE" + ppr TyConPE = text "TyConPE" + ppr PatSynPE = text "PatSynPE" + ppr FamDataConPE = text "FamDataConPE" + ppr (ConstrainedDataConPE theta) = text "ConstrainedDataConPE" <+> parens (ppr theta) + ppr RecDataConPE = text "RecDataConPE" + ppr TermVariablePE = text "TermVariablePE" + ppr TypeVariablePE = text "TypeVariablePE" + +pprPECategory :: PromotionErr -> SDoc +pprPECategory = text . capitalise . peCategory + +peCategory :: PromotionErr -> String +peCategory ClassPE = "class" +peCategory TyConPE = "type constructor" +peCategory PatSynPE = "pattern synonym" +peCategory FamDataConPE = "data constructor" +peCategory ConstrainedDataConPE{} = "data constructor" +peCategory RecDataConPE = "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] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider the scoping of the type variable `a` in the following +term-level example: + + -- f :: [forall b . Either b ()] + f = [Right @a @() () :: forall a. Either a ()] + +Here `@a` in the type application and `a` in the type signature refer to +the same type variable. Indeed, this term elaborates to the following Core: + + f = [(\@a -> Right @a @() ()) :: forall a . Either a ()] + +But how does this work with types? Suppose we have: + + type F = '[Right @a @() () :: forall a. Either a ()] + +To be consistent with the term-level language, we would have to elaborate +this using a big lambda: + + type F = '[(/\ a . Right @a @() ()) :: forall a. Either a ()] + +Core has no such construct, so this is not a valid type. + +Conclusion: Even with -XExtendedForAllScope, the forall'd variables of a +kind signature on a type cannot scope over the type. + +In implementation terms, to get a helpful error message we do this: + +* The renamer treats the type variable as bound by the forall + (so it doesn't just say "out of scope"); see the `HsKindSig` case of GHC.Rename.HsType.rnHsTyKi. + +* The typechecker adds the forall-bound type variables to the type environent, + but bound to `APromotionErr TypeVariablePE`; see the call to `tcAddKindSigPlaceholders` + in the `HsKindSig` case of `GHC.Tc.Gen.HsType.tc_infer_hs_type`. + +* The occurrence site of a type variable then complains when it finds `APromotionErr`; + see `GHC.Tc.Gen.HsType.tcTyVar`. +-} 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,1234 +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.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.Session -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 <- 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 <- 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 -> TcM 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 -> TcM (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 <- 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_all, inst_inferred, inst_none :: ForAllTyFlag -> Bool - inst_all (Invisible {}) = True - inst_all Required = False - - inst_inferred (Invisible InferredSpec) = True - inst_inferred (Invisible SpecifiedSpec) = False - inst_inferred Required = False - - inst_none _ = False - - inst_fun :: [HsExprArg 'TcpRn] -> ForAllTyFlag -> Bool - inst_fun [] | inst_final = inst_all - | otherwise = inst_none - -- Using `inst_none` 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 {} : _) = inst_all - inst_fun _ = inst_inferred - - ----------- - 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) <- tcSplitPhiTy body1 - , 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' - ; 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 <- 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) <- 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 {}) - = 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 <- 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 ] - ; 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 Solver.Canonical - - 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 <- 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 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,16 +23,18 @@ 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 ) import GHC.Types.Tickish (CoreTickish, GenTickish (..)) import GHC.Types.CostCentre (mkUserCC, mkDeclCCFlavour) -import GHC.Driver.Session +import GHC.Driver.DynFlags import GHC.Data.FastString import GHC.Hs +import GHC.Rename.Bind ( rejectBootDecls ) + import GHC.Tc.Errors.Types import GHC.Tc.Gen.Sig import GHC.Tc.Utils.Concrete ( hasFixedRuntimeRep_syntactic ) @@ -43,24 +45,25 @@ 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 import GHC.Tc.Instance.Family( tcGetFamInstEnvs ) import GHC.Tc.Utils.TcType import GHC.Tc.Validity (checkValidType, checkEscapingKind) - -import GHC.Core.Predicate +import GHC.Tc.Zonk.TcType 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 @@ -72,17 +75,15 @@ import GHC.Types.Name import GHC.Types.Name.Set import GHC.Types.Name.Env +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 @@ -91,7 +92,7 @@ import GHC.Data.Maybe import Control.Monad -import Data.Foldable (find) +import Data.Foldable (find, traverse_) {- ************************************************************************ @@ -194,47 +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 +-- signatures in it. The renamer checked all this. tcHsBootSigs binds sigs - = do { checkTc (null binds) TcRnIllegalHsBootFileDecl - ; concatMapM (addLocMA tc_boot_sig) (filter isTypeLSig sigs) } + = do { unless (null binds) $ + rejectBootDecls HsBoot BootBindsRn (concatMap snd binds) + ; concatMapM (addLocM tc_boot_sig) (filter isTypeLSig sigs) } where tc_boot_sig (TypeSig _ lnames hs_ty) = mapM f lnames where @@ -245,6 +221,7 @@ tc_boot_sig s = pprPanic "tcHsBootSigs/tc_boot_sig" (ppr s) ------------------------ + tcLocalBinds :: HsLocalBinds GhcRn -> TcM thing -> TcM (HsLocalBinds GhcTc, thing) @@ -275,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] @@ -326,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) @@ -382,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 @@ -414,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 @@ -450,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) } @@ -476,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 @@ -489,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 @@ -512,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 @@ -528,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 @@ -537,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 @@ -570,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 @@ -579,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! @@ -595,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. @@ -643,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 @@ -656,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) @@ -703,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)) @@ -724,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 @@ -738,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] @@ -746,62 +764,114 @@ , 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 +-- See Note [When the MR applies] checkMonomorphismRestriction mbis lbinds - | null partial_sigs -- The normal case = do { mr_on <- xoptM LangExt.MonomorphismRestriction ; let mr_applies = mr_on && any (restricted . unLoc) lbinds - ; when mr_applies $ mapM_ checkOverloadedSig sigs + ; when mr_applies $ mapM_ checkOverloadedSig mbis ; return mr_applies } - - | otherwise -- See Note [Partial type signatures and the monomorphism restriction] - = return (all is_mono_psig partial_sigs) - where - sigs, partial_sigs :: [TcIdSigInst] - sigs = [sig | MBI { mbi_sig = Just sig } <- mbis] - partial_sigs = [sig | sig@(TISI { sig_inst_sig = PartialSig {} }) <- sigs] - - complete_sig_bndrs :: NameSet - complete_sig_bndrs - = mkNameSet [ idName bndr - | TISI { sig_inst_sig = CompleteSig { sig_bndr = bndr }} <- sigs ] + no_mr_bndrs :: NameSet + no_mr_bndrs = mkNameSet (mapMaybe no_mr_name mbis) - is_mono_psig (TISI { sig_inst_theta = theta, sig_inst_wcx = mb_extra_constraints }) - = null theta && isNothing mb_extra_constraints + no_mr_name :: MonoBindInfo -> Maybe Name + -- Just n for binders that have a signature that says "no MR needed for me" + 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 + 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: + -- the user has explicitly specified a type-class context + no_mr_name _ = Nothing -- The Haskell 98 monomorphism restriction + restricted :: HsBindLR GhcRn GhcRn -> Bool restricted (PatBind {}) = True - restricted (VarBind { var_id = v }) = no_sig v restricted (FunBind { fun_id = v, fun_matches = m }) = restricted_match m - && no_sig (unLoc v) - restricted b = pprPanic "isRestrictedGroup/unrestricted" (ppr b) + && mr_needed_for (unLoc v) + restricted (VarBind { var_ext = x }) = dataConCantHappen x + restricted b@(PatSynBind {}) = pprPanic "isRestrictedGroup/unrestricted" (ppr b) restricted_match mg = matchGroupArity mg == 0 -- No args => like a pattern binding -- Some args => a function binding - no_sig nm = not (nm `elemNameSet` complete_sig_bndrs) + mr_needed_for nm = not (nm `elemNameSet` no_mr_bndrs) -checkOverloadedSig :: TcIdSigInst -> TcM () +checkOverloadedSig :: MonoBindInfo -> TcM () -- Example: -- f :: Eq a => a -> a -- K f = e -- The MR applies, but the signature is overloaded, and it's -- best to complain about this directly -- c.f #11339 -checkOverloadedSig sig - | not (null (sig_inst_theta sig)) - , let orig_sig = sig_inst_sig sig - = setSrcSpan (sig_loc orig_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 (tcIdSigLoc orig_sig) $ failWith $ TcRnOverloadedSig orig_sig - | otherwise - = return () +checkOverloadedSig _ = return () +{- Note [When the MR applies] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The Monomorphism Restriction (MR) applies as specifies in the Haskell Report: + +* If -XMonomorphismRestriction is on, and +* Any binding is restricted + +A binding is restricted if: +* It is a pattern binding e.g. (x,y) = e +* Or it is a FunBind with no arguments e.g. f = rhs + and the binder `f` lacks a No-MR signature + +A binder f has a No-MR signature if + +* It has a complete type signature + e.g. f :: Num a => a -> a + +* Or it has a /partial/ type signature with a /context/ + e.g. f :: (_) => a -> _ + g :: Num a => a -> _ + h :: (Num a, _) => a -> _ + All of f,g,h have a No-MR signature. They say that the function is overloaded + so it's silly to try to apply the MR. This means that #19106 works out + fine. Ditto #11016, which looked like + f4 :: (?loc :: Int) => _ + f4 = ?loc + + This partial-signature stuff is a bit ad-hoc but seems to match our + use-cases. See also Note [Constraints in partial type signatures] + in GHC.Tc.Solver. + +Example: the MR does apply to + k :: _ -> _ + k = rhs +because k's binding has no arguments, and `k` does not have +a No-MR signature. + +All of this checking takes place after synonym expansion. For example: + type Wombat a = forall b. Eq [b] => ...b...a... + f5 :: Wombat _ +This (and does) behave just like + f5 :: forall b. Eq [b] => ...b..._... + +-} + -------------- mkExport :: TcPragEnv -> WantedConstraints -- residual constraints, already emitted (for errors only) @@ -809,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 @@ -826,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 }) - = do { mono_ty <- zonkTcType (idType 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, @@ -850,19 +923,14 @@ 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 GhcBug20076 + else tcSubTypeSigma (ImpedanceMatching poly_id) sig_ctxt sel_poly_ty poly_ty - -- as Note [Impedance matching] explains, this should never fail, - -- and thus we'll never see an error message. It *may* do - -- instantiation, but no message will ever be printed to the - -- user, and so we use Shouldn'tHappenOrigin. - -- Actually, there is a bug here: #20076. So we tell the user - -- that they hit the bug. Once #20076 is fixed, change this - -- back to Shouldn'tHappenOrigin. + -- See Note [Impedance matching] ; 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 @@ -879,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 @@ -903,15 +971,19 @@ ; let inferred_poly_ty = mkInvisForAllTys binders (mkPhiTy theta' mono_ty') ; traceTc "mkInferredPolyId" (vcat [ppr poly_name, ppr qtvs, ppr theta' - , ppr inferred_poly_ty]) + , ppr inferred_poly_ty + , text "insoluble" <+> ppr insoluble ]) + ; unless insoluble $ addErrCtxtM (mk_inf_msg poly_name inferred_poly_ty) $ do { checkEscapingKind inferred_poly_ty + -- See Note [Inferred type with escaping kind] ; checkValidType (InfSigCtxt poly_name) inferred_poly_ty } - -- See Note [Validity of inferred types] - -- If we found an insoluble error in the function definition, don't - -- do this check; otherwise (#14000) we may report an ambiguity - -- error for a rather bogus type. + -- See Note [Validity of inferred types] + -- unless insoluble: if we found an insoluble error in the + -- function definition, don't do this check; otherwise + -- (#14000) we may report an ambiguity error for a rather + -- bogus type. ; return (mkLocalId poly_name ManyTy inferred_poly_ty) } @@ -934,13 +1006,12 @@ ; 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 <- mapM zonkInvisTVBinder psig_qtv_bndrs + ; psig_qtv_bndrs <- liftZonkM $ mapM zonkInvisTVBinder psig_qtv_bndrs ; let psig_qtvs = map binderVar psig_qtv_bndrs psig_qtv_set = mkVarSet psig_qtvs psig_qtv_prs = psig_qtv_nms `zip` psig_qtvs @@ -950,16 +1021,17 @@ -- 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 <- zonkTcTypes annotated_theta + ; annotated_theta <- liftZonkM $ zonkTcTypes annotated_theta ; (free_tvs, my_theta) <- choose_psig_context psig_qtv_set annotated_theta wcx -- NB: free_tvs includes tau_tvs @@ -1019,7 +1091,8 @@ -- We know that wc_co must have type kind(wc_var) ~ Constraint, as it -- comes from the checkExpectedKind in GHC.Tc.Gen.HsType.tcAnonWildCardOcc. -- So, to make the kinds work out, we reverse the cast here. - Just (wc_var, wc_co) -> writeMetaTyVar wc_var (mkConstraintTupleTy diff_theta + Just (wc_var, wc_co) -> liftZonkM $ + writeMetaTyVar wc_var (mkConstraintTupleTy diff_theta `mkCastTy` mkSymCo wc_co) Nothing -> pprPanic "chooseInferredQuantifiers 1" (ppr wc_var_ty) @@ -1033,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 @@ -1049,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 -> TcM (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 () @@ -1068,8 +1139,8 @@ warnMissingSignatures :: Id -> TcM () warnMissingSignatures id - = do { env0 <- tcInitTidyEnv - ; let (env1, tidy_ty) = tidyOpenType env0 (idType id) + = do { env0 <- liftZonkM $ tcInitTidyEnv + ; let (env1, tidy_ty) = tidyOpenTypeX env0 (idType id) ; let dia = TcRnPolymorphicBinderMissingSig (idName id) tidy_ty ; addDiagnosticTcM (env1, dia) } @@ -1098,33 +1169,6 @@ doesn't seem much point. Indeed, adding a partial type signature is a way to get per-binding inferred generalisation. -Note [Partial type signatures and the monomorphism restriction] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We apply the MR if /none/ of the partial signatures has a context. e.g. - f :: _ -> Int - f x = rhs -The partial type signature says, in effect, "there is no context", which -amounts to appplying the MR. Indeed, saying - f :: _ - f = rhs -is a way for forcing the MR to apply. - -But we /don't/ want to apply the MR if the partial signatures do have -a context e.g. (#11016): - f2 :: (?loc :: Int) => _ - f2 = ?loc -It's stupid to apply the MR here. This test includes an extra-constraints -wildcard; that is, we don't apply the MR if you write - f3 :: _ => blah - -But watch out. We don't want to apply the MR to - type Wombat a = forall b. Eq b => ...b...a... - f4 :: Wombat _ -Here f4 doesn't /look/ as if it has top-level overloading, but in fact it -does, hidden under Wombat. We can't "see" that because we only have access -to the HsType at the moment. That's why we do the check in -checkMonomorphismRestriction. - Note [Quantified variables in partial type signatures] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider @@ -1224,32 +1268,9 @@ forall qtvs. theta => f_mono_ty is more polymorphic than f's polytype and the proof is the impedance matcher. -Notice that the impedance matcher may do defaulting. See #7173. - -If we've gotten the constraints right during inference (and we assume we have), -this sub-type check should never fail. It's not really a check -- it's more of -a procedure to produce the right wrapper. - -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. +The impedance matcher can do defaulting: in the above example, we default +to Integer because of Num. See #7173. If we're dealing with a nondefaultable +class, impedance matching can fail. See #23427. ************************************************************************ * * @@ -1263,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 @@ -1280,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 @@ -1344,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] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1425,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 @@ -1445,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. @@ -1482,19 +1535,21 @@ | 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 -tcLhs _ _ other_bind = pprPanic "tcLhs" (ppr other_bind) - -- AbsBind, VarBind impossible +tcLhs _ _ b@(PatSynBind {}) = pprPanic "tcLhs: PatSynBind" (ppr b) + -- pattern synonyms are handled separately; see tc_single +tcLhs _ _ (VarBind { var_ext = x }) = dataConCantHappen x + lookupMBI :: Name -> TcM MonoBindInfo -- After typechecking the pattern, look up the binder -- names that lack a signature, which the pattern has brought @@ -1503,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 @@ -1528,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 @@ -1578,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] @@ -1620,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. @@ -1719,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 @@ -1741,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] @@ -1755,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 @@ -1763,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 @@ -1833,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.Utils.Zonk -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,25 +1,32 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TupleSections #-} -module GHC.Tc.Gen.Export (rnExports, exports_from_avail) where +module GHC.Tc.Gen.Export (rnExports, exports_from_avail, classifyGREs) where import GHC.Prelude import GHC.Hs -import GHC.Types.FieldLabel import GHC.Builtin.Names +import GHC.Core.Class import GHC.Tc.Errors.Types import GHC.Tc.Utils.Monad import GHC.Tc.Utils.Env + ( TyThing(AConLike, AnId), tcLookupGlobal, tcLookupTyCon ) import GHC.Tc.Utils.TcType +import GHC.Rename.Doc +import GHC.Rename.Module import GHC.Rename.Names import GHC.Rename.Env import GHC.Rename.Unbound ( reportUnboundName ) -import GHC.Utils.Error +import GHC.Rename.Splice import GHC.Unit.Module import GHC.Unit.Module.Imported +import GHC.Unit.Module.Warnings import GHC.Core.TyCon import GHC.Utils.Outputable import GHC.Utils.Panic @@ -28,23 +35,29 @@ import GHC.Data.Maybe import GHC.Data.FastString (fsLit) import GHC.Driver.Env +import GHC.Driver.DynFlags +import GHC.Parser.PostProcess ( setRdrNameSpace ) +import qualified GHC.LanguageExtensions as LangExt -import GHC.Types.Unique.Set +import GHC.Types.Unique.Map import GHC.Types.SrcLoc as SrcLoc 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 import GHC.Types.Id.Info import GHC.Types.Name.Reader -import Control.Monad -import GHC.Driver.Session -import GHC.Parser.PostProcess ( setRdrNameSpace ) -import Data.Either ( partitionEithers ) -import GHC.Rename.Doc +import Control.Arrow ( first ) +import Control.Monad ( when ) +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 {- ************************************************************************ @@ -130,31 +143,46 @@ data ExportAccum -- The type of the accumulating parameter of -- the main worker function in rnExports - = ExportAccum - ExportOccMap -- Tracks exported occurrence names - (UniqSet ModuleName) -- Tracks (re-)exported module names + = 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 + expacc_warn_spans :: ExportWarnSpanNames, + -- ^ Information about warnings for names + expacc_dont_warn :: DontWarnExportNames + -- ^ What names not to export warnings for + -- (because they are exported without a warning) + } + emptyExportAccum :: ExportAccum -emptyExportAccum = ExportAccum emptyOccEnv emptyUniqSet +emptyExportAccum = ExportAccum emptyOccEnv emptyNameEnv emptyUniqMap [] emptyNameEnv -accumExports :: (ExportAccum -> x -> TcRn (Maybe (ExportAccum, y))) +accumExports :: (ExportAccum -> x -> TcRn (ExportAccum, Maybe y)) -> [x] - -> TcRn [y] -accumExports f = fmap (catMaybes . snd) . mapAccumLM f' emptyExportAccum - where f' acc x = do - m <- attemptM (f acc x) - pure $ case m of - Just (Just (acc', y)) -> (acc', Just y) - _ -> (acc, Nothing) + -> TcRn ([y], DefaultEnv, ExportWarnSpanNames, DontWarnExportNames) +accumExports f xs = do + (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 + = fromMaybe (acc, Nothing) <$> attemptM (f acc x) -type ExportOccMap = OccEnv (GreName, IE GhcPs) +type ExportOccMap = OccEnv (Name, IE GhcPs) -- Tracks what a particular exported OccName -- in an export list refers to, and which item -- it came from. It's illegal to export two distinct things -- 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 @@ -164,16 +192,13 @@ rnExports explicit_mod exports = checkNoErrs $ -- Fail if anything in rnExports finds -- an error fails, to avoid error cascade - unsetWOptM Opt_WarnWarningsDeprecations $ - -- Do not report deprecations arising from the export - -- list, to avoid bleating about re-exporting a deprecated - -- thing (especially via 'module Foo' export item) do { hsc_env <- getTopEnv ; tcg_env <- getGblEnv ; let dflags = hsc_dflags hsc_env TcGblEnv { tcg_mod = this_mod , tcg_rdr_env = rdr_env , tcg_imports = imports + , tcg_warns = warns , tcg_src = hsc_src } = tcg_env default_main | mainModIs (hsc_HUE hsc_env) == this_mod , Just main_fun <- mainFunIs dflags @@ -189,15 +214,15 @@ ; let real_exports | explicit_mod = exports | has_main - = Just (noLocA [noLocA (IEVar noExtField - (noLocA (IEName noExtField $ noLocA default_main)))]) + = Just (noLocA [noLocA (IEVar Nothing + (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) + ; (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 @@ -206,7 +231,7 @@ else checkNoErrs do_it -- Final processing - ; let final_ns = availsToNameSetWithSelectors final_avails + ; let final_ns = availsToNameSet final_avails ; traceRn "rnExports: Exports:" (ppr final_avails) @@ -214,10 +239,59 @@ , 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 }) } + usesOnly final_ns + , tcg_warns = insertWarnExports + warns new_export_warns}) } -exports_from_avail :: Maybe (LocatedL [LIE GhcPs]) +-- | List of names and the information about their warnings +-- (warning, export list item span) +type ExportWarnSpanNames = [(Name, WarningTxt GhcRn, SrcSpan)] + +-- | Map from names that should not have export warnings to +-- the spans of export list items that are missing those warnings +type DontWarnExportNames = NameEnv (NE.NonEmpty SrcSpan) + + +{- 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 @@ -225,8 +299,8 @@ -- @module Foo@ export is valid (it's not valid -- if we didn't import @Foo@!) -> Module - -> RnM (Maybe [(LIE GhcRn, Avails)], Avails) - -- (Nothing, _) <=> no explicit export list + -> 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 -- names. @@ -239,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 @@ -249,18 +323,22 @@ -- only data families can locally define subordinate things (`ns` here) -- without locally defining (and instead importing) the parent (`n`) fix_faminst avail@(AvailTC n ns) - | availExportsDecl avail = avail - | otherwise = AvailTC n (NormalGreName n:ns) + | availExportsDecl avail + = avail + | otherwise + = AvailTC n (n:ns) fix_faminst avail = avail exports_from_avail (Just (L _ rdr_items)) rdr_env imports this_mod - = do ie_avails <- accumExports do_litem rdr_items + = 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 - return (Just ie_avails, final_exports) + export_warn_names <- aggregate_warnings export_warn_spans dont_warn_export + return (Just ie_avails, ie_dflts, final_exports, export_warn_names) where do_litem :: ExportAccum -> LIE GhcPs - -> RnM (Maybe (ExportAccum, (LIE GhcRn, Avails))) + -> RnM (ExportAccum, Maybe (LIE GhcRn, Avails)) do_litem acc lie = setSrcSpan (getLocA lie) (exports_from_item acc lie) -- Maps a parent to its in-scope children @@ -270,152 +348,379 @@ -- See Note [Avails of associated data families] expand_tyty_gre :: GlobalRdrElt -> [GlobalRdrElt] expand_tyty_gre (gre@GRE { gre_par = ParentIs p }) - | isTyConName p, isTyConName (greMangledName gre) = [gre, gre{ gre_par = NoParent }] - expand_tyty_gre gre = [gre] + | isTyConName p + , isTyConName (greName gre) + = [gre, gre{ gre_par = NoParent }] + expand_tyty_gre gre + = [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 (Maybe (ExportAccum, (LIE GhcRn, Avails))) - exports_from_item (ExportAccum occs earlier_mods) - (L loc ie@(IEModuleContents _ lmod@(L _ mod))) - | mod `elementOfUniqSet` earlier_mods -- Duplicate export of M - = do { addDiagnostic (TcRnDupeModuleExport mod) ; - return Nothing } + -> 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 + } (L loc ie@(IEModuleContents (warn_txt_ps, _) lmod@(L _ mod))) + | Just exported_names <- lookupUniqMap earlier_mods mod -- Duplicate export of M + = do { addDiagnostic (TcRnDupeModuleExport mod) + ; (export_warn_spans', dont_warn_export', _) <- + process_warning export_warn_spans + dont_warn_export + exported_names + warn_txt_ps + (locA loc) + -- Checks if all the names are exported with the same warning message + -- or if they should not be warned about + ; return ( expacc{ expacc_warn_spans = export_warn_spans' + , expacc_dont_warn = dont_warn_export' } + , Nothing ) } - | otherwise - = do { let { exportValid = (mod `elem` imported_modules) - || (moduleName this_mod == mod) - ; gre_prs = pickGREsModExp mod (globalRdrEnvElts rdr_env) - ; new_exports = [ availFromGRE gre' - | (gre, _) <- gre_prs - , gre' <- expand_tyty_gre gre ] - ; all_gres = foldr (\(gre1,gre2) gres -> gre1 : gre2 : gres) [] gre_prs - ; mods = addOneToUniqSet earlier_mods mod - } + | otherwise + = 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 ] + ; new_exports = map availFromGRE new_gres + ; all_gres = foldr (\(gre1,gre2) gres -> gre1 : gre2 : gres) [] gre_prs + ; exported_names = map greName new_gres + ; mods = addToUniqMap earlier_mods mod exported_names + } - ; checkErr exportValid (TcRnExportedModNotImported mod) - ; warnIf (exportValid && null gre_prs) (TcRnNullExportedModule mod) + ; checkErr exportValid (TcRnExportedModNotImported mod) + ; warnIf (exportValid && null gre_prs) (TcRnNullExportedModule mod) - ; traceRn "efa" (ppr mod $$ ppr all_gres) - ; addUsedGREs all_gres + ; traceRn "efa" (ppr mod $$ ppr all_gres) + ; addUsedGREs ExportDeprecationWarnings all_gres - ; occs' <- check_occs ie occs new_exports - -- This check_occs not only finds conflicts - -- between this item and others, but also - -- internally within this item. That is, if - -- 'M.x' is in scope in several ways, we'll have - -- several members of mod_avails with the same - -- OccName. - ; traceRn "export_mod" - (vcat [ ppr mod - , ppr new_exports ]) + ; occs' <- check_occs occs ie new_gres + -- This check_occs not only finds conflicts + -- between this item and others, but also + -- internally within this item. That is, if + -- 'M.x' is in scope in several ways, we'll have + -- several members of mod_avails with the same + -- OccName. + ; (export_warn_spans', dont_warn_export', warn_txt_rn) <- + process_warning export_warn_spans + dont_warn_export + exported_names + warn_txt_ps + (locA loc) - ; return (Just ( ExportAccum occs' mods - , ( L loc (IEModuleContents noExtField lmod) - , new_exports))) } + ; traceRn "export_mod" + (vcat [ ppr mod + , ppr new_exports ]) + ; return ( ExportAccum { expacc_exp_occs = occs' + , expacc_exp_dflts = exp_dflts -- IEModuleContents does not re-export defaults + , expacc_mods = mods + , expacc_warn_spans = export_warn_spans' + , expacc_dont_warn = dont_warn_export' } + , Just (L loc (IEModuleContents warn_txt_rn lmod), new_exports) ) } - exports_from_item acc@(ExportAccum occs mods) (L loc ie) = do - m_new_ie <- lookup_doc_ie ie - case m_new_ie of - Just new_ie -> return (Just (acc, (L loc new_ie, []))) + 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, [])) Nothing -> do - (new_ie, avail) <- lookup_ie ie - if isUnboundName (ieName new_ie) - then return Nothing -- Avoid error cascade - else do + m_ie <- lookup_ie acc lie + case m_ie of + Nothing -> return (acc, Nothing) + Just (acc', new_ie, mb_item) -> + case mb_item of + Nothing -> + return (acc', Nothing) + Just avail -> + return (acc', Just (new_ie, [avail])) - occs' <- check_occs ie occs [avail] + ------------- + lookup_ie :: ExportAccum -> LIE GhcPs -> RnM (Maybe (ExportAccum, LIE GhcRn, Maybe AvailInfo)) + lookup_ie expacc@ExportAccum{ + expacc_exp_occs = occs, + expacc_warn_spans = export_warn_spans, + expacc_dont_warn = dont_warn_export + } (L loc ie@(IEVar warn_txt_ps l doc)) + = do mb_gre <- lookupGreAvailRn (ieLWrappedNameWhatLooking l) $ lieWrappedName l + for mb_gre $ \ gre -> do + let avail = availFromGRE gre + name = greName gre - return (Just ( ExportAccum occs' mods - , (L loc new_ie, [avail]))) + checkThLocalNameNoLift (ieLWrappedUserRdrName l name) + occs' <- check_occs occs ie [gre] + (export_warn_spans', dont_warn_export', warn_txt_rn) + <- process_warning export_warn_spans + dont_warn_export + [name] + warn_txt_ps + (locA loc) - ------------- - lookup_ie :: IE GhcPs -> RnM (IE GhcRn, AvailInfo) - lookup_ie (IEVar _ (L l rdr)) - = do (name, avail) <- lookupGreAvailRn $ ieWrappedName rdr - return (IEVar noExtField (L l (replaceWrappedName rdr name)), avail) + 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) doc') + , Just avail ) - lookup_ie (IEThingAbs _ (L l rdr)) - = do (name, avail) <- lookupGreAvailRn $ ieWrappedName rdr - return (IEThingAbs noAnn (L l (replaceWrappedName rdr name)) - , avail) + lookup_ie expacc@ExportAccum{ + expacc_exp_occs = occs, + expacc_exp_dflts = exp_dflts, + expacc_warn_spans = export_warn_spans, + expacc_dont_warn = dont_warn_export + } (L loc ie@(IEThingAbs warn_txt_ps l doc)) + = do mb_gre <- lookupGreAvailRn (ieLWrappedNameWhatLooking l) $ lieWrappedName l + for mb_gre $ \ gre -> do + let avail = availFromGRE gre + name = greName gre - lookup_ie ie@(IEThingAll _ n') - = do - (n, avail, flds) <- lookup_ie_all ie n' - let name = unLoc n - return (IEThingAll noAnn (replaceLWrappedName n' (unLoc n)) - , availTC name (name:avail) flds) + (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 + [name] + warn_txt_ps + (locA loc) - lookup_ie ie@(IEThingWith _ l wc sub_rdrs) - = do - (lname, subs, avails, flds) - <- addExportErrCtxt ie $ lookup_ie_with l sub_rdrs - (_, all_avail, all_flds) <- - case wc of - NoIEWildcard -> return (lname, [], []) - IEWildcard _ -> lookup_ie_all ie l - let name = unLoc lname - let flds' = flds ++ (map noLoc all_flds) - return (IEThingWith flds' (replaceLWrappedName l name) wc subs, - availTC name (name : avails ++ all_avail) - (map unLoc flds ++ all_flds)) + 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 (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 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 - lookup_ie _ = panic "lookup_ie" -- Other cases covered earlier + 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 + dont_warn_export + all_names + 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) doc') + , Just $ AvailTC name all_names ) - lookup_ie_with :: LIEWrappedName GhcPs -> [LIEWrappedName GhcPs] - -> RnM (Located Name, [LIEWrappedName GhcRn], [Name], - [Located FieldLabel]) - lookup_ie_with (L l rdr) sub_rdrs - = do name <- lookupGlobalOccRn $ ieWrappedName rdr - (non_flds, flds) <- lookupChildrenExport name sub_rdrs - if isUnboundName name - then return (L (locA l) name, [], [name], []) - else return (L (locA l) name, non_flds - , map (ieWrappedName . unLoc) non_flds - , flds) + lookup_ie expacc@ExportAccum{ + expacc_exp_occs = occs, + expacc_warn_spans = export_warn_spans, + expacc_dont_warn = dont_warn_export + } (L loc ie@(IEThingWith (warn_txt_ps, ann) l wc sub_rdrs doc)) + = do mb_gre <- addErrCtxt (ExportCtxt ie) + $ lookupGreAvailRn (ieLWrappedNameWhatLooking l) $ lieWrappedName l + for mb_gre $ \ par -> do + (subs, with_kids) + <- addErrCtxt (ExportCtxt ie) + $ lookup_ie_kids_with par sub_rdrs - lookup_ie_all :: IE GhcPs -> LIEWrappedName GhcPs - -> RnM (Located Name, [Name], [FieldLabel]) - lookup_ie_all ie (L l rdr) = - do name <- lookupGlobalOccRn $ ieWrappedName rdr - let gres = findChildren kids_env name - (non_flds, flds) = classifyGREs gres - addUsedKids (ieWrappedName rdr) gres - when (null gres) $ - if isTyConName name - then addTcRnDiagnostic (TcRnDodgyExports name) - else -- This occurs when you export T(..), but - -- only import T abstractly, or T is a synonym. - addErr (TcRnExportHiddenComponents ie) - return (L (locA l) name, non_flds, flds) + wc_kids <- + case wc of + NoIEWildcard -> return [] + IEWildcard _ -> lookup_ie_kids_all ie l par + let name = greName par + all_kids = with_kids ++ wc_kids + 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 + dont_warn_export + all_names + 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 doc') + , Just $ AvailTC name all_names ) + + lookup_ie _ _ = panic "lookup_ie" -- Other cases covered earlier + + + lookup_ie_kids_with :: GlobalRdrElt -> [LIEWrappedName GhcPs] + -> RnM ([LIEWrappedName GhcRn], [GlobalRdrElt]) + lookup_ie_kids_with gre 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 _loc rdr) gre = + do { let name = greName gre + gres = findChildren kids_env name + -- 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 kids_0 } + ------------- - lookup_doc_ie :: IE GhcPs -> RnM (Maybe (IE GhcRn)) - lookup_doc_ie (IEGroup _ lev doc) = do + + -- 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 + -- of the export statements have a warning) + -- - If the Name already has a warning, adds it + process_warning :: ExportWarnSpanNames -- Old aggregate data about warnins + -> DontWarnExportNames -- Old names not to warn about + -> [Name] -- Names to warn about + -> 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 (LWarningTxt GhcRn)) -- Renamed warning + process_warning export_warn_spans + dont_warn_export + names Nothing loc + = return ( export_warn_spans + , foldr update_dont_warn_export + dont_warn_export names + , Nothing ) + where + update_dont_warn_export :: Name -> DontWarnExportNames -> DontWarnExportNames + update_dont_warn_export name dont_warn_export' + = extendNameEnv_Acc (NE.<|) + NE.singleton + dont_warn_export' + name + loc + + process_warning export_warn_spans + dont_warn_export + names (Just warn_txt_ps) loc + = do + 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 + , Just warn_txt_rn ) + + -- For each name exported with any warnings throws an error + -- if there are any exports of that name with a different warning + aggregate_warnings :: ExportWarnSpanNames + -> DontWarnExportNames + -> RnM (ExportWarnNames GhcRn) + aggregate_warnings export_warn_spans dont_warn_export + = fmap catMaybes + $ mapM (aggregate_single . extract_name) + $ NE.groupBy (\(n1, _, _) (n2, _, _) -> n1 == n2) + $ sortBy (\(n1, _, _) (n2, _, _) -> n1 `compare` n2) export_warn_spans + where + extract_name :: NE.NonEmpty (Name, WarningTxt GhcRn, SrcSpan) + -> (Name, NE.NonEmpty (WarningTxt GhcRn, SrcSpan)) + extract_name l@((name, _, _) NE.:| _) + = (name, NE.map (\(_, warn_txt, span) -> (warn_txt, span)) l) + + aggregate_single :: (Name, NE.NonEmpty (WarningTxt GhcRn, SrcSpan)) + -> RnM (Maybe (Name, WarningTxt GhcRn)) + aggregate_single (name, (warn_txt_rn, loc) NE.:| warn_spans) + = do + -- Emit an error if the warnings differ + case NE.nonEmpty spans_different of + Nothing -> return () + Just spans_different + -> addErrAt loc (TcRnDifferentExportWarnings name spans_different) + -- Emit a warning if some export list items do not have a warning + case lookupNameEnv dont_warn_export name of + Nothing -> return $ Just (name, warn_txt_rn) + Just not_warned_spans -> do + addDiagnosticAt loc (TcRnIncompleteExportWarnings name not_warned_spans) + return Nothing + where + spans_different = map snd $ filter (not . warningTxtSame warn_txt_rn . fst) warn_spans + + ------------- + lookup_doc_ie :: LIE GhcPs -> RnM (Maybe (LIE GhcRn)) + lookup_doc_ie (L loc (IEGroup _ lev doc)) = do doc' <- rnLHsDoc doc - pure $ Just (IEGroup noExtField lev doc') - lookup_doc_ie (IEDoc _ doc) = do + pure $ Just (L loc (IEGroup noExtField lev doc')) + lookup_doc_ie (L loc (IEDoc _ doc)) = do doc' <- rnLHsDoc doc - pure $ Just (IEDoc noExtField doc') - lookup_doc_ie (IEDocNamed _ str) = pure $ Just (IEDocNamed noExtField str) + pure $ Just (L loc (IEDoc noExtField doc')) + lookup_doc_ie (L loc (IEDocNamed _ str)) + = pure $ Just (L loc (IEDocNamed noExtField str)) lookup_doc_ie _ = pure Nothing -- In an export item M.T(A,B,C), we want to treat the uses of -- A,B,C as if they were M.A, M.B, M.C -- Happily pickGREs does just the right thing addUsedKids :: RdrName -> [GlobalRdrElt] -> RnM () - addUsedKids parent_rdr kid_gres = addUsedGREs (pickGREs parent_rdr kid_gres) + addUsedKids parent_rdr kid_gres + = addUsedGREs ExportDeprecationWarnings (pickGREs parent_rdr kid_gres) -classifyGREs :: [GlobalRdrElt] -> ([Name], [FieldLabel]) -classifyGREs = partitionGreNames . map gre_name +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. @@ -426,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. @@ -447,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' -} @@ -476,50 +781,41 @@ -lookupChildrenExport :: Name -> [LIEWrappedName GhcPs] - -> RnM ([LIEWrappedName GhcRn], [Located FieldLabel]) -lookupChildrenExport spec_parent rdr_items = - do - xs <- mapAndReportM doOne rdr_items - return $ partitionEithers xs +lookupChildrenExport :: GlobalRdrElt + -> [LIEWrappedName GhcPs] + -> RnM ([(LIEWrappedName GhcRn, GlobalRdrElt)]) +lookupChildrenExport parent_gre rdr_items = mapAndReportM doOne rdr_items where - -- Pick out the possible namespaces in order of priority - -- This is a consequence of how the parser parses all - -- data constructors as type constructors. - choosePossibleNamespaces :: NameSpace -> [NameSpace] - choosePossibleNamespaces ns - | ns == varName = [varName, tcName] - | ns == tcName = [dataName, tcName] - | otherwise = [ns] + spec_parent = greName parent_gre -- Process an individual child doOne :: LIEWrappedName GhcPs - -> RnM (Either (LIEWrappedName GhcRn) (Located FieldLabel)) + -> RnM (LIEWrappedName GhcRn, GlobalRdrElt) doOne n = do let bareName = (ieWrappedName . unLoc) n - lkup v = lookupSubBndrOcc_helper False True - spec_parent (setRdrNameSpace bareName v) - - name <- combineChildLookupResult $ map lkup $ - choosePossibleNamespaces (rdrNameSpace bareName) + -- Do not report export list declaration deprecations + name <- lookupSubBndrOcc_helper False ExportDeprecationWarnings + (ParentGRE spec_parent (greInfo parent_gre)) bareName traceRn "lookupChildrenExport" (ppr name) -- Default to data constructors for slightly better error -- messages let unboundName :: RdrName unboundName = if rdrNameSpace bareName == varName - then bareName - else setRdrNameSpace bareName dataName + then bareName + else setRdrNameSpace bareName dataName case name of - NameNotFound -> do { ub <- reportUnboundName unboundName - ; let l = getLoc n - ; return (Left (L l (IEName noExtField (L (la2na l) ub))))} - FoundChild par child -> do { checkPatSynParent spec_parent par child - ; return $ case child of - FieldGreName fl -> Right (L (getLocA n) fl) - NormalGreName name -> Left (replaceLWrappedName n name) - } - IncorrectParent p c gs -> failWithDcErr p c gs + NameNotFound -> + do { ub <- reportUnboundName (lookingForSubordinate parent_gre) unboundName + ; let l = getLoc n + gre = mkLocalGRE UnboundGRE NoParent ub + ; return (L l (IEName noExtField (L (l2l l) ub)), gre)} + FoundChild child@(GRE { gre_name = child_nm, gre_par = par }) -> + do { checkPatSynParent spec_parent par child_nm + ; checkThLocalNameNoLift (ieLWrappedUserRdrName n child_nm) + ; return (replaceLWrappedName n child_nm, child) + } + IncorrectParent p c gs -> failWithDcErr (parentGRE_name p) (greName c) gs -- Note [Typing Pattern Synonym Exports] @@ -582,35 +878,33 @@ checkPatSynParent :: Name -- ^ Alleged parent type constructor -- User wrote T( P, Q ) -> Parent -- The parent of P we discovered - -> GreName -- ^ Either a - -- a) Pattern Synonym Constructor - -- b) A pattern synonym selector + -> Name + -- ^ Either a + -- a) Pattern Synonym Constructor + -- b) A pattern synonym selector -> TcM () -- Fails if wrong parent checkPatSynParent _ (ParentIs {}) _ = return () -checkPatSynParent parent NoParent gname +checkPatSynParent parent NoParent nm | isUnboundName parent -- Avoid an error cascade = return () | otherwise - = do { parent_ty_con <- tcLookupTyCon parent - ; mpat_syn_thing <- tcLookupGlobal (greNameMangledName gname) + = do { parent_ty_con <- tcLookupTyCon parent + ; mpat_syn_thing <- tcLookupGlobal nm -- 1. Check that the Id was actually from a thing associated with patsyns ; case mpat_syn_thing of AnId i | isId i , RecSelId { sel_tycon = RecSelPatSyn p } <- idDetails i - -> handle_pat_syn (selErr gname) 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 gname [] } + _ -> 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 @@ -641,111 +935,91 @@ {-===========================================================================-} -check_occs :: IE GhcPs -> ExportOccMap -> [AvailInfo] - -> RnM ExportOccMap -check_occs ie occs avails - -- 'avails' are the entities specified by 'ie' - = foldlM check occs children + +-- | Insert the given 'GlobalRdrElt's into the 'ExportOccMap', checking that +-- each of the given 'GlobalRdrElt's does not appear multiple times in +-- the 'ExportOccMap', as per Note [Exporting duplicate declarations]. +check_occs :: ExportOccMap -> IE GhcPs -> [GlobalRdrElt] -> RnM ExportOccMap +check_occs occs ie gres + -- 'gres' are the entities specified by 'ie' + = do { drf <- xoptM LangExt.DuplicateRecordFields + ; foldlM (check drf) occs gres } where - children = concatMap availGreNames avails -- Check for distinct children exported with the same OccName (an error) or -- for duplicate exports of the same child (a warning). - check :: ExportOccMap -> GreName -> RnM ExportOccMap - check occs child - = case try_insert occs child of - Right occs' -> return occs' + -- + -- See Note [Exporting duplicate declarations]. + check :: Bool -> ExportOccMap -> GlobalRdrElt -> RnM ExportOccMap + check drf_enabled occs gre + = case try_insert occs gre of + Right occs' + -- If DuplicateRecordFields is not enabled, also make sure + -- that we are not exporting two fields with the same occNameFS + -- under different namespaces. + -- + -- See Note [Exporting duplicate record fields]. + | drf_enabled || not (isFieldOcc child_occ) + -> return occs' + | otherwise + -> do { let flds = filter (\(_,ie') -> not $ dupFieldExport_ok ie ie') + $ lookupFieldsOccEnv occs (occNameFS child_occ) + ; case flds of { [] -> return occs'; clash1:clashes -> + do { addDuplicateFieldExportErr (gre,ie) (clash1 NE.:| clashes) + ; return occs } } } Left (child', ie') - | greNameMangledName child == greNameMangledName child' -- Duplicate export - -- But we don't want to warn if the same thing is exported - -- by two different module exports. See ticket #4478. - -> do { warnIf (not (dupExport_ok child ie ie')) (TcRnDuplicateExport child ie ie') + | child == child' -- Duplicate export of a single Name: a warning. + -> do { warnIf (not (dupExport_ok child ie ie')) (TcRnDuplicateExport gre ie ie') ; return occs } - | otherwise -- Same occ name but different names: an error - -> do { global_env <- getGlobalRdrEnv ; - addErr (exportClashErr global_env child' child ie' ie) ; - return occs } + | otherwise -- Same OccName but different Name: an error. + -> do { global_env <- getGlobalRdrEnv + ; addErr (exportClashErr global_env child' child ie' ie) + ; return occs } + where + child = greName gre + child_occ = occName child -- Try to insert a child into the map, returning Left if there is something - -- already exported with the same OccName - try_insert :: ExportOccMap -> GreName -> Either (GreName, IE GhcPs) ExportOccMap + -- already exported with the same OccName. + try_insert :: ExportOccMap -> GlobalRdrElt -> Either (Name, IE GhcPs) ExportOccMap try_insert occs child - = case lookupOccEnv occs name_occ of - Nothing -> Right (extendOccEnv occs name_occ (child, ie)) + = case lookupOccEnv occs occ of + Nothing -> Right (extendOccEnv occs occ (greName child, ie)) Just x -> Left x where - -- For fields, we check for export clashes using the (OccName of the) - -- selector Name - name_occ = nameOccName (greNameMangledName child) - + occ = greOccName child -dupExport_ok :: GreName -> IE GhcPs -> IE GhcPs -> Bool --- The GreName is exported by both IEs. Is that ok? --- "No" iff the name is mentioned explicitly in both IEs --- or one of the IEs mentions the name *alone* --- "Yes" otherwise --- --- Examples of "no": module M( f, f ) --- module M( fmap, Functor(..) ) --- module M( module Data.List, head ) --- --- Example of "yes" --- module M( module A, module B ) where --- import A( f ) --- import B( f ) --- --- Example of "yes" (#2436) --- module M( C(..), T(..) ) where --- class C a where { data T a } --- instance C Int where { data T Int = TInt } +-- | Is it OK for the given name to be exported by both export items? -- --- Example of "yes" (#2436) --- module Foo ( T ) where --- data family T a --- module Bar ( T(..), module Foo ) where --- import Foo --- data instance T Int = TInt - +-- See Note [Exporting duplicate declarations]. +dupExport_ok :: Name -> IE GhcPs -> IE GhcPs -> Bool dupExport_ok child ie1 ie2 = not ( single ie1 || single ie2 || (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 single IEVar {} = True 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 - + single _ = False -failWithDcErr :: Name -> GreName -> [Name] -> TcM a +failWithDcErr :: Name -> Name -> [Name] -> TcM a failWithDcErr parent child parents = do - ty_thing <- tcLookupGlobal (greNameMangledName child) + ty_thing <- tcLookupGlobal child failWithTc $ TcRnExportedParentChildMismatch parent ty_thing child parents exportClashErr :: GlobalRdrEnv - -> GreName -> GreName + -> Name -> Name -> IE GhcPs -> IE GhcPs -> TcRnMessage exportClashErr global_env child1 child2 ie1 ie2 - = TcRnConflictingExports occ child1' gre1' ie1' child2' gre2' ie2' + = TcRnConflictingExports occ gre1' ie1' gre2' ie2' where occ = occName child1 -- get_gre finds a GRE for the Name, so that we can show its provenance @@ -753,9 +1027,127 @@ gre2 = get_gre child2 get_gre child = fromMaybe (pprPanic "exportClashErr" (ppr child)) - (lookupGRE_GreName global_env child) - (child1', gre1', ie1', child2', gre2', ie2') = + (lookupGRE_Name global_env child) + (gre1', ie1', gre2', ie2') = case SrcLoc.leftmost_smallest (greSrcSpan gre1) (greSrcSpan gre2) of - LT -> (child1, gre1, ie1, child2, gre2, ie2) - GT -> (child2, gre2, ie2, child1, gre1, ie1) + LT -> (gre1, ie1, gre2, ie2) + GT -> (gre2, ie2, gre1, ie1) EQ -> panic "exportClashErr: clashing exports have identical location" + +addDuplicateFieldExportErr :: (GlobalRdrElt, IE GhcPs) + -> NE.NonEmpty (Name, IE GhcPs) + -> RnM () +addDuplicateFieldExportErr gre others + = do { rdr_env <- getGlobalRdrEnv + ; let lkup = expectJust . lookupGRE_Name rdr_env + other_gres = fmap (first lkup) others + ; addErr (TcRnDuplicateFieldExport gre other_gres) } + +-- | Is it OK to export two clashing duplicate record fields coming from the +-- given export items, with @-XDisambiguateRecordFields@ disabled? +-- +-- See Note [Exporting duplicate record fields]. +dupFieldExport_ok :: IE GhcPs -> IE GhcPs -> Bool +dupFieldExport_ok ie1 ie2 + | IEModuleContents {} <- ie1 + , ie2 == ie1 + = True + | otherwise + = False + +{- Note [Exporting duplicate declarations] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We want to check that two different export items don't have both attempt to export +the same thing. What do we mean precisely? There are three main situations to consider: + + 1. We export two distinct Names with identical OccNames. This is an error. + 2. We export the same Name in two different export items. This is usually + a warning, but see below. + 3. We export a duplicate record field, and DuplicateRecordFields is not enabled. + See Note [Exporting duplicate record fields]. + +Concerning (2), we sometimes want to allow a duplicate export of a given Name, +as #4478 points out. The logic, as implemented in dupExport_ok, is that we +do not allow a given Name to be exported by two IEs iff either: + + - the Name is mentioned explicitly in both IEs, or + - one of the IEs mentions the name *alone*. + +Examples: + + NOT OK: module M( f, f ) + + f is mentioned explicitly in both + + NOT OK: module M( fmap, Functor(..) ) + NOT OK: module M( module Data.Functor, fmap ) + + One of the import items mentions fmap alone, which is also + exported by the other export item. + + OK: + module M( module A, module B ) where + import A( f ) + import B( f ) + + OK: (#2436) + module M( C(..), T(..) ) where + class C a where { data T a } + instance C Int where { data T Int = TInt } + + OK: (#2436) + module Foo ( T ) where + data family T a + module Bar ( T(..), module Foo ) where + import Foo + data instance T Int = TInt + +Note [Exporting duplicate record fields] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Record fields belonging to different datatypes belong to different namespaces, +as explained in Note [Record field namespacing] in GHC.Types.Name.Occurrence. +However, when the DuplicateRecordFields extension is NOT enabled, we want to +prevent users from exporting record fields that share the same underlying occNameFS. + +To enforce this, in check_occs, when inserting a new record field into the ExportOccMap +and DuplicateRecordFields is not enabled, we also look up any clashing record fields, +and report an error. + +Note however that the clash check has an extra wrinkle, similar to dupExport_ok, +as we want to allow the following: + + {-# LANGUAGE DuplicateRecordFields #-} + module M1 where + data D1 = MkD1 { foo :: Int } + data D2 = MkD2 { foo :: Bool } + + --------------------------------------------- + + module M2 ( module M1 ) where + import M1 + +That is, we should be allowed to re-export the whole module M1, without reporting +any nameclashes, even though M1 exports duplicate record fields and we have not +enabled -XDuplicateRecordFields in M2. This logic is implemented in +dupFieldExport_ok. See test case NoDRFModuleExport. + +Note that this logic only applies to whole-module imports, as we don't want +to allow the following: + + module N0 where + data family D a + module N1 where + import N0 + data instance D Int = MkDInt { foo :: Int } + module N2 where + import N0 + data instance D Bool = MkDBool { foo :: Int } + + module N (D(..)) where + import N1 + import N2 + +Here, the single export item D(..) of N exports both record fields, +`$fld:MkDInt:foo` and `$fld:MkDBool:foo`, so we have to reject the program. +See test overloadedrecfldsfail10. +-} 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,1768 +19,1775 @@ ( tcCheckPolyExpr, tcCheckPolyExprNC, tcCheckMonoExpr, tcCheckMonoExprNC, tcMonoExpr, tcMonoExprNC, - tcInferRho, tcInferRhoNC, - tcPolyExpr, tcExpr, - tcSyntaxOp, tcSyntaxOpGen, SyntaxOpType(..), synKnownType, - tcCheckId, - ) where - -import GHC.Prelude - -import {-# SOURCE #-} GHC.Tc.Gen.Splice( tcTypedSplice, tcTypedBracket, tcUntypedBracket ) - -import GHC.Hs -import GHC.Hs.Syn.Type -import GHC.Rename.Utils -import GHC.Tc.Utils.Zonk -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.Map ( UniqMap, listToUniqMap, lookupUniqMap ) -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.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 ) -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.Types.Origin -import GHC.Tc.Utils.TcType as TcType -import GHC.Types.Id -import GHC.Types.Id.Info -import GHC.Core.ConLike -import GHC.Core.DataCon -import GHC.Core.PatSyn -import GHC.Types.Name -import GHC.Types.Name.Env -import GHC.Types.Name.Set -import GHC.Types.Name.Reader -import GHC.Core.TyCon -import GHC.Core.Type -import GHC.Core.Coercion( mkSymCo ) -import GHC.Tc.Types.Evidence -import GHC.Builtin.Types -import GHC.Builtin.Names -import GHC.Builtin.Uniques ( mkBuiltinUnique ) -import GHC.Driver.Session -import GHC.Types.SrcLoc -import GHC.Utils.Misc -import GHC.Data.List.SetOps -import GHC.Data.Maybe -import GHC.Utils.Outputable as Outputable -import GHC.Utils.Panic -import GHC.Utils.Panic.Plain -import Control.Monad -import GHC.Core.Class(classTyCon) -import GHC.Types.Unique.Set ( UniqSet, mkUniqSet, elementOfUniqSet, nonDetEltsUniqSet ) - -import Language.Haskell.Syntax.Basic (FieldLabelString(..)) - -import Data.Function -import Data.List (partition, sortBy, intersect) -import qualified Data.List.NonEmpty as NE - -import GHC.Data.Bag ( unitBag ) - -{- -************************************************************************ -* * -\subsection{Main wrappers} -* * -************************************************************************ --} - - -tcCheckPolyExpr, tcCheckPolyExprNC - :: LHsExpr GhcRn -- Expression to type check - -> TcSigmaType -- Expected type (could be a polytype) - -> TcM (LHsExpr GhcTc) -- Generalised expr with expected type - --- tcCheckPolyExpr is a convenient place (frequent but not too frequent) --- place to add context information. --- The NC version does not do so, usually because the caller wants --- to do so themselves. - -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 - addExprCtxt expr $ -- Note [Error contexts in generated code] - do { expr' <- tcPolyExpr expr res_ty - ; return (L loc expr') } - -tcPolyLExprNC (L loc expr) res_ty - = setSrcSpanA loc $ - do { expr' <- tcPolyExpr expr res_ty - ; return (L loc expr') } - ---------------- -tcCheckMonoExpr, tcCheckMonoExprNC - :: LHsExpr GhcRn -- Expression to type check - -> TcRhoType -- Expected type - -- Definitely no foralls at the top - -> TcM (LHsExpr GhcTc) -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 - -- Definitely no foralls at the top - -> TcM (LHsExpr GhcTc) - -tcMonoExpr (L loc expr) res_ty - = setSrcSpanA loc $ -- Set location /first/; see GHC.Tc.Utils.Monad - addExprCtxt expr $ -- Note [Error contexts in generated code] - do { expr' <- tcExpr expr res_ty - ; return (L loc expr') } - -tcMonoExprNC (L loc expr) res_ty - = setSrcSpanA loc $ - do { expr' <- tcExpr expr res_ty - ; 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) - --- Use tcApp to typecheck applications, which are treated specially --- by Quick Look. Specifically: --- - 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 --- These constructors are the union of --- - ones taken apart by GHC.Tc.Gen.Head.splitHsApps --- - ones understood by GHC.Tc.Gen.Head.tcInferAppHead_maybe --- See Note [Application chains and heads] in GHC.Tc.Gen.App -tcExpr e@(HsVar {}) res_ty = tcApp e res_ty -tcExpr e@(HsApp {}) res_ty = tcApp e res_ty -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.Utils.Zonk - ; case mb_res of - Just lit' -> return (HsOverLit noAnn lit') - Nothing -> tcApp e res_ty } - --- Typecheck an occurrence of an unbound Id --- --- Some of these started life as a true expression hole "_". --- Others might simply be variables that accidentally have no binding site -tcExpr (HsUnboundVar _ occ) res_ty - = 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) } - -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 - = do { expr' <- tcMonoExprNC expr res_ty - ; return (HsPar x lpar expr' rpar) } - -tcExpr (HsPragE x prag expr) res_ty - = do { expr' <- tcMonoExpr expr res_ty - ; return (HsPragE x (tcExprPrag prag) expr') } - -tcExpr (NegApp x expr neg_expr) res_ty - = do { (expr', neg_expr') - <- tcSyntaxOp NegateOrigin neg_expr [SynAny] res_ty $ - \[arg_ty] [arg_mult] -> - tcScalingUsage arg_mult $ tcCheckMonoExpr expr arg_ty - ; return (NegApp x expr' neg_expr') } - -tcExpr e@(HsIPVar _ x) res_ty - = do { ip_ty <- newFlexiTyVarTy liftedTypeKind - -- 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]) - ; 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 - -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@(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 - - - -{- -************************************************************************ -* * - Explicit lists -* * -************************************************************************ --} - --- Explicit lists [e1,e2,e3] have been expanded already in the renamer --- The expansion includes an ExplicitList, but it is always the built-in --- list type, so that's all we need concern ourselves with here. See --- GHC.Rename.Expr. Note [Handling overloaded and rebindable constructs] -tcExpr (ExplicitList _ exprs) res_ty - = do { res_ty <- expTypeToType res_ty - ; (coi, elt_ty) <- matchExpectedListTy res_ty - ; let tc_elt expr = tcCheckPolyExpr expr elt_ty - ; exprs' <- mapM tc_elt exprs - ; return $ mkHsWrapCo coi $ ExplicitList elt_ty exprs' } - -tcExpr expr@(ExplicitTuple x tup_args boxity) res_ty - | all tupArgPresent tup_args - = do { let arity = length tup_args - tup_tc = tupleTyCon boxity arity - -- NB: tupleTyCon doesn't flatten 1-tuples - -- See Note [Don't flatten tuples from HsSyn] in GHC.Core.Make - ; res_ty <- expTypeToType res_ty - ; (coi, arg_tys) <- matchExpectedTyConApp tup_tc res_ty - -- Unboxed tuples have RuntimeRep vars, which we - -- don't care about here - -- 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' - ; 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 - - ; let expr' = ExplicitTuple x tup_args1 boxity - missing_tys = [Scaled mult ty | (Missing (Scaled mult _), ty) <- zip tup_args1 arg_tys] - - -- See Note [Typechecking data constructors] in GHC.Tc.Gen.Head - -- See Note [Don't flatten tuples from HsSyn] in GHC.Core.Make - act_res_ty = mkScaledFunTys missing_tys (mkTupleTy1 boxity arg_tys) - - ; traceTc "ExplicitTuple" (ppr act_res_ty $$ ppr res_ty) - - ; tcWrapResultMono expr expr' act_res_ty res_ty } - -tcExpr (ExplicitSum _ alt arity expr) res_ty - = do { let sum_tc = sumTyCon arity - ; res_ty <- expTypeToType res_ty - ; (coi, arg_tys) <- matchExpectedTyConApp sum_tc res_ty - ; -- Drop levity vars, we don't care about them here - let arg_tys' = drop arity arg_tys - arg_ty = arg_tys' `getNth` (alt - 1) - ; expr' <- tcCheckPolyExpr expr arg_ty - -- Check the whole res_ty, not just the arg_ty, to avoid #20277. - -- Example: - -- a :: TYPE rep (representation-polymorphic) - -- (# 17# | #) :: (# Int# | a #) - -- 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 - ; return $ mkHsWrapCo coi (ExplicitSum arg_tys' alt arity expr' ) } - - -{- -************************************************************************ -* * - Let, case, if, do -* * -************************************************************************ --} - -tcExpr (HsLet x tkLet binds tkIn expr) res_ty - = do { (binds', expr') <- tcLocalBinds binds $ - tcMonoExpr expr res_ty - ; return (HsLet x tkLet binds' tkIn expr') } - -tcExpr (HsCase x 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 - -- case (map f) of - -- (x:xs) -> ... - -- will report that map is applied to too few arguments - -- - -- But now, in the GADT world, we need to typecheck the scrutinee - -- first, to get type info that may be refined in the case alternatives - mult <- newFlexiTyVarTy multiplicityTy - - -- Typecheck the scrutinee. We use tcInferRho but tcInferSigma - -- would also be possible (tcMatchesCase 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 = CaseAlt, - mc_body = tcBody } - -tcExpr (HsIf x pred b1 b2) res_ty - = do { pred' <- tcCheckMonoExpr pred boolTy - ; (u1,b1') <- tcCollectingUsage $ tcMonoExpr b1 res_ty - ; (u2,b2') <- tcCollectingUsage $ tcMonoExpr b2 res_ty - ; tcEmitBindingUsage (supUE u1 u2) - ; return (HsIf x pred' b1' b2') } - -{- -Note [MultiWayIf linearity checking] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose we'd like to compute the usage environment for - -if | b1 -> e1 - | b2 -> e2 - | otherwise -> e3 - -and let u1, u2, v1, v2, v3 denote the usage env for b1, b2, e1, e2, e3 -respectively. - -Since a multi-way if is mere sugar for nested if expressions, the usage -environment should ideally be u1 + sup(v1, u2 + sup(v2, v3)). -However, currently we don't support linear guards (#19193). All variables -used in guards from u1 and u2 will have multiplicity Many. -But in that case, we have equality u1 + sup(x,y) = sup(u1 + x, y), - and likewise u2 + sup(x,y) = sup(u2 + x, y) for any x,y. -Using this identity, we can just compute sup(u1 + v1, u2 + v2, v3) instead. -This is simple to do, since we get u_i + v_i directly from tcGRHS. -If we add linear guards, this code will have to be revisited. -Not using 'sup' caused #23814. --} - -tcExpr (HsMultiIf _ alts) res_ty - = do { (ues, alts') <- mapAndUnzipM (\alt -> tcCollectingUsage $ wrapLocMA (tcGRHS match_ctxt res_ty) alt) alts - ; 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 - -tcExpr (HsProc x pat cmd) res_ty - = do { (pat', cmd', coi) <- tcProc pat cmd res_ty - ; return $ mkHsWrapCo coi (HsProc x pat' cmd') } - --- Typechecks the static form and wraps it with a call to 'fromStaticPtr'. --- See Note [Grand plan for static forms] in GHC.Iface.Tidy.StaticPtrTable for an overview. --- To type check --- (static e) :: p a --- we want to check (e :: a), --- and wrap (static e) in a call to --- fromStaticPtr :: IsStatic p => StaticPtr a -> p a - -tcExpr (HsStatic fvs expr) res_ty - = 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 - - -- Check that the free variables of the static form are closed. - -- It's OK to use nonDetEltsUniqSet here as the only side effects of - -- checkClosedInStaticForm are error messages. - ; mapM_ checkClosedInStaticForm $ nonDetEltsUniqSet fvs - - -- Require the type of the argument to be Typeable. - ; typeableClass <- tcLookupClass typeableClassName - ; typeable_ev <- emitWantedEvVar StaticOrigin $ - mkTyConApp (classTyCon typeableClass) - [liftedTypeKind, expr_ty] - - -- Insert the constraints of the static form in a global list for later - -- validation. - ; emitStaticConstraints lie - - -- Wrap the static form with the 'fromStaticPtr' call. - ; fromStaticPtr <- newMethodFromName StaticOrigin fromStaticPtrName - [p_ty] - ; let wrap = mkWpEvVarApps [typeable_ev] <.> mkWpTyApps [expr_ty] - ; loc <- getSrcSpanM - ; static_ptr_ty_con <- tcLookupTyCon staticPtrTyConName - ; return $ mkHsWrapCo co $ HsApp noComments - (L (noAnnSrcSpan loc) $ mkHsWrap wrap fromStaticPtr) - (L (noAnnSrcSpan loc) (HsStatic (fvs, mkTyConApp static_ptr_ty_con [expr_ty]) expr')) - } - -{- -************************************************************************ -* * - Record construction and update -* * -************************************************************************ --} - -tcExpr expr@(RecordCon { rcon_con = L loc con_name - , rcon_flds = rbinds }) res_ty - = do { con_like <- tcLookupConLike con_name - - ; (con_expr, con_sigma) <- tcInferId con_name - ; (con_wrap, con_tau) <- topInstantiate orig con_sigma - -- a shallow instantiation should really be enough for - -- a data constructor. - ; let arity = conLikeArity con_like - Right (arg_tys, actual_res_ty) = tcSplitFunTysN arity con_tau - - ; 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. - - ; let rcon_tc = mkHsWrap con_wrap con_expr - expr' = RecordCon { rcon_ext = rcon_tc - , rcon_con = L loc con_like - , rcon_flds = rbinds' } - - ; ret <- tcWrapResultMono expr expr' actual_res_ty res_ty - - -- Check for missing fields. We do this after type-checking to get - -- better types in error messages (cf #18869). For example: - -- data T a = MkT { x :: a, y :: a } - -- r = MkT { y = True } - -- Then we'd like to warn about a missing field `x :: True`, rather than `x :: a0`. - -- - -- NB: to do this really properly we should delay reporting until typechecking is complete, - -- via a new `HoleSort`. But that seems too much work. - ; checkMissingFields con_like rbinds arg_tys - - ; return ret } - where - orig = OccurrenceOf con_name - --- Record updates via dot syntax are replaced by desugared 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. -tcExpr expr@(RecordUpd { rupd_expr = record_expr, rupd_flds = Left rbnds }) res_ty - = assert (notNull rbnds) $ - do { -- Desugar the record update. See Note [Record Updates]. - ; (ds_expr, ds_res_ty, err_ctxt) <- desugarRecordUpd record_expr rbnds res_ty - - -- Typecheck the desugared 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 - -- expression with the expected result type. - -- - -- See Note [Unifying result types in tcRecordUpd]. - -- Test case: T10808. - } - -tcExpr (RecordUpd {}) _ = panic "tcExpr: unexpected overloaded-dot RecordUpd" - -{- -************************************************************************ -* * - Arithmetic sequences e.g. [a,b..] - and their parallel-array counterparts e.g. [: a,b.. :] - -* * -************************************************************************ --} - -tcExpr (ArithSeq _ witness seq) res_ty - = tcArithSeq witness seq res_ty - -{- -************************************************************************ -* * - Record dot syntax -* * -************************************************************************ --} - --- These terms have been replaced by desugaring 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" - -{- -************************************************************************ -* * - Template Haskell -* * -************************************************************************ --} - --- 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@(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" - -{- -************************************************************************ -* * - Catch-all -* * -************************************************************************ --} - -tcExpr (HsOverLabel {}) ty = pprPanic "tcExpr:HsOverLabel" (ppr ty) -tcExpr (SectionL {}) ty = pprPanic "tcExpr:SectionL" (ppr ty) -tcExpr (SectionR {}) ty = pprPanic "tcExpr:SectionR" (ppr ty) - - -{- -************************************************************************ -* * - Arithmetic sequences [a..b] etc -* * -************************************************************************ --} - -tcArithSeq :: Maybe (SyntaxExpr GhcRn) -> ArithSeqInfo GhcRn -> ExpRhoType - -> TcM (HsExpr GhcTc) - -tcArithSeq witness seq@(From expr) res_ty - = do { (wrap, elt_mult, elt_ty, wit') <- arithSeqEltType witness res_ty - ; expr' <-tcScalingUsage elt_mult $ tcCheckPolyExpr expr elt_ty - ; enum_from <- newMethodFromName (ArithSeqOrigin seq) - enumFromName [elt_ty] - ; return $ mkHsWrap wrap $ - ArithSeq enum_from wit' (From expr') } - -tcArithSeq witness seq@(FromThen expr1 expr2) res_ty - = do { (wrap, elt_mult, elt_ty, wit') <- arithSeqEltType witness res_ty - ; expr1' <- tcScalingUsage elt_mult $ tcCheckPolyExpr expr1 elt_ty - ; expr2' <- tcScalingUsage elt_mult $ tcCheckPolyExpr expr2 elt_ty - ; enum_from_then <- newMethodFromName (ArithSeqOrigin seq) - enumFromThenName [elt_ty] - ; return $ mkHsWrap wrap $ - ArithSeq enum_from_then wit' (FromThen expr1' expr2') } - -tcArithSeq witness seq@(FromTo expr1 expr2) res_ty - = do { (wrap, elt_mult, elt_ty, wit') <- arithSeqEltType witness res_ty - ; expr1' <- tcScalingUsage elt_mult $ tcCheckPolyExpr expr1 elt_ty - ; expr2' <- tcScalingUsage elt_mult $ tcCheckPolyExpr expr2 elt_ty - ; enum_from_to <- newMethodFromName (ArithSeqOrigin seq) - enumFromToName [elt_ty] - ; return $ mkHsWrap wrap $ - ArithSeq enum_from_to wit' (FromTo expr1' expr2') } - -tcArithSeq witness seq@(FromThenTo expr1 expr2 expr3) res_ty - = do { (wrap, elt_mult, elt_ty, wit') <- arithSeqEltType witness res_ty - ; expr1' <- tcScalingUsage elt_mult $ tcCheckPolyExpr expr1 elt_ty - ; expr2' <- tcScalingUsage elt_mult $ tcCheckPolyExpr expr2 elt_ty - ; expr3' <- tcScalingUsage elt_mult $ tcCheckPolyExpr expr3 elt_ty - ; eft <- newMethodFromName (ArithSeqOrigin seq) - enumFromThenToName [elt_ty] - ; return $ mkHsWrap wrap $ - ArithSeq eft wit' (FromThenTo expr1' expr2' expr3') } - ------------------ -arithSeqEltType :: Maybe (SyntaxExpr GhcRn) -> ExpRhoType - -> TcM (HsWrapper, Mult, TcType, Maybe (SyntaxExpr GhcTc)) -arithSeqEltType Nothing res_ty - = do { res_ty <- expTypeToType res_ty - ; (coi, elt_ty) <- matchExpectedListTy res_ty - ; return (mkWpCastN coi, OneTy, elt_ty, Nothing) } -arithSeqEltType (Just fl) res_ty - = do { ((elt_mult, elt_ty), fl') - <- tcSyntaxOp ListOrigin fl [SynList] res_ty $ - \ [elt_ty] [elt_mult] -> return (elt_mult, elt_ty) - ; 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 - = 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)) } - go i (Present x expr) arg_ty - = do { expr' <- tcCheckPolyExpr expr arg_ty - ; hasFixedRuntimeRep_syntactic (FRRTupleArg i) arg_ty - ; return (Present x expr') } - ---------------------------- --- See TcType.SyntaxOpType also for commentary -tcSyntaxOp :: CtOrigin - -> SyntaxExprRn - -> [SyntaxOpType] -- ^ shape of syntax operator arguments - -> ExpRhoType -- ^ overall result type - -> ([TcSigmaType] -> [Mult] -> TcM a) -- ^ Type check any arguments, - -- takes a type per hole and a - -- multiplicity per arrow in - -- the shape. - -> TcM (a, SyntaxExprTc) --- ^ Typecheck a syntax operator --- The operator is a variable or a lambda at this stage (i.e. renamer --- output)t -tcSyntaxOp orig expr arg_tys res_ty - = tcSyntaxOpGen orig expr arg_tys (SynType res_ty) - --- | Slightly more general version of 'tcSyntaxOp' that allows the caller --- to specify the shape of the result of the syntax operator -tcSyntaxOpGen :: CtOrigin - -> SyntaxExprRn - -> [SyntaxOpType] - -> SyntaxOpType - -> ([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) [] - -- 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) - <- tcSynArgA orig op sigma arg_tys res_ty $ - thing_inside - ; traceTc "tcSyntaxOpGen" (ppr op $$ ppr expr $$ ppr sigma ) - ; return (result, SyntaxExprTc { syn_expr = mkHsWrap expr_wrap expr - , syn_arg_wraps = arg_wraps - , syn_res_wrap = res_wrap }) } -tcSyntaxOpGen _ NoSyntaxExprRn _ _ _ = panic "tcSyntaxOpGen" - -{- -Note [tcSynArg] -~~~~~~~~~~~~~~~ -Because of the rich structure of SyntaxOpType, we must do the -contra-/covariant thing when working down arrows, to get the -instantiation vs. skolemisation decisions correct (and, more -obviously, the orientation of the HsWrappers). We thus have -two tcSynArgs. --} - --- works on "expected" types, skolemising where necessary --- See Note [tcSynArg] -tcSynArgE :: CtOrigin - -> HsExpr GhcRn -- ^ the operator to check (for error messages only) - -> TcSigmaType - -> SyntaxOpType -- ^ shape it is expected to have - -> ([TcSigmaTypeFRR] -> [Mult] -> TcM a) -- ^ check the arguments - -> TcM (a, HsWrapper) - -- ^ 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) - ; return (result, skol_wrap <.> ty_wrapper) } - where - go rho_ty SynAny - = do { result <- thing_inside [rho_ty] [] - ; return (result, idHsWrapper) } - - go rho_ty SynRho -- same as SynAny, because we skolemise eagerly - = do { result <- thing_inside [rho_ty] [] - ; return (result, idHsWrapper) } - - go rho_ty SynList - = do { (list_co, elt_ty) <- matchExpectedListTy rho_ty - ; result <- thing_inside [elt_ty] [] - ; return (result, mkWpCastN list_co) } - - go rho_ty (SynFun arg_shape res_shape) - = do { ( match_wrapper -- :: (arg_ty -> res_ty) "->" rho_ty - , ( ( (result, arg_ty, res_ty, op_mult) - , 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 -> - do { arg_tc_ty <- expTypeToType (scaledThing arg_ty) - ; res_tc_ty <- expTypeToType res_ty - - -- another nested arrow is too much for now, - -- but I bet we'll never need this - ; massertPpr (case arg_shape of - SynFun {} -> False; - _ -> True) - (text "Too many nested arrows in SyntaxOpType" $$ - pprCtOrigin orig) - - ; let arg_mult = scaledMult arg_ty - ; tcSynArgA orig op arg_tc_ty [] arg_shape $ - \ arg_results arg_res_mults -> - tcSynArgE orig op res_tc_ty res_shape $ - \ res_results res_res_mults -> - do { result <- thing_inside (arg_results ++ res_results) ([arg_mult] ++ arg_res_mults ++ res_res_mults) - ; return (result, arg_tc_ty, res_tc_ty, arg_mult) }} - - ; let fun_wrap = mkWpFun (arg_wrapper2 <.> arg_wrapper1) res_wrapper - (Scaled op_mult arg_ty) res_ty - -- NB: arg_ty comes from matchExpectedFunTys, so it has a - -- fixed RuntimeRep, as needed to call mkWpFun. - ; return (result, match_wrapper <.> fun_wrap) } - where - herald = ExpectedFunTySyntaxOp orig op - - go rho_ty (SynType the_ty) - = do { wrap <- tcSubTypePat orig GenSigCtxt the_ty rho_ty - ; result <- thing_inside [] [] - ; return (result, wrap) } - --- works on "actual" types, instantiating where necessary --- See Note [tcSynArg] -tcSynArgA :: CtOrigin - -> HsExpr GhcRn -- ^ the operator we are checking (for error messages) - -> TcSigmaType - -> [SyntaxOpType] -- ^ argument shapes - -> SyntaxOpType -- ^ result shape - -> ([TcSigmaTypeFRR] -> [Mult] -> TcM a) -- ^ check the arguments - -> TcM (a, HsWrapper, [HsWrapper], HsWrapper) - -- ^ returns a wrapper to be applied to the original function, - -- wrappers to be applied to arguments - -- 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 - -- 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 -> - tc_syn_arg res_ty res_shape $ \ res_results -> - thing_inside (arg_results ++ res_results) (map scaledMult arg_tys ++ arg_res_mults) - ; return (result, match_wrapper, arg_wrappers, res_wrapper) } - where - herald = ExpectedFunTySyntaxOp orig op - - tc_syn_args_e :: [TcSigmaTypeFRR] -> [SyntaxOpType] - -> ([TcSigmaTypeFRR] -> [Mult] -> TcM a) - -> TcM (a, [HsWrapper]) - -- the wrappers are for arguments - tc_syn_args_e (arg_ty : arg_tys) (arg_shape : arg_shapes) thing_inside - = do { ((result, arg_wraps), arg_wrap) - <- tcSynArgE orig op arg_ty arg_shape $ \ arg1_results arg1_mults -> - tc_syn_args_e arg_tys arg_shapes $ \ args_results args_mults -> - thing_inside (arg1_results ++ args_results) (arg1_mults ++ args_mults) - ; return (result, arg_wrap : arg_wraps) } - tc_syn_args_e _ _ thing_inside = (, []) <$> thing_inside [] [] - - tc_syn_arg :: TcSigmaTypeFRR -> SyntaxOpType - -> ([TcSigmaTypeFRR] -> TcM a) - -> TcM (a, HsWrapper) - -- the wrapper applies to the overall result - tc_syn_arg res_ty SynAny thing_inside - = do { result <- thing_inside [res_ty] - ; return (result, idHsWrapper) } - tc_syn_arg res_ty SynRho thing_inside - = do { (inst_wrap, rho_ty) <- topInstantiate orig res_ty - -- inst_wrap :: res_ty "->" rho_ty - ; result <- thing_inside [rho_ty] - ; return (result, inst_wrap) } - tc_syn_arg res_ty SynList thing_inside - = do { (inst_wrap, rho_ty) <- topInstantiate orig res_ty - -- inst_wrap :: res_ty "->" rho_ty - ; (list_co, elt_ty) <- matchExpectedListTy rho_ty - -- list_co :: [elt_ty] ~N rho_ty - ; result <- thing_inside [elt_ty] - ; return (result, mkWpCastN (mkSymCo list_co) <.> inst_wrap) } - 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 - ; result <- thing_inside [] - ; return (result, wrap) } - -{- -Note [Push result type in] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -Unify with expected result before type-checking the args so that the -info from res_ty percolates to args. This is when we might detect a -too-few args situation. (One can think of cases when the opposite -order would give a better error message.) -experimenting with putting this first. - -Here's an example where it actually makes a real difference - - class C t a b | t a -> b - instance C Char a Bool - - data P t a = forall b. (C t a b) => MkP b - data Q t = MkQ (forall a. P t a) - - f1, f2 :: Q Char; - f1 = MkQ (MkP True) - f2 = MkQ (MkP True :: forall a. P Char a) - -With the change, f1 will type-check, because the 'Char' info from -the signature is propagated into MkQ's argument. With the check -in the other order, the extra signature in f2 is reqd. --} - -{- ********************************************************************* -* * - Desugaring record update -* * -********************************************************************* -} - -{- -Note [Type of a record update] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The main complication with RecordUpd is that we need to explicitly -handle the *non-updated* fields. Consider: - - data T a b c = MkT1 { fa :: a, fb :: (b,c) } - | MkT2 { fa :: a, fb :: (b,c), fc :: c -> c } - | MkT3 { fd :: a } - - upd :: T a b c -> (b',c) -> T a b' c - upd t x = t { fb = x} - -The result type should be (T a b' c) -not (T a b c), because 'b' *is not* mentioned in a non-updated field -not (T a b' c'), because 'c' *is* mentioned in a non-updated field -NB that it's not good enough to look at just one constructor; we must -look at them all; cf #3219 - -After all, upd should be equivalent to: - upd t x = case t of - MkT1 p q -> MkT1 p x - MkT2 a b -> MkT2 p b - MkT3 d -> error ... - -So we need to give a completely fresh type to the result record, -and then constrain it by the fields that are *not* updated ("p" above). -We call these the "fixed" type variables, and compute them in getFixedTyVars. - -Note that because MkT3 doesn't contain all the fields being updated, -its RHS is simply an error, so it doesn't impose any type constraints. -Hence the use of 'relevant_cont'. - -Note [Implicit type sharing] -~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We also take into account any "implicit" non-update fields. For example - data T a b where { MkT { f::a } :: T a a; ... } -So the "real" type of MkT is: forall ab. (a~b) => a -> T a b - -Then consider - upd t x = t { f=x } -We infer the type - upd :: T a b -> a -> T a b - upd (t::T a b) (x::a) - = case t of { MkT (co:a~b) (_:a) -> MkT co x } -We can't give it the more general type - upd :: T a b -> c -> T c b - -Note [Criteria for update] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -We want to allow update for existentials etc, provided the updated -field isn't part of the existential. For example, this should be ok. - data T a where { MkT { f1::a, f2::b->b } :: T a } - f :: T a -> b -> T b - f t b = t { f1=b } - -The criterion we use is this: - - The types of the updated fields - mention only the universally-quantified type variables - of the data constructor - -NB: this is not (quite) the same as being a "naughty" record selector -(See Note [Naughty record selectors]) in GHC.Tc.TyCl), at least -in the case of GADTs. Consider - data T a where { MkT :: { f :: a } :: T [a] } -Then f is not "naughty" because it has a well-typed record selector. -But we don't allow updates for 'f'. (One could consider trying to -allow this, but it makes my head hurt. Badly. And no one has asked -for it.) - -In principle one could go further, and allow - g :: T a -> T a - g t = t { f2 = \x -> x } -because the expression is polymorphic...but that seems a bridge too far. - -Note [Data family example] -~~~~~~~~~~~~~~~~~~~~~~~~~~ - data instance T (a,b) = MkT { x::a, y::b } - ---> - data :TP a b = MkT { a::a, y::b } - coTP a b :: T (a,b) ~ :TP a b - -Suppose r :: T (t1,t2), e :: t3 -Then r { x=e } :: T (t3,t1) - ---> - case r |> co1 of - MkT x y -> MkT e y |> co2 - where co1 :: T (t1,t2) ~ :TP t1 t2 - co2 :: :TP t3 t2 ~ T (t3,t2) -The wrapping with co2 is done by the constructor wrapper for MkT - -Outgoing invariants -~~~~~~~~~~~~~~~~~~~ -In the outgoing (HsRecordUpd scrut binds cons in_inst_tys out_inst_tys): - - * cons are the data constructors to be updated - - * in_inst_tys, out_inst_tys have same length, and instantiate the - *representation* tycon of the data cons. In Note [Data - family example], in_inst_tys = [t1,t2], out_inst_tys = [t3,t2] - -Note [Mixed Record Field Updates] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider the following pattern synonym. - - data MyRec = MyRec { foo :: Int, qux :: String } - - pattern HisRec{f1, f2} = MyRec{foo = f1, qux=f2} - -This allows updates such as the following - - updater :: MyRec -> MyRec - updater a = a {f1 = 1 } - -It would also make sense to allow the following update (which we reject). - - updater a = a {f1 = 1, qux = "two" } ==? MyRec 1 "two" - -This leads to confusing behaviour when the selectors in fact refer the same -field. - - updater a = a {f1 = 1, foo = 2} ==? ??? - -For this reason, we reject a mixture of pattern synonym and normal record -selectors in the same update block. Although of course we still allow the -following. - - updater a = (a {f1 = 1}) {foo = 2} - - > updater (MyRec 0 "str") - MyRec 2 "str" - -Note [Record Updates] -~~~~~~~~~~~~~~~~~~~~~ -To typecheck a record update, we desugar 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 - - e { x=e1, y=e2 } - ===> - let { x' = e1; y' = e2 } in - case e of - 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. - -Wrinkle [Disambiguating fields] -As outlined above, to typecheck a record update via desugaring, we first need -to identify the parent record `TyCon` (`T` above). This can be tricky when several -record types share the same field (with `-XDuplicateRecordFields`). - -Currently, we use the inferred type of the record to help disambiguate the record -fields. For example, in - - ( mempty :: T a b ) { x = 3 } - -the type signature on `mempty` allows us to disambiguate the record `TyCon` to `T`, -when there might be other datatypes with field `x :: Int`. -This complexity is scheduled for removal via the implementation of GHC proposal #366 -https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0366-no-ambiguous-field-access.rst - -However, for the time being, we still need to disambiguate record fields using the -inferred types. This means that, when typechecking a record update via desugaring, -we need to do the following: - - D1. Perform a first typechecking pass on the record expression (`e` in the example above), - to infer the type of the record being updated. - D2. Desugar the record update as described above, using an HsExpansion. - D3. Typecheck the desugared code. - -In (D1), 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) -and a collection of residual constraints. -We have no need for the latter two, because we will typecheck again in (D3). So, for -the time being (and until GHC proposal #366 is implemented), we simply drop them. - -Wrinkle [Using IdSig] -As noted above, we want to let-bind the updated fields to avoid code duplication: - - let { x' = e1; y' = e2 } in - case e of - T1 _ _ z -> T1 x' y' z - T4 p _ _ -> T4 p y' x' - -However, doing so in a naive way would cause difficulties for type inference. -For example: - - 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: - - ds_foo r = - let f' = \ k -> (k 3, k 'x') - in case r of - MkR _ b -> MkR f' b - -then we are unable to infer an appropriately polymorphic type for f', because we -never infer higher-rank types. To circumvent this problem, we proceed as follows: - - 1. Obtain general field types by instantiating any of the constructors - that contain all the necessary fields. (Note that the field type must be - identical across different constructors of a given data constructor). - 2. Let-bind an 'IdSig' with this type. This amounts to giving the let-bound - 'Id's a partial type signature. - -In the above example, it's as if we wrote: - - ds_foo r = - let f' :: (forall a. a -> a) -> (Int, _b) - f' = \ k -> (k 3, k 'x') - in case r of - MkR _ b -> MkR f' b - -This allows us to compute the right type for f', and thus accept this record update. - -Note [Unifying result types in tcRecordUpd] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -After desugaring and typechecking a record update in the way described in -Note [Record Updates], we must take care to unify the result types. - -Example: - - type family F (a :: Type) :: Type where {} - data D a = MkD { fld :: F a } - - f :: F Int -> D Bool -> D Int - f i r = r { fld = i } - -This record update desugars to: - - let x :: F alpha -- metavariable - x = i - in case r of - MkD _ -> MkD x - -Because the type family F is not injective, our only hope for unifying the -metavariable alpha is through the result type of the record update, which tells -us that we should unify alpha := Int. - -Test case: T10808. - -Wrinkle [GADT result type in tcRecordUpd] - - When dealing with a GADT, we want to be careful about which result type we use. - - Example: - - data G a b where - MkG :: { bar :: F a } -> G a Int - - g :: F Int -> G Float b -> G Int b - g i r = r { bar = i } - - We **do not** want to use the result type from the constructor MkG, which would - leave us with a result type "G alpha Int". Instead, we should use the result type - from the GADT header, instantiating as above, to get "G alpha beta" which will get - unified withy "G Int b". - - Test cases: T18809, HardRecordUpdate. - --} - --- | Desugars 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 - -- ^ @record_expr@: expression to which the record update is applied - -> [LHsRecUpdField GhcRn] - -- ^ the record update fields - -> ExpRhoType - -- ^ the expected result type of the record update - -> TcM ( HsExpr GhcRn - -- desugared record update expression - , TcType - -- result type of desugared record update - , SDoc - -- error context to push when typechecking - -- the desugared code - ) -desugarRecordUpd record_expr rbnds res_ty - = do { -- STEP -2: 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] - -- in Note [Record Updates]. - ; ((_, record_rho), _lie) <- captureConstraints $ -- see (1) below - tcScalingUsage ManyTy $ -- see (2) below - tcInferRho record_expr - - -- (1) - -- 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`, - -- and typecheck it from scratch. We don't want to generate the constraints twice! - - -- (2) - -- Record update drops some of the content of the record (namely the - -- content of the field being updated). As a consequence, unless the - -- field being updated is unrestricted in the record, we need an - -- unrestricted record. Currently, we simply always require an - -- unrestricted record. - -- - -- Consider the following example: - -- - -- data R a = R { self :: a } - -- bad :: a ⊸ () - -- bad x = let r = R x in case r { self = () } of { R x' -> x' } - -- - -- This should definitely *not* typecheck. - - -- STEP -1 See Note [Disambiguating record fields] in GHC.Tc.Gen.Head - -- After this we know that rbinds is unambiguous - ; rbinds <- disambiguateRecordBinds record_expr record_rho rbnds res_ty - ; let upd_flds = map (unLoc . hfbLHS . unLoc) rbinds - upd_fld_occs = map (FieldLabelString . occNameFS . rdrNameOcc . rdrNameAmbiguousFieldOcc) upd_flds - sel_ids = map selectorAmbiguousFieldOcc upd_flds - upd_fld_names = map idName sel_ids - - -- STEP 0 - -- Check that the field names are really field names - -- and they are all field names for proper records or - -- all field names for pattern synonyms. - ; let bad_guys = [ setSrcSpan loc $ addErrTc (notSelector fld_name) - | fld <- rbinds, - -- Excludes class ops - let L loc sel_id = hsRecUpdFieldId (unLoc fld), - not (isRecordSelector sel_id), - let fld_name = idName sel_id ] - ; unless (null bad_guys) (sequence bad_guys >> failM) - -- See Note [Mixed Record Field Updates] - ; let (data_sels, pat_syn_sels) = - partition isDataConRecordSelector sel_ids - ; massert (all isPatSynRecordSelector pat_syn_sels) - ; checkTc ( null data_sels || null pat_syn_sels ) - ( mixedSelectors data_sels pat_syn_sels ) - - -- STEP 1 - -- Figure out the tycon and data cons from the first field name - ; let -- It's OK to use the non-tc splitters here (for a selector) - sel_id : _ = sel_ids - con_likes :: [ConLike] - con_likes = case idDetails sel_id of - RecSelId (RecSelData tc) _ - -> map RealDataCon (tyConDataCons tc) - RecSelId (RecSelPatSyn ps) _ - -> [PatSynCon ps] - _ -> panic "tcRecordUpd" - -- NB: for a data type family, the tycon is the instance tycon - relevant_cons = conLikesWithFields con_likes upd_fld_occs - -- A constructor is only relevant to this process if - -- it contains *all* the fields that are being updated - -- Other ones will cause a runtime error if they occur - - -- STEP 2 - -- Check that at least one constructor has all the named fields - -- i.e. has an empty set of bad fields returned by badFields - ; case relevant_cons of - { [] -> failWithTc (badFieldsUpd rbinds con_likes) - ; relevant_con : _ -> - - -- STEP 3 - -- Create new variables for the fields we are updating, - -- so that we can share them across constructors. - -- - -- Example: - -- - -- e { x=e1, y=e2 } - -- - -- We want to let-bind variables to `e1` and `e2`: - -- - -- let x' :: Int - -- x' = e1 - -- y' :: Bool - -- y' = e2 - -- in ... - - do { -- Instantiate the type variables of any relevant constuctor - -- with metavariables to obtain a type for each 'Id'. - -- This will allow us to have 'Id's with polymorphic types - -- by using 'IdSig'. See Wrinkle [Using IdSig] in Note [Record Updates]. - ; let (univ_tvs, ex_tvs, eq_spec, _, _, arg_tys, con_res_ty) = conLikeFullSig relevant_con - ; (subst, tc_tvs) <- newMetaTyVars (univ_tvs ++ ex_tvs) - ; let (actual_univ_tys, _actual_ex_tys) = splitAtList univ_tvs $ map mkTyVarTy tc_tvs - - -- See Wrinkle [GADT result type in tcRecordUpd] - -- for an explanation of the following. - ds_res_ty = case relevant_con of - RealDataCon con - | not (null eq_spec) -- We only need to do this if we have actual GADT equalities. - -> mkFamilyTyConApp (dataConTyCon con) actual_univ_tys - _ -> substTy subst con_res_ty - - -- Gather pairs of let-bound Ids and their right-hand sides, - -- e.g. (x', e1), (y', e2), ... - ; let mk_upd_id :: Name -> LHsFieldBind GhcTc fld (LHsExpr GhcRn) -> TcM (Name, (TcId, LHsExpr GhcRn)) - mk_upd_id fld_nm (L _ rbind) - = do { let Scaled m arg_ty = lookupNameEnv_NF arg_ty_env fld_nm - nm_occ = rdrNameOcc . nameRdrName $ fld_nm - actual_arg_ty = substTy subst arg_ty - rhs = hfbRHS rbind - ; (_co, actual_arg_ty) <- hasFixedRuntimeRep (FRRRecordUpdate fld_nm (unLoc rhs)) actual_arg_ty - -- We get a better error message by doing a (redundant) representation-polymorphism check here, - -- rather than delaying until the typechecker typechecks the let-bindings, - -- because the let-bound Ids have internal names. - -- (As we will typecheck the let-bindings later, we can drop this coercion here.) - -- See RepPolyRecordUpdate test. - ; nm <- newNameAt nm_occ generatedSrcSpan - ; let id = mkLocalId nm m actual_arg_ty - -- NB: create fresh names to avoid any accidental shadowing - -- occurring in the RHS expressions when creating the let bindings: - -- - -- let x1 = e1; x2 = e2; ... - ; return (fld_nm, (id, rhs)) - } - arg_ty_env = mkNameEnv - $ zipWith (\ lbl arg_ty -> (flSelector lbl, arg_ty)) - (conLikeFieldLabels relevant_con) - arg_tys - - ; upd_ids <- zipWithM mk_upd_id upd_fld_names rbinds - ; let updEnv :: UniqMap Name (Id, LHsExpr GhcRn) - updEnv = listToUniqMap $ upd_ids - - make_pat :: ConLike -> LMatch GhcRn (LHsExpr GhcRn) - -- As explained in Note [Record Updates], to desugar - -- - -- e { x=e1, y=e2 } - -- - -- we generate a case statement, with an equation for - -- each constructor of the record. For example, for - -- the constructor - -- - -- T1 :: { x :: Int, y :: Bool, z :: Char } -> T p q - -- - -- we let-bind x' = e1, y' = e2 and generate the equation: - -- - -- T1 _ _ z -> T1 x' y' z - make_pat conLike = mkSimpleMatch CaseAlt [pat] rhs - where - (lhs_con_pats, rhs_con_args) - = zipWithAndUnzip mk_con_arg [1..] con_fields - pat = genSimpleConPat con lhs_con_pats - rhs = wrapGenSpan $ genHsApps con rhs_con_args - con = conLikeName conLike - con_fields = conLikeFieldLabels conLike - - mk_con_arg :: Int - -> FieldLabel - -> ( LPat GhcRn - -- LHS constructor pattern argument - , LHsExpr GhcRn ) - -- RHS constructor argument - mk_con_arg i fld_lbl = - -- The following generates the pattern matches of the desugared `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 - -- Field is being updated: LHS = wildcard pattern, RHS = appropriate let-bound Id. - Just (upd_id, _) -> (genWildPat, genLHsVar (idName upd_id)) - -- Field is not being updated: LHS = variable pattern, RHS = that same variable. - _ -> let fld_nm = mkInternalName (mkBuiltinUnique i) - (mkVarOccFS (field_label $ flLabel fld_lbl)) - generatedSrcSpan - in (genVarPat fld_nm, genLHsVar fld_nm) - - -- STEP 4 - -- Desugar to HsCase, as per note [Record Updates] - ; let ds_expr :: HsExpr GhcRn - ds_expr = HsLet noExtField noHsTok let_binds noHsTok (L gen case_expr) - - case_expr :: HsExpr GhcRn - case_expr = HsCase noExtField record_expr (mkMatchGroup Generated (wrapGenSpan matches)) - matches :: [LMatch GhcRn (LHsExpr GhcRn)] - matches = map make_pat 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) - | (_, (id, rhs)) <- upd_ids ] - mk_idSig :: (Name, (Id, LHsExpr GhcRn)) -> LSig GhcRn - mk_idSig (_, (id, _)) = L gen $ XSig $ IdSig id - -- We let-bind variables using 'IdSig' in order to accept - -- record updates involving higher-rank types. - -- See Wrinkle [Using IdSig] in Note [Record Updates]. - gen = noAnnSrcSpan generatedSrcSpan - - ; traceTc "desugarRecordUpd" $ - vcat [ text "relevant_con:" <+> ppr relevant_con - , text "res_ty:" <+> ppr res_ty - , text "ds_res_ty:" <+> ppr ds_res_ty - ] - - ; 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, 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 - -{- ********************************************************************* -* * - Record bindings -* * -********************************************************************* -} - --- Disambiguate the fields in a record update. --- See Note [Disambiguating record fields] in GHC.Tc.Gen.Head -disambiguateRecordBinds :: LHsExpr GhcRn -> TcRhoType - -> [LHsRecUpdField GhcRn] -> ExpRhoType - -> TcM [LHsFieldBind GhcTc (LAmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)] -disambiguateRecordBinds record_expr record_rho rbnds res_ty - -- Are all the fields unambiguous? - = case mapM isUnambiguous rbnds of - -- If so, just skip to looking up the Ids - -- Always the case if DuplicateRecordFields is off - Just rbnds' -> mapM lookupSelector rbnds' - Nothing -> -- If not, try to identify a single parent - do { fam_inst_envs <- tcGetFamInstEnvs - -- Look up the possible parents for each field - ; rbnds_with_parents <- getUpdFieldsParents - ; let possible_parents = map (map fst . snd) rbnds_with_parents - -- Identify a single parent - ; p <- identifyParent fam_inst_envs possible_parents - -- Pick the right selector with that parent for each field - ; checkNoErrs $ mapM (pickParent p) rbnds_with_parents } - where - -- Extract the selector name of a field update if it is unambiguous - isUnambiguous :: LHsRecUpdField GhcRn -> Maybe (LHsRecUpdField GhcRn,Name) - isUnambiguous x = case unLoc (hfbLHS (unLoc x)) of - Unambiguous sel_name _ -> Just (x, sel_name) - Ambiguous{} -> Nothing - - -- Look up the possible parents and selector GREs for each field - getUpdFieldsParents :: TcM [(LHsRecUpdField GhcRn - , [(RecSelParent, GlobalRdrElt)])] - getUpdFieldsParents - = fmap (zip rbnds) $ mapM - (lookupParents False . unLoc . hsRecUpdFieldRdr . unLoc) - rbnds - - -- Given a the lists of possible parents for each field, - -- identify a single parent - identifyParent :: FamInstEnvs -> [[RecSelParent]] -> TcM RecSelParent - identifyParent fam_inst_envs possible_parents - = case foldr1 intersect possible_parents of - -- No parents for all fields: record update is ill-typed - [] -> failWithTc (TcRnNoPossibleParentForFields rbnds) - - -- Exactly one datatype with all the fields: use that - [p] -> return p - - -- Multiple possible parents: try harder to disambiguate - -- Can we get a parent TyCon from the pushed-in type? - _:_ | Just p <- tyConOfET fam_inst_envs res_ty -> - do { reportAmbiguousField p - ; return (RecSelData p) } - - -- Does the expression being updated have a type signature? - -- If so, try to extract a parent TyCon from it - | Just {} <- obviousSig (unLoc record_expr) - , Just tc <- tyConOf fam_inst_envs record_rho - -> do { reportAmbiguousField tc - ; return (RecSelData tc) } - - -- Nothing else we can try... - _ -> failWithTc (TcRnBadOverloadedRecordUpdate rbnds) - - -- Make a field unambiguous by choosing the given parent. - -- Emits an error if the field cannot have that parent, - -- e.g. if the user writes - -- r { x = e } :: T - -- where T does not have field x. - pickParent :: RecSelParent - -> (LHsRecUpdField GhcRn, [(RecSelParent, GlobalRdrElt)]) - -> TcM (LHsFieldBind GhcTc (LAmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)) - pickParent p (upd, xs) - = case lookup p xs of - -- Phew! The parent is valid for this field. - -- Previously ambiguous fields must be marked as - -- used now that we know which one is meant, but - -- unambiguous ones shouldn't be recorded again - -- (giving duplicate deprecation warnings). - Just gre -> do { unless (null (tail xs)) $ do - let L loc _ = hfbLHS (unLoc upd) - setSrcSpanA loc $ addUsedGRE True gre - ; lookupSelector (upd, greMangledName gre) } - -- The field doesn't belong to this parent, so report - -- an error but keep going through all the fields - Nothing -> do { addErrTc (fieldNotInType p - (unLoc (hsRecUpdFieldRdr (unLoc upd)))) - ; lookupSelector (upd, greMangledName (snd (head xs))) } - - -- Given a (field update, selector name) pair, look up the - -- selector to give a field update with an unambiguous Id - lookupSelector :: (LHsRecUpdField GhcRn, Name) - -> TcM (LHsFieldBind GhcRn (LAmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)) - lookupSelector (L l upd, n) - = do { i <- tcLookupId n - ; let L loc af = hfbLHS upd - lbl = rdrNameAmbiguousFieldOcc af - ; return $ L l HsFieldBind - { hfbAnn = hfbAnn upd - , hfbLHS - = L (l2l loc) (Unambiguous i (L (l2l loc) lbl)) - , hfbRHS = hfbRHS upd - , hfbPun = hfbPun upd - } - } - - -- See Note [Deprecating ambiguous fields] in GHC.Tc.Gen.Head - reportAmbiguousField :: TyCon -> TcM () - reportAmbiguousField parent_type = - setSrcSpan loc $ addDiagnostic $ TcRnAmbiguousField rupd parent_type - where - rupd = RecordUpd { rupd_expr = record_expr, rupd_flds = Left rbnds, rupd_ext = noExtField } - loc = getLocA (head rbnds) - -{- -Game plan for record bindings -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -1. Find the TyCon for the bindings, from the first field label. - -2. Instantiate its tyvars and unify (T a1 .. an) with expected_ty. - -For each binding field = value - -3. Instantiate the field type (from the field label) using the type - envt from step 2. - -4 Type check the value using tcCheckPolyExprNC (in tcRecordField), - passing the field type as the expected argument type. - -This extends OK when the field types are universally quantified. --} - -tcRecordBinds - :: ConLike - -> [TcType] -- Expected type for each field - -> HsRecordBinds GhcRn - -> TcM (HsRecordBinds GhcTc) - -tcRecordBinds con_like arg_tys (HsRecFields rbinds dd) - = do { mb_binds <- mapM do_bind rbinds - ; return (HsRecFields (catMaybes mb_binds) dd) } - where - fields = map flSelector $ conLikeFieldLabels con_like - flds_w_tys = zipEqual "tcRecordBinds" fields arg_tys - - do_bind :: LHsRecField GhcRn (LHsExpr GhcRn) - -> TcM (Maybe (LHsRecField GhcTc (LHsExpr GhcTc))) - do_bind (L l fld@(HsFieldBind { hfbLHS = f - , hfbRHS = rhs })) - - = do { mb <- tcRecordField con_like flds_w_tys f rhs - ; case mb of - Nothing -> return Nothing - -- Just (f', rhs') -> return (Just (L l (fld { hfbLHS = f' - -- , hfbRHS = rhs' }))) } - Just (f', rhs') -> return (Just (L l (HsFieldBind - { hfbAnn = hfbAnn fld - , hfbLHS = f' - , hfbRHS = rhs' - , hfbPun = hfbPun fld}))) } - - -tcRecordField :: ConLike -> Assoc Name Type - -> LFieldOcc GhcRn -> LHsExpr GhcRn - -> TcM (Maybe (LFieldOcc GhcTc, LHsExpr GhcTc)) -tcRecordField con_like flds_w_tys (L loc (FieldOcc sel_name lbl)) rhs - | 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')) - field_ty - ; let field_id = mkUserLocal (nameOccName sel_name) - (nameUnique sel_name) - ManyTy 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')) } - | otherwise - = do { addErrTc (badFieldConErr (getName con_like) field_lbl) - ; return Nothing } - where - field_lbl = FieldLabelString $ occNameFS $ rdrNameOcc (unLoc lbl) - - -checkMissingFields :: ConLike -> HsRecordBinds GhcRn -> [Scaled TcType] -> TcM () -checkMissingFields con_like rbinds arg_tys - | null field_labels -- Not declared as a record; - -- But C{} is still valid if no strict fields - = if any isBanged field_strs then - -- Illegal if any arg is strict - addErrTc (TcRnMissingStrictFields con_like []) - else do - when (notNull field_strs && null field_labels) $ do - let msg = TcRnMissingFields con_like [] - (diagnosticTc True msg) - - | otherwise = do -- A record - unless (null missing_s_fields) $ do - fs <- zonk_fields missing_s_fields - -- It is an error to omit a strict field, because - -- we can't substitute it with (error "Missing field f") - addErrTc (TcRnMissingStrictFields con_like fs) - - warn <- woptM Opt_WarnMissingFields - when (warn && notNull missing_ns_fields) $ do - fs <- zonk_fields missing_ns_fields - -- It is not an error (though we may want) to omit a - -- lazy field, because we can always use - -- (error "Missing field f") instead. - let msg = TcRnMissingFields con_like fs - diagnosticTc True msg - - where - -- we zonk the fields to get better types in error messages (#18869) - zonk_fields fs = forM fs $ \(str,ty) -> do - ty' <- zonkTcType ty - return (str,ty') - missing_s_fields - = [ (flLabel fl, scaledThing ty) | (fl,str,ty) <- field_info, - isBanged str, - not (fl `elemField` field_names_used) - ] - missing_ns_fields - = [ (flLabel fl, scaledThing ty) | (fl,str,ty) <- field_info, - not (isBanged str), - not (fl `elemField` field_names_used) - ] - - field_names_used = hsRecFields rbinds - field_labels = conLikeFieldLabels con_like - - field_info = zip3 field_labels field_strs arg_tys - - field_strs = conLikeImplBangs con_like - - fl `elemField` flds = any (\ fl' -> flSelector fl == fl') flds - -{- -************************************************************************ -* * -\subsection{Errors and contexts} -* * -************************************************************************ - -Boring and alphabetical: --} - -fieldCtxt :: FieldLabelString -> SDoc -fieldCtxt field_name - = text "In the" <+> quotes (ppr field_name) <+> text "field of a record" - -badFieldsUpd - :: [LHsFieldBind GhcTc (LAmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)] - -- Field names that don't belong to a single datacon - -> [ConLike] -- Data cons of the type which the first field name belongs to - -> TcRnMessage -badFieldsUpd rbinds data_cons - = TcRnNoConstructorHasAllFields conflictingFields - -- See Note [Finding the conflicting fields] - where - -- A (preferably small) set of fields such that no constructor contains - -- all of them. See Note [Finding the conflicting fields] - conflictingFields = case nonMembers of - -- nonMember belongs to a different type. - (nonMember, _) : _ -> [aMember, nonMember] - [] -> let - -- All of rbinds belong to one type. In this case, repeatedly add - -- a field to the set until no constructor contains the set. - - -- Each field, together with a list indicating which constructors - -- have all the fields so far. - growingSets :: [(FieldLabelString, [Bool])] - growingSets = scanl1 combine membership - combine (_, setMem) (field, fldMem) - = (field, zipWith (&&) setMem fldMem) - in - -- Fields that don't change the membership status of the set - -- are redundant and can be dropped. - map (fst . NE.head) $ NE.groupWith snd growingSets - - aMember = assert (not (null members) ) fst (head members) - (members, nonMembers) = partition (or . snd) membership - - -- For each field, which constructors contain the field? - membership :: [(FieldLabelString, [Bool])] - membership = sortMembership $ - map (\fld -> (fld, map (fld `elementOfUniqSet`) fieldLabelSets)) $ - map (FieldLabelString . occNameFS . rdrNameOcc . rdrNameAmbiguousFieldOcc . unLoc . hfbLHS . unLoc) rbinds - - fieldLabelSets :: [UniqSet FieldLabelString] - fieldLabelSets = map (mkUniqSet . map flLabel . conLikeFieldLabels) data_cons - - -- Sort in order of increasing number of True, so that a smaller - -- conflicting set can be found. - sortMembership = - map snd . - sortBy (compare `on` fst) . - map (\ item@(_, membershipRow) -> (countTrue membershipRow, item)) - - countTrue = count id - -{- -Note [Finding the conflicting fields] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose we have - data A = A {a0, a1 :: Int} - | B {b0, b1 :: Int} -and we see a record update - x { a0 = 3, a1 = 2, b0 = 4, b1 = 5 } -Then we'd like to find the smallest subset of fields that no -constructor has all of. Here, say, {a0,b0}, or {a0,b1}, etc. -We don't really want to report that no constructor has all of -{a0,a1,b0,b1}, because when there are hundreds of fields it's -hard to see what was really wrong. - -We may need more than two fields, though; eg - data T = A { x,y :: Int, v::Int } - | B { y,z :: Int, v::Int } - | C { z,x :: Int, v::Int } -with update - r { x=e1, y=e2, z=e3 }, we - -Finding the smallest subset is hard, so the code here makes -a decent stab, no more. See #7989. --} - -mixedSelectors :: [Id] -> [Id] -> TcRnMessage -mixedSelectors data_sels@(dc_rep_id:_) pat_syn_sels@(ps_rep_id:_) - = TcRnMixedSelectors (tyConName rep_dc) data_sels (patSynName rep_ps) pat_syn_sels - where - RecSelPatSyn rep_ps = recordSelectorTyCon ps_rep_id - RecSelData rep_dc = recordSelectorTyCon dc_rep_id -mixedSelectors _ _ = panic "GHC.Tc.Gen.Expr: mixedSelectors emptylists" + tcInferExpr, tcInferSigma, tcInferRho, tcInferRhoNC, + tcPolyLExpr, tcPolyExpr, tcExpr, tcPolyLExprSig, + tcSyntaxOp, tcSyntaxOpGen, SyntaxOpType(..), synKnownType, + tcCheckId, + ) where + +import GHC.Prelude + +import Language.Haskell.Syntax.Basic (FieldLabelString(..)) + +import {-# SOURCE #-} GHC.Tc.Gen.Splice + ( tcTypedSplice, tcTypedBracket, tcUntypedBracket, getUntypedSpliceBody ) + +import GHC.Hs +import GHC.Hs.Syn.Type + +import GHC.Rename.Utils +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.Gen.HsType +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.Utils.TcMType +import GHC.Tc.Utils.TcType as TcType +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.Types.SrcLoc + +import GHC.Builtin.Types +import GHC.Builtin.Names +import GHC.Builtin.Uniques ( mkBuiltinUnique ) + +import GHC.Driver.DynFlags + +import GHC.Utils.Misc +import GHC.Utils.Outputable as Outputable +import GHC.Utils.Panic + +import GHC.Data.List.SetOps +import GHC.Data.Maybe + +import Control.Monad +import qualified Data.List.NonEmpty as NE + +{- +************************************************************************ +* * +\subsection{Main wrappers} +* * +************************************************************************ +-} + +tcCheckPolyExpr, tcCheckPolyExprNC + :: LHsExpr GhcRn -- Expression to type check + -> TcSigmaType -- Expected type (could be a polytype) + -> TcM (LHsExpr GhcTc) -- Generalised expr with expected type + +-- tcCheckPolyExpr is a convenient place (frequent but not too frequent) +-- place to add context information. +-- The NC version does not do so, usually because the caller wants +-- to do so themselves. + +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 + addExprCtxt expr $ -- Note [Error contexts in generated code] + do { expr' <- tcPolyExpr expr res_ty + ; return (L loc expr') } + +tcPolyLExprNC (L loc expr) res_ty + = setSrcSpanA loc $ + 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 + -> TcRhoType -- Expected type + -- Definitely no foralls at the top + -> TcM (LHsExpr GhcTc) +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 + -- Definitely no foralls at the top + -> TcM (LHsExpr GhcTc) + +tcMonoExpr (L loc expr) res_ty + = setSrcSpanA loc $ -- Set location /first/; see GHC.Tc.Utils.Monad + addExprCtxt expr $ -- Note [Error contexts in generated code] + do { expr' <- tcExpr expr res_ty + ; return (L loc expr') } + +tcMonoExprNC (L loc expr) res_ty + = setSrcSpanA loc $ + do { expr' <- tcExpr expr res_ty + ; return (L loc expr') } + +--------------- +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 +-- 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 +-- - 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 +-- See Note [Application chains and heads] in GHC.Tc.Gen.App +tcExpr e@(HsVar {}) res_ty = tcApp e res_ty +tcExpr e@(HsApp {}) res_ty = tcApp e res_ty +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 (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 (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 (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 expr) res_ty + = do { expr' <- tcMonoExprNC expr res_ty + ; return (HsPar x expr') } + +tcExpr (HsPragE x prag expr) res_ty + = do { expr' <- tcMonoExpr expr res_ty + ; return (HsPragE x (tcExprPrag prag) expr') } + +tcExpr (NegApp x expr neg_expr) res_ty + = do { (expr', neg_expr') + <- tcSyntaxOp NegateOrigin neg_expr [SynAny] res_ty $ + \[arg_ty] [arg_mult] -> + tcScalingUsage arg_mult $ tcCheckMonoExpr expr arg_ty + ; return (NegApp x expr' neg_expr') } + +tcExpr e@(HsIPVar _ x) res_ty + = do { ip_ty <- newFlexiTyVarTy liftedTypeKind + -- Create a unification type variable of kind 'Type'. + -- (The type of an implicit parameter must have kind 'Type'.) + ; let ip_name = mkStrLitTy (hsIPNameFS x) + 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 + (mkHsWrap wrap (mkHsVar (noLocA ip_op))) + ip_ty res_ty } + +tcExpr e@(HsLam x lam_variant matches) res_ty + = do { (wrap, matches') <- tcLambdaMatches e lam_variant matches [] res_ty + ; return (mkHsWrap wrap $ HsLam x lam_variant matches') } + +{- +************************************************************************ +* * + Overloaded literals +* * +************************************************************************ +-} + +tcExpr e@(HsOverLit _ lit) res_ty + = -- See Note [Typechecking overloaded literals] + do { mb_res <- tcShortCutLit lit res_ty + -- See Note [Short cut for overloaded literals] in GHC.Tc.Utils.TcMType + ; case mb_res of + Just lit' -> return (HsOverLit noExtField lit') + Nothing -> tcApp e res_ty } + -- Why go via tcApp? See Note [Typechecking overloaded literals] + +{- Note [Typechecking overloaded literals] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Generally speaking, an overloaded literal like "3" typechecks as if you +had written (fromInteger (3 :: Integer)). But in practice it's a little +tricky: + +* Rebindable syntax (see #19154 and !4981). With rebindable syntax we might have + fromInteger :: Integer -> forall a. Num a => a + and then we might hope to use a Visible Type Application (VTA) to write + 3 @Int + expecting it to expand to + fromInteger (3::Integer) @Int dNumInt + To achieve that, we need to + * treat the application using `tcApp` to deal with the VTA + * treat the overloaded literal as the "head" of an application; + see `GHC.Tc.Gen.Head.tcInferAppHead`. + +* Short-cutting. If we have + xs :: [Int] + xs = [3,4,5,6... ] + then it's a huge short-cut (in compile time) to just cough up the `Int` literal + for `3`, rather than (fromInteger @Int d), with a wanted constraint `[W] Num Int`. + See Note [Short cut for overloaded literals] in GHC.Tc.Utils.TcMType. + + We can only take this short-cut if rebindable syntax is off; see `tcShortCutLit`. +-} + + +{- +************************************************************************ +* * + Explicit lists +* * +************************************************************************ +-} + +-- Explicit lists [e1,e2,e3] have been expanded already in the renamer +-- The expansion includes an ExplicitList, but it is always the built-in +-- list type, so that's all we need concern ourselves with here. See +-- GHC.Rename.Expr. Note [Handling overloaded and rebindable constructs] +tcExpr (ExplicitList _ exprs) res_ty + = do { res_ty <- expTypeToType res_ty + ; (coi, elt_ty) <- matchExpectedListTy res_ty + ; let tc_elt expr = tcCheckPolyExpr expr elt_ty + ; exprs' <- mapM tc_elt exprs + ; return $ mkHsWrapCo coi $ ExplicitList elt_ty exprs' } + +tcExpr expr@(ExplicitTuple x tup_args boxity) res_ty + | all tupArgPresent tup_args + = do { let arity = length tup_args + tup_tc = tupleTyCon boxity arity + -- NB: tupleTyCon doesn't flatten 1-tuples + -- See Note [Don't flatten tuples from HsSyn] in GHC.Core.Make + ; res_ty <- expTypeToType res_ty + ; (coi, arg_tys) <- matchExpectedTyConApp tup_tc res_ty + -- Unboxed tuples have RuntimeRep vars, which we + -- don't care about here + -- 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 <- 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 { (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] + + -- See Note [Typechecking data constructors] in GHC.Tc.Gen.Head + -- See Note [Don't flatten tuples from HsSyn] in GHC.Core.Make + act_res_ty = mkScaledFunTys missing_tys (mkTupleTy1 boxity arg_tys) + + ; traceTc "ExplicitTuple" (ppr act_res_ty $$ ppr res_ty) + + ; tcWrapResultMono expr expr' act_res_ty res_ty } + +tcExpr (ExplicitSum _ alt arity expr) res_ty + = do { let sum_tc = sumTyCon arity + ; res_ty <- expTypeToType res_ty + ; (coi, arg_tys) <- matchExpectedTyConApp sum_tc res_ty + ; -- Drop levity vars, we don't care about them here + let arg_tys' = drop arity arg_tys + arg_ty = arg_tys' `getNth` (alt - 1) + ; expr' <- tcCheckPolyExpr expr arg_ty + -- Check the whole res_ty, not just the arg_ty, to avoid #20277. + -- Example: + -- a :: TYPE rep (representation-polymorphic) + -- (# 17# | #) :: (# Int# | a #) + -- 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 Nothing) res_ty + ; return $ mkHsWrapCo coi (ExplicitSum arg_tys' alt arity expr' ) } + + +{- +************************************************************************ +* * + Let, case, if, do +* * +************************************************************************ +-} + +tcExpr (HsLet x binds expr) res_ty + = do { (binds', expr') <- tcLocalBinds binds $ + tcMonoExpr expr res_ty + ; return (HsLet x binds' expr') } + +tcExpr (HsCase ctxt scrut matches) res_ty + = do { -- We used to typecheck the case alternatives first. + -- The case patterns tend to give good type info to use + -- when typechecking the scrutinee. For example + -- case (map f) of + -- (x:xs) -> ... + -- will report that map is applied to too few arguments + -- + -- But now, in the GADT world, we need to typecheck the scrutinee + -- first, to get type info that may be refined in the case alternatives + mult <- newFlexiTyVarTy multiplicityTy + + -- Typecheck the scrutinee. We use tcInferRho but tcInferSigma + -- 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 + + ; hasFixedRuntimeRep_syntactic FRRCase scrut_ty + ; 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 + ; (u1,b1') <- tcCollectingUsage $ tcMonoExpr b1 res_ty + ; (u2,b2') <- tcCollectingUsage $ tcMonoExpr b2 res_ty + ; tcEmitBindingUsage (supUE u1 u2) + ; return (HsIf x pred' b1' b2') } + +{- +Note [MultiWayIf linearity checking] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we'd like to compute the usage environment for + +if | b1 -> e1 + | b2 -> e2 + | otherwise -> e3 + +and let u1, u2, v1, v2, v3 denote the usage env for b1, b2, e1, e2, e3 +respectively. + +Since a multi-way if is mere sugar for nested if expressions, the usage +environment should ideally be u1 + sup(v1, u2 + sup(v2, v3)). +However, currently we don't support linear guards (#19193). All variables +used in guards from u1 and u2 will have multiplicity Many. +But in that case, we have equality u1 + sup(x,y) = sup(u1 + x, y), + and likewise u2 + sup(x,y) = sup(u2 + x, y) for any x,y. +Using this identity, we can just compute sup(u1 + v1, u2 + v2, v3) instead. +This is simple to do, since we get u_i + v_i directly from tcGRHS. +If we add linear guards, this code will have to be revisited. +Not using 'sup' caused #23814. +-} + +tcExpr (HsMultiIf _ alts) res_ty + = do { alts' <- tcGRHSNE IfAlt tcBody alts res_ty + -- See Note [MultiWayIf linearity checking] + ; res_ty <- readExpType res_ty + ; return (HsMultiIf res_ty alts') } + +tcExpr (HsDo _ do_or_lc stmts) res_ty + = tcDoStmts do_or_lc stmts res_ty + +tcExpr (HsProc x pat cmd) res_ty + = do { (pat', cmd', coi) <- tcProc pat cmd res_ty + ; return $ mkHsWrapCo coi (HsProc x pat' cmd') } + +-- Typechecks the static form and wraps it with a call to 'fromStaticPtr'. +-- See Note [Grand plan for static forms] in GHC.Iface.Tidy.StaticPtrTable for an overview. +-- To type check +-- (static e) :: p a +-- we want to check (e :: a), +-- and wrap (static e) in a call to +-- fromStaticPtr :: IsStatic p => StaticPtr a -> p a + +tcExpr (HsStatic fvs expr) res_ty + = do { res_ty <- expTypeToType res_ty + ; (co, (p_ty, expr_ty)) <- matchExpectedAppTy res_ty + ; (expr', lie) <- captureConstraints $ + 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 + -- checkClosedInStaticForm are error messages. + ; mapM_ checkClosedInStaticForm $ nonDetEltsUniqSet fvs + + -- Require the type of the argument to be Typeable. + ; typeableClass <- tcLookupClass typeableClassName + ; typeable_ev <- emitWantedEvVar StaticOrigin $ + mkTyConApp (classTyCon typeableClass) + [liftedTypeKind, expr_ty] + + -- Insert the constraints of the static form in a global list for later + -- 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. + ; fromStaticPtr <- newMethodFromName StaticOrigin fromStaticPtrName + [p_ty] + ; let wrap = mkWpEvVarApps [typeable_ev] <.> mkWpTyApps [expr_ty] + ; loc <- getSrcSpanM + ; static_ptr_ty_con <- tcLookupTyCon staticPtrTyConName + ; 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) + +{- +************************************************************************ +* * + Record construction and update +* * +************************************************************************ +-} + +tcExpr expr@(RecordCon { rcon_con = L loc qcon@(WithUserRdr _ con_name) + , rcon_flds = rbinds }) res_ty + = do { con_like <- tcLookupConLike qcon + + ; (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. + ; let arity = conLikeArity con_like + Right (arg_tys, actual_res_ty) = tcSplitFunTysN arity con_tau + + ; checkTc (conLikeHasBuilder con_like) $ + nonBidirectionalErr (conLikeName con_like) + + ; rbinds' <- tcRecordBinds con_like arg_tys rbinds + + ; let rcon_tc = mkHsWrap con_wrap con_expr + expr' = RecordCon { rcon_ext = rcon_tc + , rcon_con = L loc con_like + , rcon_flds = rbinds' } + + ; ret <- tcWrapResultMono expr expr' actual_res_ty res_ty + + -- Check for missing fields. We do this after type-checking to get + -- better types in error messages (cf #18869). For example: + -- data T a = MkT { x :: a, y :: a } + -- r = MkT { y = True } + -- Then we'd like to warn about a missing field `x :: True`, rather than `x :: a0`. + -- + -- NB: to do this really properly we should delay reporting until typechecking is complete, + -- via a new `HoleSort`. But that seems too much work. + ; checkMissingFields con_like rbinds arg_tys + + ; return ret } + where + orig = OccurrenceOf con_name + +-- 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. +tcExpr expr@(RecordUpd { rupd_expr = record_expr + , rupd_flds = + RegularRecUpdFields + { xRecUpdFields = possible_parents + , recUpdFields = rbnds } + }) + res_ty + = assert (notNull rbnds) $ + do { -- Expand the record update. See Note [Record Updates]. + ; (ds_expr, ds_res_ty, err_ctxt) + <- expandRecordUpd record_expr possible_parents rbnds res_ty + + -- 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 expanded + -- expression with the expected result type. + -- + -- See Note [Unifying result types in tcRecordUpd]. + -- Test case: T10808. + } + +tcExpr e@(RecordUpd { rupd_flds = OverloadedRecUpdFields {}}) _ + = pprPanic "tcExpr: unexpected overloaded-dot RecordUpd" $ ppr e + +{- +************************************************************************ +* * + Arithmetic sequences e.g. [a,b..] + and their parallel-array counterparts e.g. [: a,b.. :] + +* * +************************************************************************ +-} + +tcExpr (ArithSeq _ witness seq) res_ty + = tcArithSeq witness seq res_ty + +{- +************************************************************************ +* * + Record dot syntax +* * +************************************************************************ +-} + +-- 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" + +{- +************************************************************************ +* * + Template Haskell +* * +************************************************************************ +-} + +-- 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 _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 + -- 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 } + +{- +************************************************************************ +* * + Catch-all +* * +************************************************************************ +-} + +tcExpr (HsOverLabel {}) ty = pprPanic "tcExpr:HsOverLabel" (ppr ty) +tcExpr (SectionL {}) ty = pprPanic "tcExpr:SectionL" (ppr ty) +tcExpr (SectionR {}) ty = pprPanic "tcExpr:SectionR" (ppr ty) + + +{- +************************************************************************ +* * + 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 +* * +************************************************************************ +-} + +tcArithSeq :: Maybe (SyntaxExpr GhcRn) -> ArithSeqInfo GhcRn -> ExpRhoType + -> TcM (HsExpr GhcTc) + +tcArithSeq witness seq@(From expr) res_ty + = do { (wrap, elt_mult, elt_ty, wit') <- arithSeqEltType witness res_ty + ; expr' <-tcScalingUsage elt_mult $ tcCheckPolyExpr expr elt_ty + ; enum_from <- newMethodFromName (ArithSeqOrigin seq) + enumFromName [elt_ty] + ; return $ mkHsWrap wrap $ + ArithSeq enum_from wit' (From expr') } + +tcArithSeq witness seq@(FromThen expr1 expr2) res_ty + = do { (wrap, elt_mult, elt_ty, wit') <- arithSeqEltType witness res_ty + ; expr1' <- tcScalingUsage elt_mult $ tcCheckPolyExpr expr1 elt_ty + ; expr2' <- tcScalingUsage elt_mult $ tcCheckPolyExpr expr2 elt_ty + ; enum_from_then <- newMethodFromName (ArithSeqOrigin seq) + enumFromThenName [elt_ty] + ; return $ mkHsWrap wrap $ + ArithSeq enum_from_then wit' (FromThen expr1' expr2') } + +tcArithSeq witness seq@(FromTo expr1 expr2) res_ty + = do { (wrap, elt_mult, elt_ty, wit') <- arithSeqEltType witness res_ty + ; expr1' <- tcScalingUsage elt_mult $ tcCheckPolyExpr expr1 elt_ty + ; expr2' <- tcScalingUsage elt_mult $ tcCheckPolyExpr expr2 elt_ty + ; enum_from_to <- newMethodFromName (ArithSeqOrigin seq) + enumFromToName [elt_ty] + ; return $ mkHsWrap wrap $ + ArithSeq enum_from_to wit' (FromTo expr1' expr2') } + +tcArithSeq witness seq@(FromThenTo expr1 expr2 expr3) res_ty + = do { (wrap, elt_mult, elt_ty, wit') <- arithSeqEltType witness res_ty + ; expr1' <- tcScalingUsage elt_mult $ tcCheckPolyExpr expr1 elt_ty + ; expr2' <- tcScalingUsage elt_mult $ tcCheckPolyExpr expr2 elt_ty + ; expr3' <- tcScalingUsage elt_mult $ tcCheckPolyExpr expr3 elt_ty + ; eft <- newMethodFromName (ArithSeqOrigin seq) + enumFromThenToName [elt_ty] + ; return $ mkHsWrap wrap $ + ArithSeq eft wit' (FromThenTo expr1' expr2' expr3') } + +----------------- +arithSeqEltType :: Maybe (SyntaxExpr GhcRn) -> ExpRhoType + -> TcM (HsWrapper, Mult, TcType, Maybe (SyntaxExpr GhcTc)) +arithSeqEltType Nothing res_ty + = do { res_ty <- expTypeToType res_ty + ; (coi, elt_ty) <- matchExpectedListTy res_ty + ; return (mkWpCastN coi, OneTy, elt_ty, Nothing) } +arithSeqEltType (Just fl) res_ty + = do { ((elt_mult, elt_ty), fl') + <- tcSyntaxOp ListOrigin fl [SynList] res_ty $ + \ [elt_ty] [elt_mult] -> return (elt_mult, elt_ty) + ; return (idHsWrapper, elt_mult, elt_ty, Just fl') } + +---------------- + +-- | 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 + = 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 + ; (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 + -> SyntaxExprRn + -> [SyntaxOpType] -- ^ shape of syntax operator arguments + -> ExpRhoType -- ^ overall result type + -> ([TcSigmaType] -> [Mult] -> TcM a) -- ^ Type check any arguments, + -- takes a type per hole and a + -- multiplicity per arrow in + -- the shape. + -> TcM (a, SyntaxExprTc) +-- ^ Typecheck a syntax operator +-- The operator is a variable or a lambda at this stage (i.e. renamer +-- output)t +tcSyntaxOp orig expr arg_tys res_ty + = tcSyntaxOpGen orig expr arg_tys (SynType res_ty) + +-- | Slightly more general version of 'tcSyntaxOp' that allows the caller +-- to specify the shape of the result of the syntax operator +tcSyntaxOpGen :: CtOrigin + -> SyntaxExprRn + -> [SyntaxOpType] + -> SyntaxOpType + -> ([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) + -- 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) + <- tcSynArgA orig op sigma arg_tys res_ty $ + thing_inside + ; traceTc "tcSyntaxOpGen" (ppr op $$ ppr expr $$ ppr sigma ) + ; return (result, SyntaxExprTc { syn_expr = mkHsWrap expr_wrap expr + , syn_arg_wraps = arg_wraps + , syn_res_wrap = res_wrap }) } +tcSyntaxOpGen _ NoSyntaxExprRn _ _ _ = panic "tcSyntaxOpGen" + +{- +Note [tcSynArg] +~~~~~~~~~~~~~~~ +Because of the rich structure of SyntaxOpType, we must do the +contra-/covariant thing when working down arrows, to get the +instantiation vs. skolemisation decisions correct (and, more +obviously, the orientation of the HsWrappers). We thus have +two tcSynArgs. +-} + +-- works on "expected" types, skolemising where necessary +-- See Note [tcSynArg] +tcSynArgE :: CtOrigin + -> HsExpr GhcRn -- ^ the operator to check (for error messages only) + -> TcSigmaType + -> SyntaxOpType -- ^ shape it is expected to have + -> ([TcSigmaTypeFRR] -> [Mult] -> TcM a) -- ^ check the arguments + -> TcM (a, HsWrapper) + -- ^ 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)) + <- tcSkolemise Shallow GenSigCtxt sigma_ty $ \rho_ty -> + go rho_ty syn_ty + ; return (result, skol_wrap <.> ty_wrapper) } + where + go rho_ty SynAny + = do { result <- thing_inside [rho_ty] [] + ; return (result, idHsWrapper) } + + go rho_ty SynRho -- same as SynAny, because we skolemise eagerly + = do { result <- thing_inside [rho_ty] [] + ; return (result, idHsWrapper) } + + go rho_ty SynList + = do { (list_co, elt_ty) <- matchExpectedListTy rho_ty + ; result <- thing_inside [elt_ty] [] + ; return (result, mkWpCastN list_co) } + + go rho_ty (SynFun arg_shape res_shape) + = do { ( match_wrapper -- :: (arg_ty -> res_ty) "->" rho_ty + , ( ( (result, arg_ty, res_ty, op_mult) + , res_wrapper ) -- :: res_ty_out "->" res_ty + , arg_wrapper1, [], arg_wrapper2 ) ) -- :: arg_ty "->" arg_ty_out + <- matchExpectedFunTys herald GenSigCtxt 1 (mkCheckExpType rho_ty) $ + \ [ExpFunPatTy arg_ty] res_ty -> + do { arg_tc_ty <- expTypeToType (scaledThing arg_ty) + ; res_tc_ty <- expTypeToType res_ty + + -- another nested arrow is too much for now, + -- but I bet we'll never need this + ; massertPpr (case arg_shape of + SynFun {} -> False; + _ -> True) + (text "Too many nested arrows in SyntaxOpType" $$ + pprCtOrigin orig) + + ; let arg_mult = scaledMult arg_ty + ; tcSynArgA orig op arg_tc_ty [] arg_shape $ + \ arg_results arg_res_mults -> + tcSynArgE orig op res_tc_ty res_shape $ + \ res_results res_res_mults -> + do { result <- thing_inside (arg_results ++ res_results) ([arg_mult] ++ arg_res_mults ++ res_res_mults) + ; return (result, arg_tc_ty, res_tc_ty, arg_mult) }} + + ; let fun_wrap = mkWpFun (arg_wrapper2 <.> arg_wrapper1) res_wrapper + (Scaled op_mult arg_ty) res_ty + -- NB: arg_ty comes from matchExpectedFunTys, so it has a + -- fixed RuntimeRep, as needed to call mkWpFun. + ; return (result, match_wrapper <.> fun_wrap) } + where + herald = ExpectedFunTySyntaxOp orig op + + go rho_ty (SynType the_ty) + = do { wrap <- tcSubTypePat orig GenSigCtxt the_ty rho_ty + ; result <- thing_inside [] [] + ; return (result, wrap) } + +-- works on "actual" types, instantiating where necessary +-- See Note [tcSynArg] +tcSynArgA :: CtOrigin + -> HsExpr GhcRn -- ^ the operator we are checking (for error messages) + -> TcSigmaType + -> [SyntaxOpType] -- ^ argument shapes + -> SyntaxOpType -- ^ result shape + -> ([TcSigmaTypeFRR] -> [Mult] -> TcM a) -- ^ check the arguments + -> TcM (a, HsWrapper, [HsWrapper], HsWrapper) + -- ^ returns a wrapper to be applied to the original function, + -- wrappers to be applied to arguments + -- 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) + <- 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 -> + tc_syn_arg res_ty res_shape $ \ res_results -> + thing_inside (arg_results ++ res_results) (map scaledMult arg_tys ++ arg_res_mults) + ; return (result, match_wrapper, arg_wrappers, res_wrapper) } + where + herald = ExpectedFunTySyntaxOp orig op + + tc_syn_args_e :: [TcSigmaTypeFRR] -> [SyntaxOpType] + -> ([TcSigmaTypeFRR] -> [Mult] -> TcM a) + -> TcM (a, [HsWrapper]) + -- the wrappers are for arguments + tc_syn_args_e (arg_ty : arg_tys) (arg_shape : arg_shapes) thing_inside + = do { ((result, arg_wraps), arg_wrap) + <- tcSynArgE orig op arg_ty arg_shape $ \ arg1_results arg1_mults -> + tc_syn_args_e arg_tys arg_shapes $ \ args_results args_mults -> + thing_inside (arg1_results ++ args_results) (arg1_mults ++ args_mults) + ; return (result, arg_wrap : arg_wraps) } + tc_syn_args_e _ _ thing_inside = (, []) <$> thing_inside [] [] + + tc_syn_arg :: TcSigmaTypeFRR -> SyntaxOpType + -> ([TcSigmaTypeFRR] -> TcM a) + -> TcM (a, HsWrapper) + -- the wrapper applies to the overall result + tc_syn_arg res_ty SynAny thing_inside + = do { result <- thing_inside [res_ty] + ; return (result, idHsWrapper) } + tc_syn_arg res_ty SynRho thing_inside + = do { (inst_wrap, rho_ty) <- topInstantiate orig res_ty + -- inst_wrap :: res_ty "->" rho_ty + ; result <- thing_inside [rho_ty] + ; return (result, inst_wrap) } + tc_syn_arg res_ty SynList thing_inside + = do { (inst_wrap, rho_ty) <- topInstantiate orig res_ty + -- inst_wrap :: res_ty "->" rho_ty + ; (list_co, elt_ty) <- matchExpectedListTy rho_ty + -- list_co :: [elt_ty] ~N rho_ty + ; result <- thing_inside [elt_ty] + ; return (result, mkWpCastN (mkSymCo list_co) <.> inst_wrap) } + tc_syn_arg _ (SynFun {}) _ + = pprPanic "tcSynArgA hits a SynFun" (ppr orig) + tc_syn_arg res_ty (SynType the_ty) thing_inside + = do { wrap <- addSubTypeCtxt res_ty the_ty $ + tcSubType orig GenSigCtxt Nothing res_ty the_ty + ; result <- thing_inside [] + ; return (result, wrap) } + +{- +Note [Push result type in] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +Unify with expected result before type-checking the args so that the +info from res_ty percolates to args. This is when we might detect a +too-few args situation. (One can think of cases when the opposite +order would give a better error message.) +experimenting with putting this first. + +Here's an example where it actually makes a real difference + + class C t a b | t a -> b + instance C Char a Bool + + data P t a = forall b. (C t a b) => MkP b + data Q t = MkQ (forall a. P t a) + + f1, f2 :: Q Char; + f1 = MkQ (MkP True) + f2 = MkQ (MkP True :: forall a. P Char a) + +With the change, f1 will type-check, because the 'Char' info from +the signature is propagated into MkQ's argument. With the check +in the other order, the extra signature in f2 is reqd. +-} + +{- ********************************************************************* +* * + Expanding record update +* * +********************************************************************* -} + +{- Note [Record Updates] +~~~~~~~~~~~~~~~~~~~~~~~~ +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 }` expands as follows + + e { x=e1, y=e2 } + ===> + let { x' = e1; y' = e2 } in + case e of + 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 expansion is to identify T and then T1/T4. + +Wrinkle [Disambiguating fields] + + As explained in Note [Disambiguating record updates] in GHC.Rename.Pat, + to typecheck a record update we first need to disambiguate the field labels, + in order to find a parent which has at least one constructor with all of the fields + being updated. + + As mentioned in Note [Type-directed record disambiguation], we sometimes use + type-directed disambiguation, although this mechanism is deprecated and + scheduled for removal via the implementation of GHC proposal #366 + 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 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) Expand the record update as described above, using an XXExprGhcRn. + (a) Create a let-binding to share the record update right-hand sides. + (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 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) +and a collection of residual constraints. +We have no need for the latter two, because we will typecheck again in (D3). So, for +the time being (and until GHC proposal #366 is implemented), we simply drop them. + +Wrinkle [Using IdSig] + + As noted above, we want to let-bind the updated fields to avoid code duplication: + + let { x' = e1; y' = e2 } in + case e of + T1 _ _ z -> T1 x' y' z + T4 p _ _ -> T4 p y' x' + + However, doing so in a naive way would cause difficulties for type inference. + For example: + + data R b = MkR { f :: (forall a. a -> a) -> (Int,b), c :: Int } + foo r = r { f = \ k -> (k 3, k 'x') } + + If we expand to: + + ds_foo r = + let f' = \ k -> (k 3, k 'x') + in case r of + MkR _ b -> MkR f' b + + then we are unable to infer an appropriately polymorphic type for f', because we + never infer higher-rank types. To circumvent this problem, we proceed as follows: + + 1. Obtain general field types by instantiating any of the constructors + that contain all the necessary fields. (Note that the field type must be + identical across different constructors of a given data constructor). + 2. Let-bind an 'IdSig' with this type. This amounts to giving the let-bound + 'Id's a partial type signature. + + In the above example, it's as if we wrote: + + ds_foo r = + let f' :: (forall a. a -> a) -> (Int, _b) + f' = \ k -> (k 3, k 'x') + in case r of + MkR _ b -> MkR f' b + + This allows us to compute the right type for f', and thus accept this record update. + +Note [Type-directed record disambiguation] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +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. + + 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: + + (a) Use the type being pushed in, if it is already a TyConApp. The + following are valid updates at type `R`: + + g :: R -> R + g x = x { fld1 = 3 } + + g' x = x { fld1 = 3 } :: R + + (b) Use the type signature of the record expression, if it exists and + is a TyConApp. Thus this is valid update at type `R`: + + h x = (x :: R) { fld1 = 3 } + +Note that this type-directed disambiguation mechanism isn't very robust, +as it doesn't properly integrate with the rest of the typechecker. +For example, the following updates will all be rejected as ambiguous: + + let r :: R + r = blah + in r { foo = 3 } + + \r. (r { foo = 3 }, r :: R) + +Record updates which require constraint-solving should instead use the +-XOverloadedRecordUpdate extension, as described in Note [Overview of record dot syntax]. + +Note [Unifying result types in tcRecordUpd] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +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: + + type family F (a :: Type) :: Type where {} + data D a = MkD { fld :: F a } + + f :: F Int -> D Bool -> D Int + f i r = r { fld = i } + +This record update expands to: + + let x :: F alpha -- metavariable + x = i + in case r of + MkD _ -> MkD x + +Because the type family F is not injective, our only hope for unifying the +metavariable alpha is through the result type of the record update, which tells +us that we should unify alpha := Int. + +Test case: T10808. + +Wrinkle [GADT result type in tcRecordUpd] + + When dealing with a GADT, we want to be careful about which result type we use. + + Example: + + data G a b where + MkG :: { bar :: F a } -> G a Int + + g :: F Int -> G Float b -> G Int b + g i r = r { bar = i } + + We **do not** want to use the result type from the constructor MkG, which would + leave us with a result type "G alpha Int". Instead, we should use the result type + from the GADT header, instantiating as above, to get "G alpha beta" which will get + unified withy "G Int b". + + Test cases: T18809, HardRecordUpdate. + +-} + +-- | 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 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, + -- with the associated constructors and field labels + -> [LHsRecUpdField GhcRn GhcRn] + -- ^ the record update fields + -> ExpRhoType + -- ^ the expected result type of the record update + -> TcM ( HsExpr GhcRn + -- Expanded record update expression + , TcType + -- result type of expanded record update + , ErrCtxtMsg + -- error context to push when typechecking + -- the expanded code + ) +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 expand. See Wrinkle [Disambiguating fields] + -- in Note [Record Updates]. + ; ((_, record_rho), _lie) <- captureConstraints $ -- see (1) below + tcScalingUsage ManyTy $ -- see (2) below + tcInferRho record_expr + + -- (1) + -- 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 expanded record update, including `record_expr`, + -- and typecheck it from scratch. We don't want to generate the constraints twice! + + -- (2) + -- Record update drops some of the content of the record (namely the + -- content of the field being updated). As a consequence, unless the + -- field being updated is unrestricted in the record, we need an + -- unrestricted record. Currently, we simply always require an + -- unrestricted record. + -- + -- Consider the following example: + -- + -- data R a = R { self :: a } + -- bad :: a ⊸ () + -- bad x = let r = R x in case r { self = () } of { R x' -> x' } + -- + -- This should definitely *not* typecheck. + + -- STEP 1: disambiguate the record update by computing a single parent + -- which has a constructor with all of the fields being updated. + -- + -- See Note [Disambiguating record updates] in GHC.Rename.Pat. + ; (cons, rbinds) + <- disambiguateRecordBinds record_expr record_rho possible_parents rbnds res_ty + ; let sel_ids = map (unLoc . foLabel . unLoc . hfbLHS . unLoc) rbinds + upd_fld_names = map idName sel_ids + relevant_cons@(relevant_con NE.:| _) = + case NE.nonEmpty $ nonDetEltsUniqSet cons of + Just rel_cons -> rel_cons + Nothing -> pprPanic "desugarRecordUpd: no relevant constructors" $ + vcat [ text "record_expr:" <+> ppr record_expr ] + + -- STEP 2: expand the record update. + -- + -- (a) Create new variables for the fields we are updating, + -- so that we can share them across constructors. + -- + -- Example: + -- + -- e { x=e1, y=e2 } + -- + -- We want to let-bind variables to `e1` and `e2`: + -- + -- let x' :: Int + -- x' = e1 + -- y' :: Bool + -- y' = e2 + -- in ... + + -- Instantiate the type variables of any relevant constuctor + -- with metavariables to obtain a type for each 'Id'. + -- This will allow us to have 'Id's with polymorphic types + -- by using 'IdSig'. See Wrinkle [Using IdSig] in Note [Record Updates]. + ; let (univ_tvs, ex_tvs, eq_spec, _, _, arg_tys, con_res_ty) = conLikeFullSig relevant_con + ; (subst, tc_tvs) <- newMetaTyVars (univ_tvs ++ ex_tvs) + ; let (actual_univ_tys, _actual_ex_tys) = splitAtList univ_tvs $ map mkTyVarTy tc_tvs + + -- See Wrinkle [GADT result type in tcRecordUpd] + -- for an explanation of the following. + ds_res_ty = case relevant_con of + RealDataCon con + | not (null eq_spec) -- We only need to do this if we have actual GADT equalities. + -> mkFamilyTyConApp (dataConTyCon con) actual_univ_tys + _ -> substTy subst con_res_ty + + -- Gather pairs of let-bound Ids and their right-hand sides, + -- e.g. (x', e1), (y', e2), ... + ; let mk_upd_id :: Name -> LHsFieldBind GhcTc fld (LHsExpr GhcRn) -> TcM (Name, (TcId, LHsExpr GhcRn)) + mk_upd_id fld_nm (L _ rbind) + = do { let Scaled _ arg_ty = lookupNameEnv_NF arg_ty_env fld_nm + nm_occ = rdrNameOcc . nameRdrName $ fld_nm + actual_arg_ty = substTy subst arg_ty + rhs = hfbRHS rbind + ; (_co, actual_arg_ty) <- hasFixedRuntimeRep (FRRRecordUpdate fld_nm (unLoc rhs)) actual_arg_ty + -- We get a better error message by doing a (redundant) representation-polymorphism check here, + -- rather than delaying until the typechecker typechecks the let-bindings, + -- because the let-bound Ids have internal names. + -- (As we will typecheck the let-bindings later, we can drop this coercion here.) + -- See RepPolyRecordUpdate test. + ; nm <- newNameAt nm_occ generatedSrcSpan + ; let id = mkLocalId nm ManyTy actual_arg_ty + -- NB: create fresh names to avoid any accidental shadowing + -- occurring in the RHS expressions when creating the let bindings: + -- + -- let x1 = e1; x2 = e2; ... + -- + -- Above, we use multiplicity Many rather than the one associated to arg_ty. + -- Normally, there shouldn't be a difference, since it's a let binding. + -- But -XStrict can convert the let to a case, and this causes issues + -- in test LinearRecUpd. Since we don't support linear record updates, + -- using Many is simple and safe. + ; return (fld_nm, (id, rhs)) + } + arg_ty_env = mkNameEnv + $ zipWith (\ lbl arg_ty -> (flSelector lbl, arg_ty)) + (conLikeFieldLabels relevant_con) + arg_tys + + ; traceTc "tcRecordUpd" $ + vcat [ text "upd_fld_names:" <+> ppr upd_fld_names + , text "relevant_cons:" <+> ppr relevant_cons ] + + ; upd_ids <- zipWithM mk_upd_id upd_fld_names rbinds + ; let updEnv :: UniqMap Name (Id, LHsExpr GhcRn) + updEnv = listToUniqMap $ upd_ids + + make_pat :: ConLike -> LMatch GhcRn (LHsExpr GhcRn) + -- As explained in Note [Record Updates], to expand + -- + -- e { x=e1, y=e2 } + -- + -- we generate a case statement, with an equation for + -- each constructor of the record. For example, for + -- the constructor + -- + -- T1 :: { x :: Int, y :: Bool, z :: Char } -> T p q + -- + -- we let-bind x' = e1, y' = e2 and generate the equation: + -- + -- T1 _ _ z -> T1 x' y' z + make_pat conLike = mkSimpleMatch RecUpd (noLocA [pat]) rhs + where + (lhs_con_pats, rhs_con_args) + = zipWithAndUnzip mk_con_arg [1..] con_fields + pat = genSimpleConPat con lhs_con_pats + rhs = wrapGenSpan $ genHsApps con rhs_con_args + con = conLikeName conLike + con_fields = conLikeFieldLabels conLike + + mk_con_arg :: Int + -> FieldLabel + -> ( LPat GhcRn + -- LHS constructor pattern argument + , LHsExpr GhcRn ) + -- RHS constructor argument + mk_con_arg i fld_lbl = + -- 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 + -- Field is being updated: LHS = wildcard pattern, RHS = appropriate let-bound Id. + Just (upd_id, _) -> (genWildPat, genLHsVar (idName upd_id)) + -- Field is not being updated: LHS = variable pattern, RHS = that same variable. + _ -> let fld_nm = mkInternalName (mkBuiltinUnique i) + (nameOccName $ flSelector $ fld_lbl) + generatedSrcSpan + in (genVarPat fld_nm, genLHsVar fld_nm) + + -- STEP 2 (b): expand to HsCase, as per note [Record Updates] + ; let ds_expr :: HsExpr GhcRn + ds_expr = HsLet noExtField let_binds (L gen case_expr) + + case_expr :: HsExpr GhcRn + case_expr = HsCase RecUpd record_expr + $ mkMatchGroup (Generated OtherExpansion DoPmc) (wrapGenSpan matches) + matches :: [LMatch GhcRn (LHsExpr GhcRn)] + 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, [genSimpleFunBind (idName id) [] rhs]) + | (_, (id, rhs)) <- upd_ids ] + mk_idSig :: (Name, (Id, LHsExpr GhcRn)) -> LSig GhcRn + mk_idSig (_, (id, _)) = L gen $ XSig $ IdSig id + -- We let-bind variables using 'IdSig' in order to accept + -- record updates involving higher-rank types. + -- See Wrinkle [Using IdSig] in Note [Record Updates]. + gen = noAnnSrcSpan generatedSrcSpan + + ; 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 + ] + + ; return (ds_expr, ds_res_ty, RecordUpdCtxt relevant_cons upd_fld_names ex_tvs) } + + + +{- ********************************************************************* +* * + Record bindings +* * +**********************************************************************-} + +-- | Disambiguate the fields in a record update. +-- +-- Most of the disambiguation has been done by the renamer; this function +-- performs a final type-directed disambiguation pass, as explained in +-- Note [Type-directed record disambiguation]. +disambiguateRecordBinds :: LHsExpr GhcRn -> TcRhoType + -> NE.NonEmpty (HsRecUpdParent GhcRn) + -> [LHsRecUpdField GhcRn GhcRn] -> ExpRhoType + -> TcM (UniqSet ConLike, [LHsRecUpdField GhcTc GhcRn]) +disambiguateRecordBinds record_expr record_rho possible_parents rbnds res_ty + = do { fam_inst_envs <- tcGetFamInstEnvs + -- Identify a single parent, using type-directed disambiguation + -- if necessary. (Note that type-directed disambiguation of + -- record field updates is is scheduled for removal, as per + -- Note [Type-directed record disambiguation].) + ; TcRecUpdParent + { tcRecUpdLabels = lbls + , tcRecUpdCons = cons } + <- identifyParentLabels fam_inst_envs possible_parents + -- Pick the right selector with that parent for each field + ; rbnds' <- zipWithM lookupField (NE.toList lbls) rbnds + ; return (cons, rbnds') } + where + + -- Try to identify a single parent, using type-directed disambiguation. + -- + -- Any non-type-directed disambiguation will have been done already. + -- See GHC.Rename.Env.lookupRecUpdFields. + identifyParentLabels :: FamInstEnvs + -> NE.NonEmpty (HsRecUpdParent GhcRn) + -> TcM (HsRecUpdParent GhcTc) + identifyParentLabels fam_inst_envs possible_parents + = case possible_parents of + + -- Exactly one possible parent for the record update! + p NE.:| [] -> lookup_parent_flds p + + -- Multiple possible parents: try harder to disambiguate. + -- Can we get a parent TyCon from the pushed-in type? + -- + -- See (a) in Note [Type-directed record disambiguation] in GHC.Rename.Pat. + _ NE.:| _ : _ + | Just tc <- tyConOfET fam_inst_envs res_ty + -> do { reportAmbiguousUpdate possible_parents tc + ; try_disambiguated_tycon tc possible_parents } + + -- Does the expression being updated have a type signature? + -- If so, try to extract a parent TyCon from it. + -- + -- See (b) inNote [Type-directed record disambiguation] in GHC.Rename.Pat. + | Just {} <- obviousSig (unLoc record_expr) + , Just tc <- tyConOf fam_inst_envs record_rho + -> do { reportAmbiguousUpdate possible_parents tc + ; try_disambiguated_tycon tc possible_parents } + + -- Nothing else we can try... + p1 NE.:| p2 : ps + -> do { p1 <- tcLookupRecSelParent p1 + ; p2 <- tcLookupRecSelParent p2 + ; ps <- mapM tcLookupRecSelParent ps + ; failWithTc $ TcRnBadRecordUpdate (getUpdFieldLbls rbnds) + $ MultiplePossibleParents (p1, p2, ps) } + + -- Try to use the 'TyCon' we learned from type-directed disambiguation. + -- This might not work, if it doesn't match up with any of the parents we had + -- computed on the basis of the field labels. + -- (See test cases overloadedrecfields01 and T21946.) + try_disambiguated_tycon :: TyCon + -> NE.NonEmpty (HsRecUpdParent GhcRn) + -> TcM (HsRecUpdParent GhcTc) + try_disambiguated_tycon tc pars + = do { pars <- mapMaybeM (fmap (guard_parent tc) . lookup_parent_flds) (NE.toList pars) + ; case pars of + [par] -> return par + [] -> do { pars <- mapM tcLookupRecSelParent possible_parents + ; failWithTc $ TcRnBadRecordUpdate (getUpdFieldLbls rbnds) + $ InvalidTyConParent tc pars } + _ -> pprPanic "try_disambiguated_tycon: more than 1 valid parent" + (ppr $ map tcRecUpdParent pars) } + + guard_parent :: TyCon -> HsRecUpdParent GhcTc -> Maybe (HsRecUpdParent GhcTc) + guard_parent disamb_tc cand_parent@(TcRecUpdParent { tcRecUpdParent = cand_tc }) + = do { guard (RecSelData disamb_tc == cand_tc) + ; return cand_parent } + + lookup_parent_flds :: HsRecUpdParent GhcRn + -> TcM (HsRecUpdParent GhcTc) + lookup_parent_flds par@(RnRecUpdParent { rnRecUpdLabels = lbls, rnRecUpdCons = cons }) + = do { let cons' :: NonDetUniqFM ConLike ConLikeName + cons' = NonDetUniqFM $ unsafeCastUFMKey $ getUniqSet cons + lookup_one con = tcLookupConLike (noUserRdr $ getName con) + ; cons <- traverse lookup_one cons' + ; tc <- tcLookupRecSelParent par + ; return $ + TcRecUpdParent + { tcRecUpdParent = tc + , tcRecUpdLabels = lbls + , tcRecUpdCons = unsafeUFMToUniqSet $ getNonDet cons } } + + lookupField :: FieldGlobalRdrElt + -> LHsRecUpdField GhcRn GhcRn + -> TcM (LHsRecUpdField GhcTc GhcRn) + lookupField fld_gre (L l upd) + = do { let L loc af = hfbLHS upd + lbl = fieldOccRdrName af + mb_gre = pickGREs lbl [fld_gre] + -- NB: this GRE can be 'Nothing' when in GHCi. + -- See test T10439. + + -- Mark the record fields as used, now that we have disambiguated. + -- There is no risk of duplicate deprecation warnings, as we have + -- not marked the GREs as used previously. + ; setSrcSpanA loc $ mapM_ (addUsedGRE AllDeprecationWarnings) mb_gre + ; sel <- tcLookupId (greName fld_gre) + ; return $ L l HsFieldBind + { hfbAnn = hfbAnn upd + , hfbLHS = L (l2l loc) (FieldOcc lbl (L (l2l loc) sel)) + , hfbRHS = hfbRHS upd + , hfbPun = hfbPun upd + } } + + -- The type-directed disambiguation mechanism is scheduled for removal, + -- as per Note [Type-directed record disambiguation]. + -- So we emit a warning whenever the user relies on it. + reportAmbiguousUpdate :: NE.NonEmpty (HsRecUpdParent GhcRn) + -> TyCon -> TcM () + reportAmbiguousUpdate parents parent_type = + setSrcSpan loc $ addDiagnostic $ TcRnAmbiguousRecordUpdate rupd parent_type + where + rupd = RecordUpd { rupd_expr = record_expr + , rupd_flds = + RegularRecUpdFields + { xRecUpdFields = parents + , recUpdFields = rbnds } + , rupd_ext = noExtField } + loc = getLocA (head rbnds) + +{- +Game plan for record bindings +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +1. Find the TyCon for the bindings, from the first field label. + +2. Instantiate its tyvars and unify (T a1 .. an) with expected_ty. + +For each binding field = value + +3. Instantiate the field type (from the field label) using the type + envt from step 2. + +4 Type check the value using tcCheckPolyExprNC (in tcRecordField), + passing the field type as the expected argument type. + +This extends OK when the field types are universally quantified. +-} + +tcRecordBinds + :: ConLike + -> [Scaled TcType] -- Expected type for each field + -> HsRecordBinds GhcRn + -> TcM (HsRecordBinds GhcTc) + +tcRecordBinds con_like arg_tys (HsRecFields x rbinds dd) + = do { mb_binds <- mapM do_bind rbinds + ; return (HsRecFields x (catMaybes mb_binds) dd) } + where + fields = map flSelector $ conLikeFieldLabels con_like + flds_w_tys = zipEqual fields arg_tys + + do_bind :: LHsRecField GhcRn (LHsExpr GhcRn) + -> TcM (Maybe (LHsRecField GhcTc (LHsExpr GhcTc))) + do_bind (L l fld@(HsFieldBind { hfbLHS = f + , hfbRHS = rhs })) + + = do { mb <- tcRecordField con_like flds_w_tys f rhs + ; case mb of + Nothing -> return Nothing + Just (f', rhs') -> return (Just (L l (HsFieldBind + { hfbAnn = hfbAnn fld + , hfbLHS = f' + , hfbRHS = rhs' + , hfbPun = hfbPun fld}))) } + +tcRecordField :: ConLike -> Assoc Name (Scaled Type) + -> LFieldOcc GhcRn -> LHsExpr GhcRn + -> TcM (Maybe (LFieldOcc GhcTc, LHsExpr GhcTc)) +tcRecordField con_like flds_w_tys (L loc (FieldOcc rdr (L l sel_name))) rhs + | Just (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) + 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 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 rdr + + +checkMissingFields :: ConLike -> HsRecordBinds GhcRn -> [Scaled TcType] -> TcM () +checkMissingFields con_like rbinds arg_tys + | null field_labels -- Not declared as a record; + -- But C{} is still valid if no strict fields + = if any isBanged field_strs then + -- Illegal if any arg is strict + addErrTc (TcRnMissingStrictFields con_like []) + else do + when (notNull field_strs && null field_labels) $ do + let msg = TcRnMissingFields con_like [] + (diagnosticTc True msg) + + | otherwise = do -- A record + unless (null missing_s_fields) $ do + fs <- liftZonkM $ zonk_fields missing_s_fields + -- It is an error to omit a strict field, because + -- we can't substitute it with (error "Missing field f") + addErrTc (TcRnMissingStrictFields con_like fs) + + warn <- woptM Opt_WarnMissingFields + when (warn && notNull missing_ns_fields) $ do + fs <- liftZonkM $ zonk_fields missing_ns_fields + -- It is not an error (though we may want) to omit a + -- lazy field, because we can always use + -- (error "Missing field f") instead. + let msg = TcRnMissingFields con_like fs + diagnosticTc True msg + + where + -- we zonk the fields to get better types in error messages (#18869) + zonk_fields fs = forM fs $ \(str,ty) -> do + ty' <- zonkTcType ty + return (str,ty') + missing_s_fields + = [ (flLabel fl, scaledThing ty) | (fl,str,ty) <- field_info, + isBanged str, + not (fl `elemField` field_names_used) + ] + missing_ns_fields + = [ (flLabel fl, scaledThing ty) | (fl,str,ty) <- field_info, + not (isBanged str), + not (fl `elemField` field_names_used) + ] + + field_names_used = hsRecFields rbinds + field_labels = conLikeFieldLabels con_like + + field_info = zip3 field_labels field_strs arg_tys + + field_strs = conLikeImplBangs con_like + + fl `elemField` flds = any (\ fl' -> flSelector fl == fl') flds {- ************************************************************************ 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 @@ -71,17 +71,21 @@ import GHC.Utils.Error import GHC.Utils.Outputable as Outputable import GHC.Utils.Panic +import GHC.Utils.Unique import GHC.Platform import GHC.Data.Bag 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.Builtin.Types (unitTyCon) +import GHC.Types.RepType (typePrimRep1) -- Defines a binding isForeignImport :: forall name. UnXRec name => LForeignDecl name -> Bool @@ -250,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 @@ -267,7 +271,7 @@ id = mkLocalId nm ManyTy sig_ty -- Use a LocalId to obey the invariant that locally-defined -- things are LocalIds. However, it does not need zonking, - -- (so GHC.Tc.Utils.Zonk.zonkForeignExports ignores it). + -- (so GHC.Tc.Zonk.Type.zonkForeignExports ignores it). ; imp_decl' <- tcCheckFIType arg_tys res_ty imp_decl -- Can't use sig_ty here because sig_ty :: Type and @@ -294,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. @@ -352,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) -> @@ -369,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 @@ -401,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 @@ -438,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 @@ -458,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 >> @@ -536,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 @@ -549,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 @@ -563,7 +580,211 @@ 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 + +isFFIArgumentTy :: DynFlags -> Safety -> Type -> Validity' IllegalForeignTypeReason +-- Checks for valid argument type for a 'foreign import' +isFFIArgumentTy dflags safety ty + = checkRepTyCon (legalOutgoingTyCon dflags safety) ty + +isFFIExternalTy :: Type -> Validity' IllegalForeignTypeReason +-- Types that are allowed as arguments of a 'foreign export' +isFFIExternalTy ty = checkRepTyCon legalFEArgTyCon ty + +isFFIImportResultTy :: DynFlags -> Type -> Validity' IllegalForeignTypeReason +isFFIImportResultTy dflags ty + = checkRepTyCon (legalFIResultTyCon dflags) ty + +isFFIExportResultTy :: Type -> Validity' IllegalForeignTypeReason +isFFIExportResultTy ty = checkRepTyCon legalFEResultTyCon ty + +isFFIDynTy :: Type -> Type -> Validity' IllegalForeignTypeReason +-- The type in a foreign import dynamic must be Ptr, FunPtr, or a newtype of +-- either, and the wrapped function type must be equal to the given type. +-- We assume that all types have been run through normaliseFfiType, so we don't +-- need to worry about expanding newtypes here. +isFFIDynTy expected ty + -- Note [Foreign import dynamic] + -- In the example below, expected would be 'CInt -> IO ()', while ty would + -- be 'FunPtr (CDouble -> IO ())'. + | Just (tc, [ty']) <- splitTyConApp_maybe ty + , tyConUnique tc `elem` [ptrTyConKey, funPtrTyConKey] + , eqType ty' expected + = IsValid + | otherwise + = NotValid (ForeignDynNotPtr expected ty) + +isFFILabelTy :: Type -> Validity' IllegalForeignTypeReason +-- The type of a foreign label must be Ptr, FunPtr, or a newtype of either. +isFFILabelTy ty = checkRepTyCon ok ty + where + ok tc | tc `hasKey` funPtrTyConKey || tc `hasKey` ptrTyConKey + = IsValid + | otherwise + = NotValid ForeignLabelNotAPtr + +-- | Check validity for a type of the form @Any :: k@. +-- +-- This function returns: +-- +-- - @Just IsValid@ for @Any :: Type@ and @Any :: UnliftedType@, +-- - @Just (NotValid ..)@ for @Any :: k@ if @k@ is not a kind of boxed types, +-- - @Nothing@ if the type is not @Any@. +checkAnyTy :: Type -> Maybe (Validity' IllegalForeignTypeReason) +checkAnyTy ty + | Just ki <- anyTy_maybe ty + = Just $ + if isJust $ kindBoxedRepLevity_maybe ki + then IsValid + -- NB: don't allow things like @Any :: TYPE IntRep@, as per #21305. + else NotValid (TypeCannotBeMarshaled ty NotBoxedKindAny) + | otherwise + = Nothing + +isFFIPrimArgumentTy :: DynFlags -> Type -> Validity' IllegalForeignTypeReason +-- Checks for valid argument type for a 'foreign import prim' +-- Currently they must all be simple unlifted types, or Any (at kind Type or UnliftedType), +-- which can be used to pass the address to a Haskell object on the heap to +-- the foreign function. +isFFIPrimArgumentTy dflags ty + | Just validity <- checkAnyTy ty + = validity + | otherwise + = checkRepTyCon (legalFIPrimArgTyCon dflags) ty + +isFFIPrimResultTy :: DynFlags -> Type -> Validity' IllegalForeignTypeReason +-- Checks for valid result type for a 'foreign import prim' Currently +-- it must be an unlifted type, including unboxed tuples, unboxed +-- sums, or the well-known type Any (at kind Type or UnliftedType). +isFFIPrimResultTy dflags ty + | Just validity <- checkAnyTy ty + = validity + | otherwise + = checkRepTyCon (legalFIPrimResultTyCon dflags) ty + +isFunPtrTy :: Type -> Bool +isFunPtrTy ty + | Just (tc, [_]) <- splitTyConApp_maybe ty + = tc `hasKey` funPtrTyConKey + | otherwise + = False + +-- normaliseFfiType gets run before checkRepTyCon, so we don't +-- need to worry about looking through newtypes or type functions +-- here; that's already been taken care of. +checkRepTyCon + :: (TyCon -> Validity' TypeCannotBeMarshaledReason) + -> Type + -> Validity' IllegalForeignTypeReason +checkRepTyCon check_tc ty + = fmap (TypeCannotBeMarshaled ty) $ case splitTyConApp_maybe ty of + Just (tc, tys) + | isNewTyCon tc -> NotValid (mk_nt_reason tc tys) + | otherwise -> check_tc tc + Nothing -> NotValid NotADataType + where + mk_nt_reason tc tys = NewtypeDataConNotInScope tc tys + +{- +Note [Foreign import dynamic] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +A dynamic stub must be of the form 'FunPtr ft -> ft' where ft is any foreign +type. Similarly, a wrapper stub must be of the form 'ft -> IO (FunPtr ft)'. + +We use isFFIDynTy to check whether a signature is well-formed. For example, +given a (illegal) declaration like: + +foreign import ccall "dynamic" + foo :: FunPtr (CDouble -> IO ()) -> CInt -> IO () + +isFFIDynTy will compare the 'FunPtr' type 'CDouble -> IO ()' with the curried +result type 'CInt -> IO ()', and return False, as they are not equal. + + +---------------------------------------------- +These chaps do the work; they are not exported +---------------------------------------------- +-} + +legalFEArgTyCon :: TyCon -> Validity' TypeCannotBeMarshaledReason +legalFEArgTyCon tc + -- It's illegal to make foreign exports that take unboxed + -- arguments. The RTS API currently can't invoke such things. --SDM 7/2000 + = boxedMarshalableTyCon tc + +legalFIResultTyCon :: DynFlags -> TyCon -> Validity' TypeCannotBeMarshaledReason +legalFIResultTyCon dflags tc + | tc == unitTyCon = IsValid + | otherwise = marshalableTyCon dflags tc + +legalFEResultTyCon :: TyCon -> Validity' TypeCannotBeMarshaledReason +legalFEResultTyCon tc + | tc == unitTyCon = IsValid + | otherwise = boxedMarshalableTyCon tc + +legalOutgoingTyCon :: DynFlags -> Safety -> TyCon -> Validity' TypeCannotBeMarshaledReason +-- Checks validity of types going from Haskell -> external world +legalOutgoingTyCon dflags _ tc + = marshalableTyCon dflags tc + +-- Check for marshalability of a primitive type. +-- We exclude lifted types such as RealWorld and TYPE. +-- They can technically appear in types, e.g. +-- f :: RealWorld -> TYPE LiftedRep -> RealWorld +-- f x _ = x +-- but there are no values of type RealWorld or TYPE LiftedRep, +-- so it doesn't make sense to use them in FFI. +marshalablePrimTyCon :: TyCon -> Bool +marshalablePrimTyCon tc = isPrimTyCon tc && not (isLiftedTypeKind (tyConResKind tc)) + +marshalableTyCon :: DynFlags -> TyCon -> Validity' TypeCannotBeMarshaledReason +marshalableTyCon dflags tc + | marshalablePrimTyCon tc + = validIfUnliftedFFITypes dflags + | otherwise + = boxedMarshalableTyCon tc + +boxedMarshalableTyCon :: TyCon -> Validity' TypeCannotBeMarshaledReason +boxedMarshalableTyCon tc + | anyOfUnique tc [ intTyConKey, int8TyConKey, int16TyConKey + , int32TyConKey, int64TyConKey + , wordTyConKey, word8TyConKey, word16TyConKey + , word32TyConKey, word64TyConKey + , floatTyConKey, doubleTyConKey + , ptrTyConKey, funPtrTyConKey + , charTyConKey + , stablePtrTyConKey + , boolTyConKey + , jsvalTyConKey + ] + = IsValid + + | otherwise = NotValid NotABoxedMarshalableTyCon + +legalFIPrimArgTyCon :: DynFlags -> TyCon -> Validity' TypeCannotBeMarshaledReason +-- Check args of 'foreign import prim', only allow simple unlifted types. +legalFIPrimArgTyCon dflags tc + | marshalablePrimTyCon tc + = validIfUnliftedFFITypes dflags + | otherwise + = NotValid NotSimpleUnliftedType + +legalFIPrimResultTyCon :: DynFlags -> TyCon -> Validity' TypeCannotBeMarshaledReason +-- Check result type of 'foreign import prim'. Allow simple unlifted +-- types and also unboxed tuple and sum result types. +legalFIPrimResultTyCon dflags tc + | marshalablePrimTyCon tc + = validIfUnliftedFFITypes dflags + + | isUnboxedTupleTyCon tc || isUnboxedSumTyCon tc + = validIfUnliftedFFITypes dflags + + | otherwise + = NotValid $ NotSimpleUnliftedType + +validIfUnliftedFFITypes :: DynFlags -> Validity' TypeCannotBeMarshaledReason +validIfUnliftedFFITypes dflags + | xopt LangExt.UnliftedFFITypes dflags = IsValid + | otherwise = NotValid UnliftedFFITypesNeeded 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,1490 +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, lookupParents, fieldNotInType - , notSelector, nonBidirectionalErr - - , addHeadCtxt, addExprCtxt, addFunResCtxt ) where - -import {-# SOURCE #-} GHC.Tc.Gen.Expr( tcExpr, tcCheckMonoExprNC, tcCheckPolyExprNC ) - -import GHC.Prelude -import GHC.Hs - -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.Unit.Module ( getModule ) -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.Hs.Syn.Type - -import GHC.Core.FamInstEnv ( FamInstEnvs ) -import GHC.Core.UsageEnv ( unitUE ) -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.Session -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 - - --- For an ambiguous record field, find all the candidate record --- selectors (as GlobalRdrElts) and their parents. -lookupParents :: Bool -> RdrName -> RnM [(RecSelParent, GlobalRdrElt)] -lookupParents is_selector rdr - = do { env <- getGlobalRdrEnv - -- Filter by isRecFldGRE because otherwise a non-selector variable with - -- an overlapping name can get through when NoFieldSelectors is enabled. - -- See Note [NoFieldSelectors] in GHC.Rename.Env. - ; let all_gres = lookupGRE_RdrName' rdr env - ; let gres | is_selector = filter isFieldSelectorGRE all_gres - | otherwise = filter isRecFldGRE all_gres - ; mapM lookupParent gres } - where - lookupParent :: GlobalRdrElt -> RnM (RecSelParent, GlobalRdrElt) - lookupParent gre = do { id <- tcLookupId (greMangledName gre) - ; case recordSelectorTyCon_maybe id of - Just rstc -> return (rstc, gre) - Nothing -> failWithTc (notSelector (greMangledName gre)) } - - -fieldNotInType :: RecSelParent -> RdrName -> TcRnMessage -fieldNotInType p rdr - = mkTcRnNotInScope rdr $ - UnknownSubordinate (text "field of type" <+> quotes (ppr p)) - -notSelector :: Name -> TcRnMessage -notSelector = TcRnNotARecordSelector - - -{- ********************************************************************* -* * - 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 <- 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)) - dflags <- getDynFlags - rdr_env <- getGlobalRdrEnv - lcl_env <- getLocalRdrEnv - imp_info <- getImports - curr_mod <- getModule - hpt <- getHpt - return $ unknownNameSuggestions WL_Anything dflags hpt curr_mod rdr_env - lcl_env imp_info (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 $ unitUE (idName id) OneTy } - -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.Utils.Zonk.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) (TcRnSplicePolymorphicLocalVar 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 - = addLandmarkErrCtxtM (\env -> (env, ) <$> mk_msg) thing_inside - -- NB: use a landmark error context, so that an empty context - -- doesn't suppress some more useful context - where - mk_msg - = 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 { dumping <- doptM Opt_D_dump_tc_trace - ; massert dumping - ; newFlexiTyVarTy liftedTypeKind } - ; 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,4438 +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.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.Utils.Zonk -import GHC.Tc.Utils.TcType -import GHC.Tc.Utils.Instantiate ( tcInstInvisibleTyBinders, tcInstInvisibleTyBindersN, - tcInstInvisibleTyBinder, tcSkolemiseInvisibleBndrs, - tcInstTypeBndrs ) - -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.Session -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 ( find, 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 block unification (Note [Equalities with incompatible kinds] in --- TcCanonical) 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 <- 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 (mk_doc 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 - mk_doc exp_kind tidy_env - = do { (tidy_env2, exp_kind) <- zonkTidyTcType tidy_env exp_kind - ; return (tidy_env2, hang (text "The kind" <+> ppr exp_kind) - 2 (text "of type signature:" <+> ppr 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 - - ; ze <- mkEmptyZonkEnv NoFlexi - ; final_ty <- zonkTcTypeToTypeX ze (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 <- 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 <- 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' <- 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 (tcl_env 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 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 <- 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 - = 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 (LHsType GhcRn) (LHsKind GhcRn)] - -> (LHsType GhcRn, - [HsArg (LHsType GhcRn) (LHsKind GhcRn)]) -- AZ temp - go (L _ (HsAppTy _ f a)) as = go f (HsValArg a : as) - go (L _ (HsAppKindTy l ty k)) as = go ty (HsTypeArg l 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 _ Inferred) -> instantiate ki_binder inner_ki - Anon _ af | isInvisibleFunArg af -> instantiate ki_binder 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 - | isInvisiblePiTyBinder ki_binder -- FunTy with constraint on LHS; - -- or ForAllTy with Inferred or Specified - -> instantiate ki_binder 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' <- 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 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' <- zonkTcType arg - ; args' <- zonkTcTypes 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 - 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.Canonical. - -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 l arg : args) - = appTypeToArg (mkHsAppKindTy l 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 <- uType 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 $$ ppr (dc_theta_illegal_constraint theta)) - ; case dc_theta_illegal_constraint theta of - Just pred -> promotionErr name $ - ConstrainedDataConPE pred - Nothing -> pure () - ; let tc = promoteDataCon dc - ; return (mkTyConApp tc [], tyConKind tc) } - - APromotionErr err -> promotionErr name err - - _ -> wrongThingErr "type" thing name } - where - -- We cannot promote a data constructor with a context that contains - -- constraints other than equalities, so error if we find one. - -- See Note [Constraints in kinds] in GHC.Core.TyCo.Rep - dc_theta_illegal_constraint :: ThetaType -> Maybe PredType - dc_theta_illegal_constraint = find (not . isEqPred) - -{- -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 either * or #. 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 * or # 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.Utils.Zonk. - - 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-specified kind (CUSK)? -data SAKS_or_CUSK - = SAKS Kind -- Standalone kind signature, fully zonked! (zonkTcTypeToType) - | CUSK -- Complete user-specified 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 -- ^ 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 -- ^ 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 -- ^ 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_tvs, 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 ++ tc_tvs - 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 <- mapM zonkTyCoVarKind scoped_kvs -- scoped_kvs and tc_tvs are skolems, - ; tc_tvs <- mapM zonkTyCoVarKind tc_tvs -- so zonkTyCoVarKind suffices - ; res_kind <- zonkTcType 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 (mkRequiredTyConBinder mentioned_kv_set) tc_tvs - - -- 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 ++ tc_tvs) - final_tcbs = all_tcbs `chkAppend` eta_tcbs - tycon = mkTcTyCon name final_tcbs res_kind all_tv_prs - True -- it is 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 tc_tvs - , 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 - --- | 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 -- ^ 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_tvs }) 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 { (scoped_kvs, (tc_tvs, 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_tvs $ - 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_binders = mkAnonTyConBinders tc_tvs - -- Also, note that tc_binders has the tyvars from only the - -- user-written tyvarbinders. See S1 in Note [How TcTyCons work] - -- in GHC.Tc.TyCl - -- - -- mkAnonTyConBinder: see Note [No polymorphic recursion] - - 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 -- not yet generalised - flav - - ; traceTc "kcInferDeclHeader: not-cusk" $ - vcat [ ppr name, ppr kv_ns, ppr hs_tvs - , ppr scoped_kvs - , ppr tc_tvs, ppr (mkTyConKind tc_binders res_kind) ] - ; return tycon } - where - ctxt_kind | tcFlavourIsOpen flav = TheKind liftedTypeKind - | otherwise = AnyKind - --- | 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 -- ^ 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 ] - - ; (tclvl, wanted, (implicit_tvs, (skol_tcbs, (extra_tcbs, tycon_res_kind)))) - <- pushLevelAndSolveEqualitiesX "kcCheckDeclHeader_sig" $ -- #16687 - bindImplicitTKBndrs_Q_Tv implicit_nms $ -- Q means don't clone - matchUpSigWithDecl 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. - ; implicit_tvs <- zonkTcTyVarsToTcTyVars implicit_tvs - ; let implicit_prs = implicit_nms `zip` implicit_tvs - ; checkForDuplicateScopedTyVars implicit_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 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 - :: [TcTyConBinder] -- TcTyConBinders (with skolem TcTyVars) from the separate kind signature - -> TcKind -- The tail end of the kind signature - -> [LHsTyVarBndr () 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 - , a ) --- See Note [Matching a kind signature with a declaration] --- Invariant: Length of returned TyConBinders + length of excess TyConBinders --- = length of incoming TyConBinders -matchUpSigWithDecl 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 - | Bndr tv vis <- tcb - , isVisibleTcbVis vis - , (L _ hs_bndr : hs_bndrs') <- hs_bndrs -- hs_bndrs is non-empty - = -- Visible TyConBinder, so match up with the hs_bndrs - do { let 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 hs_bndr (tyVarKind tv') - ; (tcbs', res) <- tcExtendTyVarEnv [tv'] $ - go subst' tcbs' hs_bndrs' - ; return (Bndr tv' vis : tcbs', res) } - - | otherwise - = -- Invisible TyConBinder, so do not consume one of the hs_bndrs - do { let (subst', tcb') = substTyConBinderX subst tcb - ; (tcbs', 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', res) } - - tc_hs_bndr :: HsTyVarBndr () 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 - ; discardResult $ -- See Note [discardResult in kcCheckDeclHeader_sig] - unifyKind (Just (NameThing hs_nm)) sig_kind expected_kind } - -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 () 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 [No polymorphic recursion] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Should this kind-check? - data T ka (a::ka) b = MkT (T Type Int Bool) - (T (Type -> Type) Maybe Bool) - -Notice that T is used at two different kinds in its RHS. No! -This should not kind-check. Polymorphic recursion is known to -be a tough nut. - -Previously, we laboriously (with help from the renamer) -tried to give T the polymorphic kind - T :: forall ka -> ka -> kappa -> Type -where kappa is a unification variable, even in the inferInitialKinds -phase (which is what kcInferDeclHeader is all about). But -that is dangerously fragile (see the ticket). - -Solution: make kcInferDeclHeader give T a straightforward -monomorphic kind, with no quantification whatsoever. That's why -we use mkAnonTyConBinder for all arguments when figuring out -tc_binders. - -But notice that (#16322 comment:3) - -* The algorithm successfully kind-checks this declaration: - data T2 ka (a::ka) = MkT2 (T2 Type a) - - Starting with (inferInitialKinds) - T2 :: (kappa1 :: kappa2 :: *) -> (kappa3 :: kappa4 :: *) -> * - we get - kappa4 := kappa1 -- from the (a:ka) kind signature - kappa1 := Type -- From application T2 Type - - These constraints are soluble so generaliseTcTyCon gives - T2 :: forall (k::Type) -> k -> * - - But now the /typechecking/ (aka desugaring, tcTyClDecl) phase - fails, because the call (T2 Type a) in the RHS is ill-kinded. - - We'd really prefer all errors to show up in the kind checking - phase. - -* This algorithm still accepts (in all phases) - data T3 ka (a::ka) = forall b. MkT3 (T3 Type b) - although T3 is really polymorphic-recursive too. - Perhaps we should somehow reject that. - -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 -> [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 --- E.g. data SameKind (a::k) (b::k) --- data T (a::k1) (b::k2) c = MkT (SameKind a b) c --- Here k1 and k2 start as TyVarTvs, and get unified with each other --- If this happens, things get very confused later, so fail fast --- --- In the CUSK case k1 and k2 are skolems so they won't unify; --- but in the inference case (see generaliseTcTyCon), --- and the type-sig case (see kcCheckDeclHeader_sig), they are --- TcTyVars, so we must check. -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 [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 - => 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 - => 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 - => 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 - => 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 - => 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) - => SkolemInfo - -> [LHsTyVarBndr flag GhcRn] - -> TcM a - -> TcM ([VarBndr TyVar flag], a) - -bindExplicitTKBndrs_Tv - :: (OutputableBndrFlag flag 'Renamed) - => [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 - :: SkolemInfo - -> ContextKind - -> [LHsTyVarBndr () GhcRn] - -> TcM a - -> TcM ([TcTyVar], a) - -bindExplicitTKBndrs_Q_Tv - :: ContextKind - -> [LHsTyVarBndr () GhcRn] - -> TcM a - -> TcM ([TcTyVar], a) --- These do not clone: see Note [Cloning for type variable binders] -bindExplicitTKBndrs_Q_Skol skol_info ctxt_kind hs_bndrs thing_inside - = mapFst binderVars $ - 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 - = mapFst binderVars $ - 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) - => 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 :: HasCallStack => 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 { ze <- mkEmptyZonkEnv NoFlexi - ; (ze, bndrs) <- zonkTyVarBindersX ze tc_bndrs - ; kind <- zonkTcTypeToTypeX ze tc_kind - ; thing_inside bndrs kind } - - -{- ********************************************************************* -* * - Kind generalisation -* * -********************************************************************* -} - -zonkAndScopedSort :: [TcTyVar] -> TcM [TcTyVar] -zonkAndScopedSort spec_tkvs - = do { spec_tkvs <- 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 - ; dvs <- filterConstrainedCandidates wanted dvs - ; quantifyTyVars skol_info DefaultNonStandardTyVars 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 <- 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 -> 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 -> 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 - ; uniqs <- newUniqueSupply - ; 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 - new_uniqs = uniqsFromSupply uniqs - 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') - -> go occs' uniqs' subst' (tcb : acc) kind' - where - tcb = Bndr tv (AnonTCB af) - 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 -> AnonTCB af : 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 <- mapSndM zonkInvisTVBinder (tv_prs ++ tv_prs') - ; theta <- mapM zonkTcType (theta ++ theta') - ; tau <- zonkTcType 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 <- 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 <- 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 -> 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,14 +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 ) 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 @@ -54,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 @@ -69,118 +74,130 @@ import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Utils.Misc -import GHC.Driver.Session ( 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 {- ********************************************************************* * * @@ -188,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') } {- ************************************************************************ @@ -303,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 @@ -314,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 @@ -333,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 + } + {- ************************************************************************ * * @@ -348,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 @@ -364,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 @@ -389,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' $ @@ -400,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' $ @@ -451,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 @@ -462,39 +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 +-- 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 { (pairs', thing) <- loop bndr_stmts_s + = 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 :: [([LStmt GhcRn], [GhcRn])] - -- -> TcM ([([LStmt GhcTc], [GhcTc])], thing) - loop [] = do { thing <- thing_inside elt_ty - ; return ([], thing) } -- matching in the branches - - loop (ParStmtBlock x stmts names _ : pairs) + 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 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) <- loop pairs + ; (pairs', thing) <- setLocalRdrEnv origEnv $ + 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 @@ -732,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 @@ -787,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) } @@ -808,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) $ @@ -829,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) @@ -849,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 @@ -877,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 @@ -901,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 }) @@ -914,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) @@ -926,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 () @@ -954,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) @@ -979,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 isIrrefutableHsPat dflags pat + is_strict <- xoptM LangExt.Strict + comps <- getCompleteMatchesTcM + if isIrrefutableHsPat is_strict (irrefutableConLikeTc comps) pat then return Nothing else Just . snd <$> (tcSyntaxOp orig fail_op [synKnownType stringTy] (mkCheckExpType res_ty) $ \_ _ -> return ()) @@ -1012,10 +1145,25 @@ <$> :: (pat_ty_1 -> ... -> pat_ty_n -> body_ty) -> exp_ty_1 -> t_1 <*>_i :: t_(i-1) -> exp_ty_i -> t_i join :: tn -> res_ty + +Note [Scoping in parallel list comprehensions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In a parallel list comprehension like [ ebody | a <- blah1; e1 | b <- blah2; e2 ] +we want to ensure that in the lexical environment, tcl_rdr :: LocalRdrEnv, we have + * 'a' in scope in e1, but not 'b' + * 'b' in scope in e2, but not 'a' + * Both in scope in ebody +We don't want too /many/ variables in the LocalRdrEnv, else we make stupid +suggestions for an out-of-scope variable (#22940). + +To achieve this we: + * At the start of each branch, reset the LocalRdrEnv to the outer scope. + * Before typechecking ebody, add to LocalRdrEnv all the variables bound in + all branches. This step is done with bindLocalNames. -} tcApplicativeStmts - :: HsStmtContext GhcTc + :: HsStmtContextRn -> [(SyntaxExpr GhcRn, ApplicativeArg GhcRn)] -> ExpRhoType -- rhs_ty -> (TcRhoType -> TcM t) -- thing_inside @@ -1024,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 @@ -1067,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 () @@ -1131,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,20 +19,19 @@ , 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 import GHC.Rename.Utils import GHC.Tc.Errors.Types -import GHC.Tc.Utils.Zonk import GHC.Tc.Gen.Sig( TcPragEnv, lookupPragEnv, addInlinePrags ) import GHC.Tc.Utils.Monad import GHC.Tc.Utils.Instantiate @@ -44,7 +44,7 @@ import GHC.Tc.Utils.Concrete ( hasFixedRuntimeRep_syntactic ) import GHC.Tc.Utils.Env import GHC.Tc.Utils.TcMType -import GHC.Tc.Validity( arityErr ) +import GHC.Tc.Zonk.TcType import GHC.Core.TyCo.Ppr ( pprTyVars ) import GHC.Tc.Utils.TcType import GHC.Tc.Utils.Unify @@ -60,13 +60,12 @@ import GHC.Core.ConLike import GHC.Builtin.Names import GHC.Types.Basic hiding (SuccessFlag(..)) -import GHC.Driver.Session +import GHC.Driver.DynFlags import GHC.Types.SrcLoc import GHC.Types.Var.Set 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 @@ -74,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 {- ************************************************************************ @@ -99,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 @@ -154,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 @@ -170,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] @@ -231,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 @@ -326,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 @@ -357,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) @@ -373,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 @@ -403,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)) @@ -427,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 @@ -459,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 @@ -479,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 @@ -512,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 @@ -596,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 @@ -621,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] @@ -649,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') @@ -693,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. @@ -703,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) } @@ -781,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) } {- ********************************************************************* * * @@ -862,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 @@ -925,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 @@ -949,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 @@ -975,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)) @@ -983,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 @@ -1012,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] @@ -1027,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' @@ -1059,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" @@ -1067,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' @@ -1087,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 @@ -1113,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.Canonical.canClassNC 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 @@ -1321,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 - (arityErr (text "constructor") 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 - (arityErr (text "constructor") 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, @@ -1383,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 -> @@ -1585,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,506 +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.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) - <- 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.Utils.Zonk.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 don't_default = nonDefaultableTyVarsOfWC residual_lhs_wanted - ; let weed_out = (`dVarSetMinusVarSet` don't_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 "don't_default:" <+> ppr don't_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 --- 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 - ; setTcLevel tc_lvl $ - discardResult $ - runTcS $ - do { _ <- solveWanteds lhs_clone - ; _ <- solveWanteds rhs_clone - -- Why do them separately? - -- See Note [Solve order for RULES] - ; return () } - - -- Note [The SimplifyRule Plan] step 2 - ; lhs_wanted <- 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 - ] - - ; return (quant_evs, residual_lhs_wanted) } - - 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.Interact 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,884 +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.Session -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.Utils.Zonk -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 *. - ; ze <- mkEmptyZonkEnv NoFlexi - ; (ze, kv_bndrs) <- zonkTyVarBindersX ze (mkTyVarBinders InferredSpec kvs) - ; (ze, implicit_bndrs) <- zonkTyVarBindersX ze implicit_bndrs - ; (ze, univ_bndrs) <- zonkTyVarBindersX ze univ_bndrs - ; (ze, ex_bndrs) <- zonkTyVarBindersX ze ex_bndrs - ; req <- zonkTcTypesToTypesX ze req - ; prov <- zonkTcTypesToTypesX ze prov - ; body_ty <- zonkTcTypeToTypeX ze 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 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 = 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, @@ -34,7 +43,7 @@ import GHC.Driver.Errors import GHC.Driver.Plugins import GHC.Driver.Main -import GHC.Driver.Session +import GHC.Driver.DynFlags import GHC.Driver.Env import GHC.Driver.Hooks import GHC.Driver.Config.Diagnostic @@ -49,8 +58,10 @@ import GHC.Tc.Utils.Unify import GHC.Tc.Utils.Env import GHC.Tc.Types.Origin +import GHC.Tc.Types.LclEnv import GHC.Tc.Types.Evidence -import GHC.Tc.Utils.Zonk +import GHC.Tc.Zonk.Type +import GHC.Tc.Zonk.TcType import GHC.Tc.Solver import GHC.Tc.Utils.TcMType import GHC.Tc.Gen.HsType @@ -79,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 ) @@ -92,7 +103,6 @@ import GHC.Core.ConLike import GHC.Core.DataCon as DataCon -import GHC.Types.FieldLabel import GHC.Types.SrcLoc import GHC.Types.Name.Env import GHC.Types.Name.Set @@ -115,37 +125,40 @@ 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 Language.Haskell.Syntax.Basic (FieldLabelString(..)) -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 import Data.Binary.Get -import Data.List ( find ) import Data.Maybe import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as LB @@ -155,6 +168,7 @@ import Data.Typeable ( typeOf, Typeable, TypeRep, typeRep ) import Data.Data (Data) import Data.Proxy ( Proxy (..) ) +import Data.IORef import GHC.Parser.HaddockLex (lexHsDoc) import GHC.Parser (parseIdentifier) import GHC.Rename.Doc (rnHsDoc) @@ -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,40 +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 - = do { unless (isTauTy exp_ty) $ addErr (TcRnTypedTHWithPolyType 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) @@ -815,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 @@ -847,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)) } @@ -871,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) @@ -886,43 +1024,17 @@ 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) runTopSplice (DelayedSplice lcl_env orig_expr res_ty q_expr) = restoreLclEnv lcl_env $ - do { zonked_ty <- zonkTcType res_ty + do { zonked_ty <- liftZonkM $ zonkTcType res_ty ; zonked_q_expr <- zonkTopLExpr q_expr -- 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 @@ -938,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 @@ -954,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 (char '$' <> 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") {- @@ -1001,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')) }) @@ -1033,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 @@ -1058,6 +1155,7 @@ withForeignRefs (x : xs) f = withForeignRef x $ \r -> withForeignRefs xs $ \rs -> f (r : rs) interp <- tcGetInterp + case interpInstance interp of #if defined(HAVE_INTERNAL_INTERPRETER) InternalInterp -> do @@ -1065,30 +1163,32 @@ runQuasi $ sequence_ qs #endif - ExternalInterp conf iserv -> withIServ_ conf iserv $ \i -> do + ExternalInterp ext -> withExtInterp ext $ \inst -> do tcg <- getGblEnv th_state <- readTcRef (tcg_th_remote_state tcg) case th_state of Nothing -> return () -- TH was not started, nothing to do Just fhv -> do - liftIO $ withForeignRef fhv $ \st -> + r <- liftIO $ withForeignRef fhv $ \st -> withForeignRefs finRefs $ \qrefs -> - writeIServ i (putMessage (RunModFinalizers st qrefs)) - () <- runRemoteTH i [] - readQResult i + sendMessageDelayedResponse inst (RunModFinalizers st qrefs) + () <- runRemoteTH inst [] + qr <- liftIO $ receiveDelayedResponse inst r + checkQResult qr 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) } ----------------- @@ -1187,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 @@ -1250,7 +1348,8 @@ -- see where this splice is do { mb_result <- run_and_convert expr_span hval ; case mb_result of - Left err -> failWithTc (TcRnRunSpliceFailure Nothing err) + Left err -> failWithTc $ + TcRnTHError $ THSpliceFailed $ RunSpliceFailure err Right result -> do { traceTc "Got HsSyn result:" (ppr_hs result) ; return $! result } } @@ -1265,8 +1364,8 @@ fail_with_exn :: Exception e => SplicePhase -> e -> TcM a fail_with_exn phase exn = do exn_msg <- liftIO $ Panic.safeShowException exn - failWithTc - $ TcRnSpliceThrewException phase (SomeException exn) exn_msg expr show_code + failWithTc $ TcRnTHError $ THSpliceFailed $ + SpliceThrewException phase (toException exn) exn_msg expr show_code {- Note [Running typed splices in the zonker] @@ -1382,8 +1481,8 @@ -- 'msg' is forced to ensure exceptions don't escape, -- see Note [Exceptions in TH] - qReport True msg = seqList msg $ addErr $ TcRnReportCustomQuasiError True msg - qReport False msg = seqList msg $ addDiagnostic $ TcRnReportCustomQuasiError False msg + qReport True msg = seqList msg $ addErr $ TcRnTHError $ ReportCustomQuasiError True msg + qReport False msg = seqList msg $ addDiagnostic $ TcRnTHError $ ReportCustomQuasiError False msg qLocation :: TcM TH.Loc qLocation = do { m <- getModule @@ -1432,12 +1531,13 @@ 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 - $ TcRnRunSpliceFailure (Just "addTopDecls") exn + Left exn -> failWithTc $ TcRnTHError $ AddTopDeclsError $ + AddTopDeclsRunSpliceFailure exn Right ds -> return ds mapM_ (checkTopDecl . unLoc) ds th_topdecls_var <- fmap tcg_th_topdecls getGblEnv @@ -1453,7 +1553,7 @@ checkTopDecl (ForD _ (ForeignImport { fd_name = L _ name })) = bindName name checkTopDecl d - = addErr $ TcRnInvalidTopDecl d + = addErr $ TcRnTHError $ AddTopDeclsError $ InvalidTopDecl d bindName :: RdrName -> TcM () bindName (Exact n) @@ -1461,7 +1561,7 @@ ; updTcRef th_topnames_var (\ns -> extendNameSet ns n) } - bindName name = addErr $ TcRnNonExactName name + bindName name = addErr $ TcRnTHError $ THNameError $ NonExactName name qAddForeignFilePath lang fp = do var <- fmap tcg_th_foreign_files getGblEnv @@ -1479,7 +1579,7 @@ let dflags = hsc_dflags hsc_env let fopts = initFinderOpts dflags r <- liftIO $ findHomeModule fc fopts home_unit (mkModuleName plugin) - let err = TcRnAddInvalidCorePlugin plugin + let err = TcRnTHError $ AddInvalidCorePlugin plugin case r of Found {} -> addErr err FoundMultiple {} -> addErr err @@ -1507,7 +1607,7 @@ th_doc_var <- tcg_th_docs <$> getGblEnv resolved_doc_loc <- resolve_loc doc_loc is_local <- checkLocalName resolved_doc_loc - unless is_local $ failWithTc $ TcRnAddDocToNonLocalDefn doc_loc + unless is_local $ failWithTc $ TcRnTHError $ AddDocToNonLocalDefn doc_loc let ds = mkGeneratedHsDocString s hd = lexHsDoc parseIdentifier ds hd' <- rnHsDoc hd @@ -1546,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 @@ -1562,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 @@ -1591,7 +1693,7 @@ Right (_, []) -> noMatches where noMatches = failWithTc $ - TcRnFailedToLookupThInstName th_type NoMatchesFound + TcRnTHError $ FailedToLookupThInstName th_type NoMatchesFound -- Get the name of the class for the instance we are documenting -- > inst_cls_name (Monad Maybe) == Monad @@ -1628,7 +1730,7 @@ inst_cls_name (TH.ImplicitParamT _ _) = inst_cls_name_err inst_cls_name_err = failWithTc $ - TcRnFailedToLookupThInstName th_type CouldNotDetermineInstance + TcRnTHError $ FailedToLookupThInstName th_type CouldNotDetermineInstance -- Basically does the opposite of 'mkThAppTs' -- > inst_arg_types (Monad Maybe) == [Maybe] @@ -1643,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 () @@ -1691,37 +1793,40 @@ return r #endif - ExternalInterp conf iserv -> + ExternalInterp ext -> withExtInterp ext $ \inst -> do -- Run it on the server. For an overview of how TH works with -- Remote GHCi, see Note [Remote Template Haskell] in -- libraries/ghci/GHCi/TH.hs. - withIServ_ conf iserv $ \i -> do - rstate <- getTHState i - loc <- TH.qLocation - liftIO $ - withForeignRef rstate $ \state_hv -> - withForeignRef fhv $ \q_hv -> - writeIServ i (putMessage (RunTH state_hv q_hv ty (Just loc))) - runRemoteTH i [] - bs <- readQResult i - return $! runGet get (LB.fromStrict bs) + rstate <- getTHState inst + loc <- TH.qLocation + -- run a remote TH request + r <- liftIO $ + withForeignRef rstate $ \state_hv -> + withForeignRef fhv $ \q_hv -> + sendMessageDelayedResponse inst (RunTH state_hv q_hv ty (Just loc)) + -- respond to requests from the interpreter + runRemoteTH inst [] + -- get the final result + qr <- liftIO $ receiveDelayedResponse inst r + bs <- checkQResult qr + return $! runGet get (LB.fromStrict bs) -- | communicate with a remotely-running TH computation until it finishes. -- See Note [Remote Template Haskell] in libraries/ghci/GHCi/TH.hs. runRemoteTH - :: IServInstance + :: ExtInterpInstance d -> [Messages TcRnMessage] -- saved from nested calls to qRecover -> TcM () -runRemoteTH iserv recovers = do - THMsg msg <- liftIO $ readIServ iserv getTHMessage +runRemoteTH inst recovers = do + THMsg msg <- liftIO $ receiveTHMessage inst case msg of RunTHDone -> return () StartRecover -> do -- Note [TH recover with -fexternal-interpreter] v <- getErrsVar msgs <- readTcRef v writeTcRef v emptyMessages - runRemoteTH iserv (msgs : recovers) + runRemoteTH inst (msgs : recovers) EndRecover caught_error -> do let (prev_msgs, rest) = case recovers of [] -> panic "EndRecover" @@ -1732,16 +1837,15 @@ writeTcRef v $ if caught_error then prev_msgs else mkMessages warn_msgs `unionMessages` prev_msgs - runRemoteTH iserv rest + runRemoteTH inst rest _other -> do r <- handleTHMessage msg - liftIO $ writeIServ iserv (put r) - runRemoteTH iserv recovers + liftIO $ sendAnyValue inst r + runRemoteTH inst recovers --- | Read a value of type QResult from the iserv -readQResult :: Binary a => IServInstance -> TcM a -readQResult i = do - qr <- liftIO $ readIServ i get +-- | Check a QResult +checkQResult :: QResult a -> TcM a +checkQResult qr = case qr of QDone a -> return a QException str -> liftIO $ throwIO (ErrorCall str) @@ -1788,17 +1892,18 @@ -- -- The TH state is stored in tcg_th_remote_state in the TcGblEnv. -- -getTHState :: IServInstance -> TcM (ForeignRef (IORef QState)) -getTHState i = do - tcg <- getGblEnv - th_state <- readTcRef (tcg_th_remote_state tcg) - case th_state of - Just rhv -> return rhv - Nothing -> do - interp <- tcGetInterp - fhv <- liftIO $ mkFinalizedHValue interp =<< iservCall i StartTH - writeTcRef (tcg_th_remote_state tcg) (Just fhv) - return fhv +getTHState :: ExtInterpInstance d -> TcM (ForeignRef (IORef QState)) +getTHState inst = do + th_state_var <- tcg_th_remote_state <$> getGblEnv + liftIO $ do + th_state <- readIORef th_state_var + case th_state of + Just rhv -> return rhv + Nothing -> do + rref <- sendMessage inst StartTH + fhv <- mkForeignRef rref (freeReallyRemoteRef inst rref) + writeIORef th_state_var (Just fhv) + return fhv wrapTHResult :: TcM a -> TcM (THResult a) wrapTHResult tcm = do @@ -1870,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 @@ -1910,20 +2015,20 @@ -> 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 ; traceTc "reifyInstances'2" (ppr matches) ; return $ Right (tc, map fim_instance matches) } - _ -> bale_out $ TcRnCannotReifyInstance ty } + _ -> 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 - Left msg -> failWithTc (TcRnRunSpliceFailure Nothing msg) + 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 {- @@ -1939,7 +2044,7 @@ -> String -> TcM (Maybe TH.Name) lookupName is_type_name s = do { mb_nm <- lookupOccRn_maybe rdr_name - ; return (fmap reifyName mb_nm) } + ; return (fmap (reifyName . greName) mb_nm) } where th_name = TH.mkName s -- Parses M.x into a base of 'x' and a module of 'M' @@ -1954,6 +2059,12 @@ | otherwise = if isLexCon occ_fs then mkDataOccFS occ_fs else mkVarOccFS occ_fs + -- NB: when we pick the variable namespace, we + -- might well obtain an identifier in a record + -- field namespace, as lookupOccRn_maybe looks in + -- record field namespaces when looking up variables. + -- This ensures we can look up record fields using + -- this function (#24293). rdr_name = case TH.nameModule th_name of Nothing -> mkRdrUnqual occ @@ -1964,8 +2075,7 @@ getThSpliceOrigin :: TcM Origin getThSpliceOrigin = do warn <- goptM Opt_EnableThSpliceWarnings - if warn then return FromSource else return Generated - + if warn then return FromSource else return (Generated OtherExpansion SkipPmc) getThing :: TH.Name -> TcM TcTyThing getThing th_name @@ -1975,9 +2085,10 @@ -- ToDo: this tcLookup could fail, which would give a -- rather unhelpful error message where - ppr_ns (TH.Name _ (TH.NameG TH.DataName _pkg _mod)) = text "data" - ppr_ns (TH.Name _ (TH.NameG TH.TcClsName _pkg _mod)) = text "tc" - ppr_ns (TH.Name _ (TH.NameG TH.VarName _pkg _mod)) = text "var" + ppr_ns (TH.Name _ (TH.NameG TH.DataName _pkg _mod)) = text "data" + ppr_ns (TH.Name _ (TH.NameG TH.TcClsName _pkg _mod)) = text "tc" + ppr_ns (TH.Name _ (TH.NameG TH.VarName _pkg _mod)) = text "var" + ppr_ns (TH.Name _ (TH.NameG (TH.FldName {}) _pkg _mod)) = text "fld" ppr_ns _ = panic "reify/ppr_ns" reify :: TH.Name -> TcM TH.Info @@ -1996,10 +2107,15 @@ lookupThName_maybe :: TH.Name -> TcM (Maybe Name) lookupThName_maybe th_name - = do { names <- mapMaybeM lookupOccRn_maybe (thRdrNameGuesses th_name) + = do { listTuplePuns <- xoptM LangExt.ListTuplePuns + ; let guesses = thRdrNameGuesses listTuplePuns th_name + ; case guesses of + { [for_sure] -> lookupSameOccRn_maybe for_sure + ; _ -> + do { gres <- mapMaybeM lookupOccRn_maybe guesses -- Pick the first that works -- E.g. reify (mkName "A") will pick the class A in preference to the data constructor A - ; return (listToMaybe names) } + ; return (fmap greName $ listToMaybe gres) } } } tcLookupTh :: Name -> TcM TcTyThing -- This is a specialised version of GHC.Tc.Utils.Env.tcLookup; specialised mainly in that @@ -2007,7 +2123,7 @@ -- tcLookup, failure is a bug. tcLookupTh name = do { (gbl_env, lcl_env) <- getEnvs - ; case lookupNameEnv (tcl_env lcl_env) name of { + ; case lookupNameEnv (getLclEnvTypeEnv lcl_env) name of { Just thing -> return thing; Nothing -> @@ -2024,15 +2140,15 @@ do { mb_thing <- tcLookupImported_maybe name ; case mb_thing of Succeeded thing -> return (AGlobal thing) - Failed msg -> failWithTc (TcRnInterfaceLookupError name msg) + Failed msg -> failWithTc (TcRnInterfaceError msg) }}}} notInScope :: TH.Name -> TcRnMessage notInScope th_name = - TcRnCannotReifyOutOfScopeThing th_name + TcRnTHError $ THReifyError $ CannotReifyOutOfScopeThing th_name notInEnv :: Name -> TcRnMessage -notInEnv name = TcRnCannotReifyThingNotInTypeEnv name +notInEnv name = TcRnTHError $ THReifyError $ CannotReifyThingNotInTypeEnv name ------------------------------ reifyRoles :: TH.Name -> TcM [TH.Role] @@ -2040,7 +2156,8 @@ = do { thing <- getThing th_name ; case thing of AGlobal (ATyCon tc) -> return (map reify_role (tyConRoles tc)) - _ -> failWithTc (TcRnNoRolesAssociatedWithThing thing) + _ -> failWithTc $ TcRnTHError $ THReifyError $ + NoRolesAssociatedWithThing thing } where reify_role Nominal = TH.NominalR @@ -2057,10 +2174,8 @@ = do { ty <- reifyType (idType id) ; let v = reifyName id ; case idDetails id of - ClassOpId cls -> return (TH.ClassOpI v ty (reifyName cls)) - RecSelId{sel_tycon=RecSelData tc} - -> return (TH.VarI (reifySelector id tc) ty Nothing) - _ -> return (TH.VarI v ty Nothing) + ClassOpId cls _ -> return (TH.ClassOpI v ty (reifyName cls)) + _ -> return (TH.VarI v ty Nothing) } reifyThing (AGlobal (ATyCon tc)) = reifyTyCon tc @@ -2073,13 +2188,13 @@ ; return (TH.PatSynI name ty) } reifyThing (ATcId {tct_id = id}) - = do { ty1 <- zonkTcType (idType id) -- Make use of all the info we have, even + = do { ty1 <- liftZonkM $ zonkTcType (idType id) -- Make use of all the info we have, even -- though it may be incomplete ; ty2 <- reifyType ty1 ; return (TH.VarI (reifyName id) ty2 Nothing) } reifyThing (ATyVar tv tv1) - = do { ty1 <- zonkTcTyVar tv1 + = do { ty1 <- liftZonkM $ zonkTcTyVar tv1 ; ty2 <- reifyType ty1 ; return (TH.TyVarI (reifyName tv) ty2) } @@ -2135,7 +2250,7 @@ injRHS = map (reifyName . tyVarName) (filterByList ms tvs) in (sig, inj) - ; tvs' <- reifyTyVars (tyConVisibleTyVars tc) + ; tvs' <- reifyTyConBinders tc ; let tfHead = TH.TypeFamilyHead (reifyName tc) tvs' resultSig injectivity ; if isOpenTypeFamilyTyCon tc @@ -2156,7 +2271,7 @@ ; kind' <- fmap Just (reifyKind res_kind) - ; tvs' <- reifyTyVars (tyConVisibleTyVars tc) + ; tvs' <- reifyTyConBinders tc ; fam_envs <- tcGetFamInstEnvs ; instances <- reifyFamilyInstances tc (familyInstances fam_envs tc) ; return (TH.FamilyI @@ -2164,7 +2279,7 @@ | Just (_, rhs) <- synTyConDefn_maybe tc -- Vanilla type synonym = do { rhs' <- reifyType rhs - ; tvs' <- reifyTyVars (tyConVisibleTyVars tc) + ; tvs' <- reifyTyConBinders tc ; return (TH.TyConI (TH.TySynD (reifyName tc) tvs' rhs')) } @@ -2182,7 +2297,7 @@ dataCons = tyConDataCons tc isGadt = isGadtSyntaxTyCon tc ; cons <- mapM (reifyDataCon isGadt (mkTyVarTys tvs)) dataCons - ; r_tvs <- reifyTyVars (tyConVisibleTyVars tc) + ; r_tvs <- reifyTyConBinders tc ; let name = reifyName tc deriv = [] -- Don't know about deriving decl | isTypeDataTyCon tc = @@ -2232,7 +2347,7 @@ | not (null fields) -> do { res_ty <- reifyType g_res_ty ; return $ TH.RecGadtC [name] - (zip3 (map (reifyName . flSelector) fields) + (zip3 (map reifyFieldLabel fields) dcdBangs r_arg_tys) res_ty } -- We need to check not isGadtDataCon here because GADT -- constructors can be declared infix. @@ -2244,7 +2359,8 @@ ; return $ TH.InfixC (s1,r_a1) name (s2,r_a2) } | isGadtDataCon -> do { res_ty <- reifyType g_res_ty - ; return $ TH.GadtC [name] (dcdBangs `zip` r_arg_tys) res_ty } + ; return $ TH.GadtC [name] + (dcdBangs `zip` r_arg_tys) res_ty } | otherwise -> return $ TH.NormalC name (dcdBangs `zip` r_arg_tys) @@ -2255,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 @@ -2310,7 +2434,7 @@ ; insts <- reifyClassInstances cls (InstEnv.classInstances inst_envs cls) ; assocTys <- concatMapM reifyAT ats ; ops <- concatMapM reify_op op_stuff - ; tvs' <- reifyTyVars (tyConVisibleTyVars (classTyCon cls)) + ; tvs' <- reifyTyConBinders (classTyCon cls) ; let dec = TH.ClassD cxt (reifyName cls) tvs' fds' (assocTys ++ ops) ; return (TH.ClassI dec insts) } where @@ -2502,6 +2626,7 @@ Overlapping _ -> Just TH.Overlapping Overlaps _ -> Just TH.Overlaps Incoherent _ -> Just TH.Incoherent + NonCanonical _ -> Just TH.Incoherent ------------------------------ reifyFamilyInstances :: TyCon -> [FamInst] -> TcM [TH.Dec] @@ -2654,6 +2779,43 @@ reifyFlag SpecifiedSpec = TH.SpecifiedSpec reifyFlag InferredSpec = TH.InferredSpec +instance ReifyFlag TyConBndrVis (Maybe TH.BndrVis) where + reifyFlag AnonTCB = Just TH.BndrReq + reifyFlag (NamedTCB Required) = Just TH.BndrReq + reifyFlag (NamedTCB (Invisible _)) = + Nothing -- See Note [Reifying invisible type variable binders] and #22828. + +-- Currently does not return invisible type variable binders (@k-binders). +-- See Note [Reifying invisible type variable binders] and #22828. +reifyTyConBinders :: TyCon -> TcM [TH.TyVarBndr TH.BndrVis] +reifyTyConBinders tc = fmap (mapMaybe get_bndr) (reifyTyVarBndrs (tyConBinders tc)) + where + get_bndr :: TH.TyVarBndr (Maybe flag) -> Maybe (TH.TyVarBndr flag) + get_bndr = sequenceA + +{- Note [Reifying invisible type variable binders] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In reifyFlag for TyConBndrVis, we have the following clause: + + reifyFlag (NamedTCB (Invisible _)) = Nothing + +This means that reifyTyConBinders doesn't reify invisible type variables as +@k-binders. However, it is possible (and not hard) to change this. +Just replace the above clause with: + + reifyFlag (NamedTCB Specified) = Just TH.BndrInvis + reifyFlag (NamedTCB Inferred) = Nothing -- Inferred variables can not be bound + +There are two reasons we opt not to do that for now. + 1. It would be a (sometimes silent) breaking change affecting th-abstraction, + aeson, and other libraries that assume that reified binders are visible. + 2. It would create an asymmetry with visible kind applications, which are + not reified either. + +This decision is not set in stone. If a use case for reifying invisible type +variable binders presents itself, we can reconsider. See #22828. +-} + reifyTyVars :: [TyVar] -> TcM [TH.TyVarBndr ()] reifyTyVars = reifyTyVarBndrs . map mk_bndr where @@ -2734,26 +2896,12 @@ mk_varg | OccName.isDataOcc occ = TH.mkNameG_d | OccName.isVarOcc occ = TH.mkNameG_v | OccName.isTcOcc occ = TH.mkNameG_tc + | Just con_fs <- OccName.fieldOcc_maybe occ + = \ pkg mod occ -> TH.mkNameG_fld pkg mod (unpackFS con_fs) occ | otherwise = pprPanic "reifyName" (ppr name) --- See Note [Reifying field labels] reifyFieldLabel :: FieldLabel -> TH.Name -reifyFieldLabel fl - | flIsOverloaded fl - = TH.Name (TH.mkOccName occ_str) (TH.NameQ (TH.mkModName mod_str)) - | otherwise = TH.mkNameG_v pkg_str mod_str occ_str - where - name = flSelector fl - mod = assert (isExternalName name) $ nameModule name - pkg_str = unitString (moduleUnit mod) - mod_str = moduleNameString (moduleName mod) - occ_str = unpackFS (field_label $ flLabel fl) - -reifySelector :: Id -> TyCon -> TH.Name -reifySelector id tc - = case find ((idName id ==) . flSelector) (tyConFieldLabels tc) of - Just fl -> reifyFieldLabel fl - Nothing -> pprPanic "reifySelector: missing field" (ppr id $$ ppr tc) +reifyFieldLabel fl = reifyName $ flSelector fl ------------------------------ reifyFixity :: Name -> TcM (Maybe TH.Fixity) @@ -2761,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 @@ -2795,8 +2943,8 @@ reifyType (idType (dataConWrapId dc)) AGlobal (AConLike (PatSynCon ps)) -> reifyPatSynType (patSynSigBndr ps) - ATcId{tct_id = id} -> zonkTcType (idType id) >>= reifyType - ATyVar _ tctv -> zonkTcTyVar tctv >>= reifyType + ATcId{tct_id = id} -> liftZonkM (zonkTcType (idType id)) >>= reifyType + ATyVar _ tctv -> liftZonkM (zonkTcTyVar tctv) >>= reifyType -- Impossible cases, supposedly: AGlobal (ACoAxiom _) -> panic "reifyTypeOfThing: ACoAxiom" ATcTyCon _ -> panic "reifyTypeOfThing: ATcTyCon" @@ -2831,59 +2979,24 @@ 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 noTH :: UnrepresentableTypeDescr -> Type -> TcM a -noTH s d = failWithTc $ TcRnCannotRepresentType s d - -ppr_th :: TH.Ppr a => a -> SDoc -ppr_th x = text (TH.pprint x) - -{- -Note [Reifying field labels] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When reifying a datatype declared with DuplicateRecordFields enabled, we want -the reified names of the fields to be labels rather than selector functions. -That is, we want (reify ''T) and (reify 'foo) to produce - - data T = MkT { foo :: Int } - foo :: T -> Int - -rather than - - data T = MkT { $sel:foo:MkT :: Int } - $sel:foo:MkT :: T -> Int - -because otherwise TH code that uses the field names as strings will silently do -the wrong thing. Thus we use the field label (e.g. foo) as the OccName, rather -than the selector (e.g. $sel:foo:MkT). Since the Orig name M.foo isn't in the -environment, NameG can't be used to represent such fields. Instead, -reifyFieldLabel uses NameQ. - -However, this means that extracting the field name from the output of reify, and -trying to reify it again, may fail with an ambiguity error if there are multiple -such fields defined in the module (see the test case -overloadedrecflds/should_fail/T11103.hs). The "proper" fix requires changes to -the TH AST to make it able to represent duplicate record fields. --} +noTH s d = failWithTc $ TcRnTHError $ THReifyError $ CannotRepresentType s d tcGetInterp :: TcM Interp tcGetInterp = do @@ -2891,3 +3004,120 @@ case hsc_interp hsc_env of Nothing -> liftIO $ throwIO (InstallationError "Template haskell requires a target code interpreter") Just i -> pure i + +-- Note [Bootstrapping Template Haskell] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- Staged Metaprogramming as implemented in Template Haskell introduces a whole +-- new dimension of staging to the already staged bootstrapping process. +-- While users depend on the user-facing `template-haskell` library, the TH +-- interface (all wired-in identifiers) is defined in `ghc-internal` and for +-- bootstrapping purposes, re-exported from `ghc-boot-th`. +-- +-- Nomenclature: +-- +-- boot/stage0 compiler: An already released compiler used to compile GHC +-- stage(N+1) compiler: The result of compiling GHC from source with stage(N) +-- Recall that any code compiled by the stage1 compiler should be binary +-- identical to the same code compiled by later stages. +-- boot `ghc-boot-th`: the `ghc-boot-th` that comes with (and is linked to) the +-- boot/stage0 compiler +-- in-tree `ghc-boot-th`: the `ghc-boot-th` library that lives in GHC's repository. +-- +-- Here is how we bootstrap TH in tandem with GHC: +-- +-- 1. Build the stage1 compiler with the boot compiler. +-- The latter comes with its own boot `ghc-boot-th` library, but we do not import it. +-- 2. Instead, the stage1 compiler depends on the in-tree `ghc-boot-th`. +-- * To avoid clashes with the boot `ghc-boot-th`, we change its +-- package-id `ghc-boot-th-next`. +-- * There is a bit of CPP to vendor the stage1 TH AST defined in +-- `ghc-internal`, which we cannot build with the boot compiler. +-- 3. Build `ghc-internal` and in-tree `ghc-boot-th` with the stage1 compiler. +-- From here on `ghc-boot-th` re-exposes the TH modules from `ghc-internal`. +-- 4. Build and link the stage2 compiler against the in-tree `ghc-boot-th`. +-- NB: No dependency on `ghc-boot-th-next`. +-- +-- Observations: +-- +-- A. The vendoring in (2) means that the fully qualified name of the in-tree TH +-- AST will be, e.g., `ghc-boot-th-next:...VarE`, not `ghc-internal:...VarE`. +-- That is OK, because we need it just for the `Binary` instance and to +-- convert TH ASTs returned by splices into the Hs AST, both of which do not +-- depend on the fully qualified name of the type to serialise! Importantly, +-- Note [Hard-wiring in-tree template-haskell for desugaring quotes] is +-- unaffected, because the desugaring refers to names in the in-tree TH +-- library, which is built in the next stage, stage1, and later. +-- +-- When we decided in favour of the current design, `template-haskell` +-- still contained the wired-in Ids that meanwhile were moved to +-- `ghc-internal`. +-- These were the (rejected) alternative designs back then: +-- +-- 1b. Build the in-tree TH with the stage0 compiler and link the stage1 compiler +-- against it. This is what we did until Apr 24 and it is problematic (#23536): +-- * (It rules out using TH in GHC, for example to derive GHC.Core.Map types, +-- because the boot compiler expects the boot TH AST in splices, but, e.g., +-- splice functions in GHC.Core.Map.TH would return the in-tree TH AST. +-- However, at the moment, we are not using TH in GHC anyway.) +-- * Ultimately, we must link the stage1 compiler against a +-- single version of template-haskell. +-- (Beyond the fact that doing otherwise would invite even +-- more "which `template-haskell` is this" confusion, it +-- would also result in confusing linker errors: see for +-- example #21981. In principle we could likely lift this +-- restriction with more aggressive name mangling, but the +-- knock-on effects of doing so are unexplored.) +-- * If the single version is the in-tree TH, we have to recompile all boot +-- libraries (e.g. bytestring, containers) with this new TH version. +-- * But the boot libraries must *not* be built against a non-boot TH version. +-- The reason is Note [Hard-wiring in-tree template-haskell for desugaring quotes]: +-- The boot compiler will desugar quotes wrt. names in the boot TH version. +-- A quote like `[| unsafePackLenLiteral |]` in bytestring will desugar +-- to `varE (mkNameS "unsafePackLenLiteral")`, and all +-- those smart constructors refer to locations in *boot TH*, because that +-- is all that the boot GHC knows about. +-- If the in-tree TH were to move or rename the definition of +-- `mkNameS`, the boot compiler would report a linker error when +-- compiling bytestring. +-- * (Stopping to use quotes in bytestring is no solution, either, because +-- the `Lift` type class is wired-in as well. +-- Only remaining option: provide an entirely TH-less variant of every +-- boot library. That would place a huge burden on maintainers and is +-- thus rejected.) +-- * We have thus made it impossible to refactor in-tree TH. +-- This problem was discussed in #23536. +-- 1c. Do not build the stage1 compiler against any library exposing the in-tree TH AST. +-- This is viable because no splices need to be run as part of the +-- bootstrapping process, so we could CPP away all the code in the stage1 +-- compiler that refers to template-haskell types. However, +-- * it is not so simple either: a surprising example is GHC.Tc.Errors.Types +-- where we would need to replace all TH types with dummy types. +-- (We *cannot* simply CPP away TH-specific error constructors because +-- that affects binary compatibility with the stage2 compiler.) +-- * we would still need to vendor the updated Extension enum, so even +-- though we had to use a lot of CPP, we still end up depending on names +-- that are not present in the stage2 compiler. +-- * this design would never allow us to use TH in GHC's code base, for +-- example in GHC.Core.Map. +-- It seems simpler just to depend on a template-haskell library in a fake +-- namespace. +-- 2b. Alternatively vendor the parts relevant to serialising +-- the (new, in-tree) TH AST into `ghc-boot`, thus shadowing definitions in the +-- implicitly linked boot TH. +-- * We found that this led to quite a bit of duplication in the +-- `ghc-boot` cabal file. + +-- Note [Hard-wiring in-tree template-haskell for desugaring quotes] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- To desugar Template Haskell quotes, GHC needs to wire in a bunch of Names in the +-- `ghc-internal` library as Note [Known-key names], in GHC.Builtin.Names.TH. +-- Consider +-- > foo :: Q Exp +-- > foo = [| unwords ["hello", "world"] |] +-- this desugars to Core that looks like this +-- > varE (mkNameS "unwords") `appE` listE [litE (stringE "hello"), litE (stringE "world")] +-- And all these smart constructors are known-key. +-- NB: Since the constructors are known-key, it is impossible to link this program +-- against another `ghc-internal` library in which, e.g., `varE` was moved into a +-- different module. So effectively, GHC is hard-wired against the in-tree +-- `ghc-internal` library. 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,18 +1,16 @@ - -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} +{-# LANGUAGE MultiWayIf #-} module GHC.Tc.Instance.Class ( - matchGlobalInst, + matchGlobalInst, matchEqualityInst, ClsInstResult(..), InstanceWhat(..), safeOverlap, instanceReturnsDictCon, AssocInstInfo(..), isNotAssociated, + lookupHasFieldLabel ) where import GHC.Prelude -import GHC.Driver.Session - -import GHC.Core.TyCo.Rep +import GHC.Driver.DynFlags import GHC.Tc.Utils.Env import GHC.Tc.Utils.Monad @@ -21,22 +19,28 @@ import GHC.Tc.Instance.Typeable import GHC.Tc.Utils.TcMType import GHC.Tc.Types.Evidence -import GHC.Tc.Instance.Family( tcGetFamInstEnvs, tcInstNewTyCon_maybe, tcLookupDataFamInst ) -import GHC.Rename.Env( addUsedGRE ) +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( lookupGRE_FieldLabel, greMangledName ) import GHC.Types.SafeHaskell -import GHC.Types.Name ( Name, pprDefinedAt ) +import GHC.Types.Name ( Name ) +import GHC.Types.Name.Reader import GHC.Types.Var.Env ( VarEnv ) import GHC.Types.Id -import GHC.Types.Id.Make ( nospecId ) +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, Type) ) +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 @@ -87,39 +99,20 @@ * * **********************************************************************-} --- | Indicates if Instance met the Safe Haskell overlapping instances safety --- check. --- --- See Note [Safe Haskell Overlapping Instances] in GHC.Tc.Solver --- See Note [Safe Haskell Overlapping Instances Implementation] in GHC.Tc.Solver -type SafeOverlapping = Bool - data ClsInstResult = NoInstance -- Definitely no instance - | OneInst { cir_new_theta :: [TcPredType] - , cir_mk_ev :: [EvExpr] -> EvTerm - , cir_what :: InstanceWhat } + | OneInst { cir_new_theta :: [TcPredType] + , cir_mk_ev :: [EvExpr] -> EvTerm + , 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 -data InstanceWhat -- How did we solve this constraint? - = BuiltinEqInstance -- Built-in solver for (t1 ~ t2), (t1 ~~ t2), Coercible t1 t2 - -- See GHC.Tc.Solver.InertSet Note [Solved dictionaries] - - | BuiltinTypeableInstance TyCon -- Built-in solver for Typeable (T t1 .. tn) - -- See Note [Well-staged instance evidence] - - | BuiltinInstance -- Built-in solver for (C t1 .. tn) where C is - -- KnownNat, .. etc (classes with no top-level evidence) - - | LocalInstance -- Solved by a quantified constraint - -- See GHC.Tc.Solver.InertSet Note [Solved dictionaries] - - | TopLevInstance -- Solved by a top-level instance decl - { iw_dfun_id :: DFunId - , iw_safe_over :: SafeOverlapping } - instance Outputable ClsInstResult where ppr NoInstance = text "NoInstance" ppr NotSure = text "NotSure" @@ -127,15 +120,6 @@ , cir_what = what }) = text "OneInst" <+> vcat [ppr ev, ppr what] -instance Outputable InstanceWhat where - ppr BuiltinInstance = text "a built-in instance" - ppr BuiltinTypeableInstance {} = text "a built-in typeable instance" - ppr BuiltinEqInstance = text "a built-in equality instance" - ppr LocalInstance = text "a locally-quantified instance" - ppr (TopLevInstance { iw_dfun_id = dfun }) - = hang (text "instance" <+> pprSigmaType (idType dfun)) - 2 (text "--" <+> pprDefinedAt (idName dfun)) - safeOverlap :: InstanceWhat -> Bool safeOverlap (TopLevInstance { iw_safe_over = so }) = so safeOverlap _ = True @@ -151,22 +135,29 @@ matchGlobalInst :: DynFlags -> Bool -- True <=> caller is the short-cut solver -- See Note [Shortcut solving: overlap] - -> Class -> [Type] -> TcM ClsInstResult -matchGlobalInst dflags short_cut clas tys - | 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 - | clas `hasKey` heqTyConKey = matchHeteroEquality tys - | clas `hasKey` eqTyConKey = matchHomoEquality tys - | clas `hasKey` coercibleTyConKey = matchCoercible tys - | cls_name == hasFieldClassName = matchHasField dflags short_cut clas tys - | otherwise = matchInstEnv dflags short_cut clas tys + -> 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 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 == 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 {- ******************************************************************** * * @@ -188,12 +179,12 @@ ; case (matches, unify, safeHaskFail) of -- Nothing matches - ([], NoUnifiers, _) + ([], NoUnifiers{}, _) -> do { traceTc "matchClass not matching" (ppr pred $$ ppr (ie_local instEnvs)) ; return NoInstance } -- A single match (& no safe haskell failure) - ([(ispec, inst_tys)], NoUnifiers, False) + ([(ispec, inst_tys)], NoUnifiers canonical, False) | short_cut_solver -- Called from the short-cut solver , isOverlappable ispec -- If the instance has OVERLAPPABLE or OVERLAPS or INCOHERENT @@ -205,12 +196,13 @@ | otherwise -> do { let dfun_id = instanceDFunId ispec + warn = instanceWarning ispec ; traceTc "matchClass success" $ - vcat [text "dict" <+> ppr pred, + 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) 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 @@ -221,17 +213,18 @@ where pred = mkClassPred clas tys -match_one :: SafeOverlapping -> DFunId -> [DFunInstType] -> TcM ClsInstResult - -- See Note [DFunInstType: instantiating types] in GHC.Core.InstEnv -match_one so 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) - ; return $ OneInst { cir_new_theta = theta - , cir_mk_ev = evDFunApp dfun_id tys - , cir_what = TopLevInstance { iw_dfun_id = dfun_id - , iw_safe_over = so } } } - + ; return $ OneInst { cir_new_theta = theta + , cir_mk_ev = evDFunApp dfun_id tys + , cir_canonical = canonical + , cir_what = TopLevInstance { iw_dfun_id = dfun_id + , iw_safe_over = so + , iw_warn = warn } } } {- Note [Shortcut solving: overlap] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -262,13 +255,11 @@ matchCTuple :: Class -> [Type] -> TcM ClsInstResult matchCTuple clas tys -- (isCTupleClass clas) holds - = return (OneInst { cir_new_theta = tys - , cir_mk_ev = tuple_ev - , cir_what = BuiltinInstance }) + = return (OneInst { cir_new_theta = tys + , 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 {- ******************************************************************** * * @@ -295,9 +286,10 @@ instance KnownNat 2 where natSing = SNat 2 ... -In practice, we solve `KnownNat` predicates in the type-checker -(see GHC.Tc.Solver.Interact) because we can't have infinitely many instances. -The evidence (aka "dictionary") for `KnownNat` is of the form `EvLit (EvNum n)`. +In practice, we solve `KnownNat` predicates in the type-checker (see +`matchKnownNat` in this module) because we can't have infinitely many +instances. The evidence (aka "dictionary") for `KnownNat` is of the +form `EvLit (EvNum n)`. We make the following assumptions about dictionaries in GHC: 1. The "dictionary" for classes with a single method---like `KnownNat`---is @@ -405,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 @@ -414,25 +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_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 @@ -441,50 +434,36 @@ -- 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) -> - -- nospec @(cls => a) k (sv |> (sub co ; sym co2)) - -- - -- 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 (WD6) in Note [withDict], and Note [nospecId magic] in GHC.Types.Id.Make. - ; let evWithDict co2 = - mkCoreLams [ runtimeRep1TyVar, openAlphaTyVar, sv, k ] $ - Var nospecId - `App` - (Type $ mkInvisFunTy cls openAlphaTy) - `App` - 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] - , cir_mk_ev = mk_ev - , cir_what = BuiltinInstance } + ; return $ OneInst { cir_new_theta = [mkNomEqPred mty (scaledThing inst_meth_ty)] + , cir_mk_ev = mk_ev + , cir_canonical = EvNonCanonical -- See (WD6) in Note [withDict] + , cir_what = BuiltinInstance } } matchWithDict _ @@ -534,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` @@ -587,12 +566,14 @@ (WD6) In fact, we desugar `withDict @cls @mty @{rr} @r` to \@(r :: RuntimeRep) @(a :: TYPE r) (sv :: mty) (k :: cls => a) -> - nospec @(cls => a) k (sv |> (sub co2 ; sym co))) + k (sv |> (sub co2 ; sym co))) - That is, we cast the method using a coercion, and apply k to it. - However, we use the 'nospec' magicId (see Note [nospecId magic] in GHC.Types.Id.Make) - to ensure that the typeclass specialiser doesn't incorrectly common-up distinct - evidence terms. This is super important! Suppose we have calls + That is, we cast the method using a coercion, and apply k to + it. Moreover, we mark the evidence as non-canonical, resulting in + the use of the 'nospec' magicId (see Note [nospecId magic] in + GHC.Types.Id.Make) to ensure that the typeclass specialiser + doesn't incorrectly common-up distinct evidence terms. This is + super important! Suppose we have calls withDict A k withDict B k @@ -629,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. -} {- ******************************************************************** @@ -672,14 +978,15 @@ -- | Representation for a type @ty@ of the form @arg -> ret@. doFunTy :: Class -> Type -> Mult -> Type -> Type -> TcM ClsInstResult doFunTy clas ty mult arg_ty ret_ty - = return $ OneInst { cir_new_theta = preds - , cir_mk_ev = mk_ev - , cir_what = BuiltinInstance } + = return $ OneInst { cir_new_theta = preds + , cir_mk_ev = mk_ev + , 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 _ = panic "GHC.Tc.Solver.Interact.doFunTy" + 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" -- | Representation for type constructor applied to some kinds. @@ -688,9 +995,10 @@ doTyConApp :: Class -> Type -> TyCon -> [Kind] -> TcM ClsInstResult doTyConApp clas ty tc kind_args | tyConIsTypeable tc - = return $ OneInst { cir_new_theta = map (mk_typeable_pred clas) kind_args - , cir_mk_ev = mk_ev - , cir_what = BuiltinTypeableInstance tc } + = return $ OneInst { cir_new_theta = map (mk_typeable_pred clas) kind_args + , cir_mk_ev = mk_ev + , cir_canonical = EvCanonical + , cir_what = BuiltinTypeableInstance tc } | otherwise = return NoInstance where @@ -719,9 +1027,10 @@ | isForAllTy (typeKind f) = return NoInstance -- We can't solve until we know the ctr. | otherwise - = return $ OneInst { cir_new_theta = map (mk_typeable_pred clas) [f, tk] - , cir_mk_ev = mk_ev - , cir_what = BuiltinInstance } + = return $ OneInst { cir_new_theta = map (mk_typeable_pred clas) [f, tk] + , cir_mk_ev = mk_ev + , cir_canonical = EvCanonical + , cir_what = BuiltinInstance } where mk_ev [t1,t2] = evTypeable ty $ EvTypeableTyApp (EvExpr t1) (EvExpr t2) mk_ev _ = panic "doTyApp" @@ -739,9 +1048,10 @@ ; let kc_pred = mkClassPred kc_clas [ t ] mk_ev [ev] = evTypeable t $ EvTypeableTyLit (EvExpr ev) mk_ev _ = panic "doTyLit" - ; return (OneInst { cir_new_theta = [kc_pred] - , cir_mk_ev = mk_ev - , cir_what = BuiltinInstance }) } + ; return (OneInst { cir_new_theta = [kc_pred] + , cir_mk_ev = mk_ev + , cir_canonical = EvCanonical + , cir_what = BuiltinInstance }) } {- Note [Typeable (T a b c)] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -827,91 +1137,68 @@ ***********************************************************************-} -- See also Note [The equality types story] in GHC.Builtin.Types.Prim -matchHeteroEquality :: [Type] -> TcM ClsInstResult --- Solves (t1 ~~ t2) -matchHeteroEquality args - = return (OneInst { cir_new_theta = [ mkTyConApp eqPrimTyCon args ] - , cir_mk_ev = evDataConApp heqDataCon args - , cir_what = BuiltinEqInstance }) +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 + = (Nominal, t1, t2) -matchHomoEquality :: [Type] -> TcM ClsInstResult --- Solves (t1 ~ t2) -matchHomoEquality args@[k,t1,t2] - = return (OneInst { cir_new_theta = [ mkTyConApp eqPrimTyCon [k,k,t1,t2] ] - , cir_mk_ev = evDataConApp eqDataCon args - , cir_what = BuiltinEqInstance }) -matchHomoEquality args = pprPanic "matchHomoEquality" (ppr args) + | cls `hasKey` heqTyConKey -- Solves (t1 ~~ t2) + , [_,_,t1,t2] <- args + = (Nominal, t1, t2) --- See also Note [The equality types story] in GHC.Builtin.Types.Prim -matchCoercible :: [Type] -> TcM ClsInstResult -matchCoercible args@[k, t1, t2] - = return (OneInst { cir_new_theta = [ mkTyConApp eqReprPrimTyCon args' ] - , cir_mk_ev = evDataConApp coercibleDataCon args - , cir_what = BuiltinEqInstance }) - where - args' = [k, k, t1, t2] -matchCoercible args = pprPanic "matchLiftedCoercible" (ppr args) + | cls `hasKey` coercibleTyConKey -- Solves (Coercible t1 t2) + , [_, t1, t2] <- args + = (Representational, t1, t2) + | otherwise -- Does not satisfy the precondition + = pprPanic "matchEqualityInst" (ppr (mkClassPred cls args)) + + {- ******************************************************************** * * Class lookup for overloaded record fields * * ***********************************************************************-} -{- -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] @@ -929,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 @@ -955,32 +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 True gre - ; keepAlive (greMangledName gre) - ; return OneInst { cir_new_theta = theta - , cir_mk_ev = mk_ev - , 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,12 +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, - newFamInst, + tcTopNormaliseNewTypeTF_maybe, -- * Injectivity reportInjectivityErrors, reportConflictingInjectivityErrs @@ -14,11 +13,10 @@ import GHC.Prelude -import GHC.Driver.Session +import GHC.Driver.DynFlags import GHC.Driver.Env import GHC.Core.FamInstEnv -import GHC.Core.InstEnv( roughMatchTcs ) import GHC.Core.Coercion import GHC.Core.TyCon import GHC.Core.Coercion.Axiom @@ -31,15 +29,12 @@ import GHC.Tc.Errors.Types import GHC.Tc.Types.Evidence import GHC.Tc.Utils.Monad -import GHC.Tc.Utils.Instantiate( freshenTyVarBndrs, freshenCoVarBndrsX ) import GHC.Tc.Utils.TcType 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 @@ -49,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 ) @@ -61,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] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -161,44 +156,6 @@ {- ************************************************************************ * * - Making a FamInst -* * -************************************************************************ --} - --- All type variables in a FamInst must be fresh. This function --- creates the fresh variables and applies the necessary substitution --- It is defined here to avoid a dependency from FamInstEnv on the monad --- code. - -newFamInst :: FamFlavor -> CoAxiom Unbranched -> TcM FamInst --- Freshen the type variables of the FamInst branches -newFamInst flavor axiom@(CoAxiom { co_ax_tc = fam_tc }) - = do { - -- Freshen the type variables - (subst, tvs') <- freshenTyVarBndrs tvs - ; (subst, cvs') <- freshenCoVarBndrsX subst cvs - ; let lhs' = substTys subst lhs - rhs' = substTy subst rhs - - ; return (FamInst { fi_fam = tyConName fam_tc - , fi_flavor = flavor - , fi_tcs = roughMatchTcs lhs - , fi_tvs = tvs' - , fi_cvs = cvs' - , fi_tys = lhs' - , fi_rhs = rhs' - , fi_axiom = axiom }) } - where - CoAxBranch { cab_tvs = tvs - , cab_cvs = cvs - , cab_lhs = lhs - , cab_rhs = rhs } = coAxiomSingleBranch axiom - - -{- -************************************************************************ -* * Optimised overlap checking for family instances * * ************************************************************************ @@ -230,9 +187,6 @@ indirectly), we check that they are consistent now. (So that we can be certain that the modules in our `GHC.Driver.Env.dep_finsts' are consistent.) -There is some fancy footwork regarding hs-boot module loops, see -Note [Don't check hs-boot type family instances too early] - Note [Checking family instance optimization] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ As explained in Note [Checking family instance consistency] @@ -284,11 +238,51 @@ 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. + -} --- This function doesn't check ALL instances for consistency, --- only ones that aren't involved in recursive knot-tying --- loops; see Note [Don't check hs-boot type family instances too early]. -- We don't need to check the current module, this is done in -- tcExtendLocalFamInstEnv. -- See Note [The type family instance consistency story]. @@ -298,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 @@ -342,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 @@ -350,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 @@ -391,68 +395,7 @@ sizeE2 = famInstEnvSize env2' (env1, env2) = if sizeE1 < sizeE2 then (env1', env2') else (env2', env1') - -- Note [Don't check hs-boot type family instances too early] - -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -- Family instance consistency checking involves checking that - -- the family instances of our imported modules are consistent with - -- one another; this might lead you to think that this process - -- has nothing to do with the module we are about to typecheck. - -- Not so! Consider the following case: - -- - -- -- A.hs-boot - -- type family F a - -- - -- -- B.hs - -- import {-# SOURCE #-} A - -- type instance F Int = Bool - -- - -- -- A.hs - -- import B - -- type family F a - -- - -- When typechecking A, we are NOT allowed to poke the TyThing - -- for F until we have typechecked the family. Thus, we - -- can't do consistency checking for the instance in B - -- (checkFamInstConsistency is called during renaming). - -- Failing to defer the consistency check lead to #11062. - -- - -- Additionally, we should also defer consistency checking when - -- type from the hs-boot file of the current module occurs on - -- the left hand side, as we will poke its TyThing when checking - -- for overlap. - -- - -- -- F.hs - -- type family F a - -- - -- -- A.hs-boot - -- import F - -- data T - -- - -- -- B.hs - -- import {-# SOURCE #-} A - -- import F - -- type instance F T = Int - -- - -- -- A.hs - -- import B - -- data T = MkT - -- - -- In fact, it is even necessary to defer for occurrences in - -- the RHS, because we may test for *compatibility* in event - -- of an overlap. - -- - -- Why don't we defer ALL of the checks to later? Well, many - -- instances aren't involved in the recursive loop at all. So - -- we might as well check them immediately; and there isn't - -- a good time to check them later in any case: every time - -- we finish kind-checking a type declaration and add it to - -- a context, we *then* consistency check all of the instances - -- which mentioned that type. We DO want to check instances - -- as quickly as possible, so that we aren't typechecking - -- values with inconsistent axioms in scope. - -- - -- See also Note [Tying the knot] - -- for why we are doing this at all. + ; let check_now = famInstEnvElts env1 ; mapM_ (checkForConflicts (emptyFamInstEnv, env2)) check_now ; mapM_ (checkForInjectivityConflicts (emptyFamInstEnv,env2)) check_now @@ -463,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" @@ -477,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 @@ -512,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 @@ -35,24 +34,23 @@ import GHC.Core.InstEnv import GHC.Core.TyCo.FVs import GHC.Core.TyCo.Compare( eqTypes, eqType ) -import GHC.Core.TyCo.Ppr( pprWithExplicitKindsWhen ) +import GHC.Tc.Errors.Types ( CoverageProblem(..), FailedCoverageCondition(..) ) +import GHC.Tc.Types.Constraint ( isUnsatisfiableCt_maybe ) import GHC.Tc.Utils.TcType( transSuperClasses ) import GHC.Types.Var.Set import GHC.Types.Var.Env -import GHC.Types.SrcLoc import GHC.Utils.Outputable import GHC.Utils.FV -import GHC.Utils.Error( Validity'(..), Validity, allValid ) +import GHC.Utils.Error( Validity'(..), allValid ) import GHC.Utils.Misc import GHC.Utils.Panic -import GHC.Data.Pair ( Pair(..) ) -import Data.List ( nubBy ) -import Data.Maybe -import Data.Foldable ( fold ) +import GHC.Data.Pair ( Pair(..) ) +import Data.List ( nubBy ) +import Data.Maybe ( isJust, isNothing ) {- ************************************************************************ @@ -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 @@ -392,7 +379,7 @@ checkInstCoverage :: Bool -- Be liberal -> Class -> [PredType] -> [Type] - -> Validity + -> Validity' CoverageProblem -- "be_liberal" flag says whether to use "liberal" coverage of -- See Note [Coverage condition] below -- @@ -401,12 +388,23 @@ -- Just msg => coverage problem described by msg checkInstCoverage be_liberal clas theta inst_taus + | any (isJust . isUnsatisfiableCt_maybe) theta + -- As per [GHC proposal #433](https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0433-unsatisfiable.rst), + -- we skip checking the coverage condition if there is an "Unsatisfiable" + -- constraint in the instance context. + -- + -- See Note [Implementation of Unsatisfiable constraints] in GHC.Tc.Errors, + -- point (E). + = IsValid + | otherwise = allValid (map fundep_ok fds) where (tyvars, fds) = classTvsFds clas fundep_ok fd - | and (isEmptyVarSet <$> undetermined_tvs) = IsValid - | otherwise = NotValid msg + | all isEmptyVarSet undetermined_tvs + = IsValid + | otherwise + = NotValid not_covered_msg where (ls,rs) = instFD fd tyvars inst_taus ls_tvs = tyCoVarsOfTypes ls @@ -419,33 +417,18 @@ liberal_undet_tvs = (`minusVarSet` closed_ls_tvs) <$> rs_tvs conserv_undet_tvs = (`minusVarSet` ls_tvs) <$> rs_tvs - undet_set = fold undetermined_tvs + not_covered_msg = + CoverageProblem + { not_covered_fundep = fd + , not_covered_fundep_inst = (ls, rs) + , not_covered_invis_vis_tvs = undetermined_tvs + , not_covered_liberal = + if be_liberal + then FailedLICC + else FailedICC + { alsoFailedLICC = not $ all isEmptyVarSet liberal_undet_tvs } + } - msg = pprWithExplicitKindsWhen - (isEmptyVarSet $ pSnd undetermined_tvs) $ - vcat [ -- text "ls_tvs" <+> ppr ls_tvs - -- , text "closed ls_tvs" <+> ppr (closeOverKinds ls_tvs) - -- , text "theta" <+> ppr theta - -- , text "closeWrtFunDeps" <+> ppr (closeWrtFunDeps theta (closeOverKinds ls_tvs)) - -- , text "rs_tvs" <+> ppr rs_tvs - sep [ text "The" - <+> ppWhen be_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) - , ppWhen (not be_liberal && - and (isEmptyVarSet <$> liberal_undet_tvs)) $ - text "Using UndecidableInstances might help" ] {- Note [Closing over kinds in coverage] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -531,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] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -595,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. +-} {- ********************************************************************* * * @@ -669,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 @@ -35,11 +35,9 @@ import GHC.Core.DataCon import GHC.Unit.Module import GHC.Hs -import GHC.Driver.Session -import GHC.Data.Bag +import GHC.Driver.DynFlags 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 @@ -94,7 +92,7 @@ interface file to find its type, value, etc 4. Solve Typeable constraints. This is done by a custom Typeable solver, - currently in GHC.Tc.Solver.Interact, that use M.$tcT so solve (Typeable T). + currently in GHC.Tc.Instance.Class, that use M.$tcT so solve (Typeable T). There are many wrinkles: @@ -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,3235 +1,3334 @@ {-# LANGUAGE CPP #-} -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NondecreasingIndentation #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE MultiWayIf #-} -{-# LANGUAGE TupleSections #-} - -{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} - -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 - --} - --- | Typechecking a whole module --- --- https://gitlab.haskell.org/ghc/ghc/wikis/commentary/compiler/type-checker -module GHC.Tc.Module ( - tcRnStmt, tcRnExpr, TcRnExprMode(..), tcRnType, - tcRnImportDecls, - tcRnLookupRdrName, - getModuleInterface, - tcRnDeclsi, - isGHCiMonad, - runTcInteractive, -- Used by GHC API clients (#8878) - withTcPlugins, -- Used by GHC API clients (#20499) - withHoleFitPlugins, -- Used by GHC API clients (#20499) - tcRnLookupName, - tcRnGetInfo, - tcRnModule, tcRnModuleTcRnM, - tcTopSrcDecls, - rnTopSrcDecls, - checkBootDecl, checkHiBootIface', - findExtraSigImports, - implicitRequirements, - checkUnit, - mergeSignatures, - tcRnMergeSignatures, - instantiateSignature, - tcRnInstantiateSignature, - loadUnqualIfaces, - -- More private... - badReexportedBootThing, - checkBootDeclM, - missingBootThing, - getRenamedStuff, RenamedStuff - ) where - -import GHC.Prelude - -import GHC.Driver.Env -import GHC.Driver.Plugins -import GHC.Driver.Session -import GHC.Driver.Config.Diagnostic - -import GHC.Tc.Errors.Hole.FitTypes ( HoleFitPluginR (..) ) -import GHC.Tc.Errors.Types -import {-# SOURCE #-} GHC.Tc.Gen.Splice ( finishTH, runRemoteModFinalizers ) -import GHC.Tc.Gen.HsType -import GHC.Tc.Validity( checkValidType ) -import GHC.Tc.Gen.Match -import GHC.Tc.Utils.Unify( checkConstraints, tcSubTypeSigma ) -import GHC.Tc.Utils.Zonk -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 -import GHC.Tc.Types.Constraint -import GHC.Tc.Types.Origin -import GHC.Tc.Instance.Family -import GHC.Tc.Gen.Annotation -import GHC.Tc.Gen.Bind -import GHC.Tc.Gen.Default -import GHC.Tc.Utils.Env -import GHC.Tc.Gen.Rule -import GHC.Tc.Gen.Foreign -import GHC.Tc.TyCl.Instance -import GHC.Tc.Utils.TcMType -import GHC.Tc.Utils.TcType -import GHC.Tc.Utils.Instantiate (tcGetInsts) -import GHC.Tc.Solver -import GHC.Tc.TyCl -import GHC.Tc.Instance.Typeable ( mkTypeableBinds ) -import GHC.Tc.Utils.Backpack - -import GHC.Rename.Splice ( rnTopSpliceDecls, traceSplice, SpliceInfo(..) ) -import GHC.Rename.HsType -import GHC.Rename.Expr -import GHC.Rename.Fixity ( lookupFixityRn ) -import GHC.Rename.Names -import GHC.Rename.Env -import GHC.Rename.Module -import GHC.Rename.Doc - -import GHC.Iface.Syntax ( ShowSub(..), showToHeader ) -import GHC.Iface.Type ( ShowForAllFlag(..) ) -import GHC.Iface.Env ( externaliseName ) -import GHC.Iface.Make ( coAxiomToIfaceDecl ) -import GHC.Iface.Load - -import GHC.Builtin.Types ( unitTy, mkListTy ) -import GHC.Builtin.Names -import GHC.Builtin.Utils - -import GHC.Hs -import GHC.Hs.Dump - -import GHC.Core.PatSyn ( pprPatSynType ) -import GHC.Core.Predicate ( classMethodTy ) -import GHC.Core.InstEnv -import GHC.Core.TyCon -import GHC.Core.ConLike -import GHC.Core.DataCon -import GHC.Core.Type -import GHC.Core.Class -import GHC.Core.Coercion.Axiom -import GHC.Core.Reduction ( Reduction(..) ) -import GHC.Core.RoughMap( RoughMatchTc(..) ) -import GHC.Core.TyCo.Ppr( debugPprType ) -import GHC.Core.FamInstEnv - ( FamInst, pprFamInst, famInstsRepTyCons, orphNamesOfFamInst - , famInstEnvElts, extendFamInstEnvList, normaliseType ) - -import GHC.Parser.Header ( mkPrelImports ) - -import GHC.IfaceToCore - -import GHC.Runtime.Context - -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.Fixity.Env -import GHC.Types.Id as Id -import GHC.Types.Id.Info( IdDetails(..) ) -import GHC.Types.Var.Env -import GHC.Types.TypeEnv -import GHC.Types.Unique.FM -import GHC.Types.Name -import GHC.Types.Name.Env -import GHC.Types.Name.Set -import GHC.Types.Avail -import GHC.Types.Basic hiding( SuccessFlag(..) ) -import GHC.Types.Annotations -import GHC.Types.SrcLoc -import GHC.Types.SourceFile -import GHC.Types.TyThing.Ppr ( pprTyThingInContext ) -import GHC.Types.PkgQual -import qualified GHC.LanguageExtensions as LangExt - -import GHC.Unit.External -import GHC.Unit.Types -import GHC.Unit.State -import GHC.Unit.Home -import GHC.Unit.Module -import GHC.Unit.Module.Warnings -import GHC.Unit.Module.ModSummary -import GHC.Unit.Module.ModIface -import GHC.Unit.Module.ModDetails -import GHC.Unit.Module.Deps - -import GHC.Data.FastString -import GHC.Data.Maybe -import GHC.Data.List.SetOps -import GHC.Data.Bag -import qualified GHC.Data.BooleanFormula as BF - -import Data.Functor.Classes ( liftEq ) -import Data.List ( sortBy, sort ) -import Data.List.NonEmpty ( NonEmpty (..) ) -import qualified Data.List.NonEmpty as NE -import Data.Ord -import Data.Data ( Data ) -import qualified Data.Set as S -import Control.DeepSeq -import Control.Monad - -{- -************************************************************************ -* * - Typecheck and rename a module -* * -************************************************************************ --} - --- | Top level entry point for typechecker and renamer -tcRnModule :: HscEnv - -> ModSummary - -> Bool -- True <=> save renamed syntax - -> HsParsedModule - -> IO (Messages TcRnMessage, Maybe TcGblEnv) - -tcRnModule hsc_env mod_sum save_rn_syntax - parsedModule@HsParsedModule {hpm_module= L loc this_module} - | RealSrcSpan real_loc _ <- loc - = withTiming logger - (text "Renamer/typechecker"<+>brackets (ppr this_mod)) - (const ()) $ - initTc hsc_env hsc_src save_rn_syntax this_mod real_loc $ - withTcPlugins hsc_env $ - withDefaultingPlugins hsc_env $ - withHoleFitPlugins hsc_env $ - - tcRnModuleTcRnM hsc_env mod_sum parsedModule pair - - | otherwise - = return (err_msg `addMessage` emptyMessages, Nothing) - - where - hsc_src = ms_hsc_src mod_sum - logger = hsc_logger hsc_env - home_unit = hsc_home_unit hsc_env - err_msg = mkPlainErrorMsgEnvelope loc $ - TcRnModMissingRealSrcSpan this_mod - - pair :: (Module, SrcSpan) - pair@(this_mod,_) - | Just (L mod_loc mod) <- hsmodName this_module - = (mkHomeModule home_unit mod, locA mod_loc) - - | otherwise -- 'module M where' is omitted - = (mkHomeModule home_unit mAIN_NAME, srcLocSpan (srcSpanStart loc)) - - - - -tcRnModuleTcRnM :: HscEnv - -> ModSummary - -> HsParsedModule - -> (Module, SrcSpan) - -> TcRn TcGblEnv --- Factored out separately from tcRnModule so that a Core plugin can --- call the type checker directly -tcRnModuleTcRnM hsc_env mod_sum - (HsParsedModule { - hpm_module = - (L loc (HsModule (XModulePs _ _ mod_deprec maybe_doc_hdr) - maybe_mod export_ies import_decls local_decls)), - hpm_src_files = src_files - }) - (this_mod, prel_imp_loc) - = setSrcSpan loc $ - do { let { explicit_mod_hdr = isJust maybe_mod - ; hsc_src = ms_hsc_src mod_sum } - ; -- Load the hi-boot interface for this module, if any - -- We do this now so that the boot_names can be passed - -- to tcTyAndClassDecls, because the boot_names are - -- automatically considered to be loop breakers - tcg_env <- getGblEnv - ; boot_info <- tcHiBootIface hsc_src this_mod - ; setGblEnv (tcg_env { tcg_self_boot = boot_info }) - $ do - { -- Deal with imports; first add implicit prelude - implicit_prelude <- xoptM LangExt.ImplicitPrelude - ; let { prel_imports = mkPrelImports (moduleName this_mod) prel_imp_loc - implicit_prelude import_decls } - - ; when (notNull prel_imports) $ do - let msg = mkTcRnUnknownMessage $ - mkPlainDiagnostic (WarningWithFlag Opt_WarnImplicitPrelude) noHints (implicitPreludeWarn) - addDiagnostic msg - - ; -- TODO This is a little skeevy; maybe handle a bit more directly - let { simplifyImport (L _ idecl) = - ( renameRawPkgQual (hsc_unit_env hsc_env) (unLoc $ ideclName idecl) (ideclPkgQual idecl) - , reLoc $ ideclName idecl) - } - ; raw_sig_imports <- liftIO - $ findExtraSigImports hsc_env hsc_src - (moduleName this_mod) - ; raw_req_imports <- liftIO - $ implicitRequirements hsc_env - (map simplifyImport (prel_imports - ++ import_decls)) - ; let { mkImport mod_name = noLocA - $ (simpleImportDecl mod_name) - { ideclImportList = Just (Exactly, noLocA [])}} - ; let { withReason t imps = map (,text t) imps } - ; let { all_imports = withReason "is implicitly imported" prel_imports - ++ withReason "is directly imported" import_decls - ++ 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 - - -- Put a version of the header without identifier info into the tcg_env - -- Make sure to do this before 'tcRnSrcDecls', because we need the - -- module header when we're splicing TH, since it can be accessed via - -- 'getDoc'. - -- 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 }) - ; -- 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 - ; tcg_env1 <- case mod_deprec of - Just (L _ txt) -> do { txt' <- rnWarningTxt txt - ; pure $ tcg_env {tcg_warns = WarnAll txt'} - } - Nothing -> pure tcg_env - ; setGblEnv tcg_env1 - $ do { -- Rename and type check the declarations - traceRn "rn1a" empty - ; tcg_env <- if isHsBootOrSig hsc_src - then do { - ; tcg_env <- tcRnHsBootDecls hsc_src local_decls - ; traceRn "rn4a: before exports" empty - ; tcg_env <- setGblEnv tcg_env $ - rnExports explicit_mod_hdr export_ies - ; traceRn "rn4b: after exports" empty - ; return tcg_env - } - else {-# SCC "tcRnSrcDecls" #-} - tcRnSrcDecls explicit_mod_hdr export_ies local_decls - - ; whenM (goptM Opt_DoCoreLinting) $ - lintGblEnv (hsc_logger hsc_env) (hsc_dflags hsc_env) tcg_env - - ; setGblEnv tcg_env - $ do { -- Compare hi-boot iface (if any) with the real thing - -- Must be done after processing the exports - tcg_env <- checkHiBootIface tcg_env boot_info - ; -- The new type env is already available to stuff - -- slurped from interface files, via - -- GHC.Tc.Utils.Env.setGlobalTypeEnv. It's important that this - -- includes the stuff in checkHiBootIface, - -- because the latter might add new bindings for - -- boot_dfuns, which may be mentioned in imported - -- unfoldings. - ; -- Report unused names - -- Do this /after/ typeinference, so that when reporting - -- a function with no type signature we can give the - -- inferred type - ; reportUnusedNames tcg_env hsc_src - - -- 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 }) - - ; -- add extra source files to tcg_dependent_files - addDependentFiles src_files - -- Ensure plugins run with the same tcg_env that we pass in - ; setGblEnv tcg_env - $ do { tcg_env <- runTypecheckerPlugin mod_sum tcg_env - ; -- Dump output and return - tcDump tcg_env - ; return tcg_env - } - } - } - } - } - -implicitPreludeWarn :: SDoc -implicitPreludeWarn - = text "Module `Prelude' implicitly imported" - -{- -************************************************************************ -* * - Import declarations -* * -************************************************************************ --} - -tcRnImports :: HscEnv -> [(LImportDecl GhcPs, SDoc)] -> TcM TcGblEnv -tcRnImports hsc_env import_decls - = do { (rn_imports, rdr_env, imports, hpc_info) <- rnImports import_decls ; - - ; this_mod <- getModule - ; gbl_env <- getGblEnv - ; let { -- We want instance declarations from all home-package - -- modules below this one, including boot modules, except - -- ourselves. The 'except ourselves' is so that we don't - -- 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))) - - } ; - - -- Record boot-file info in the EPS, so that it's - -- visible to loadHiBootInterface in tcRnSrcDecls, - -- and any other incrementally-performed imports - ; when (isOneShot (ghcMode (hsc_dflags hsc_env))) $ do { - updateEps_ $ \eps -> eps { eps_is_boot = imp_boot_mods imports } - } - - -- Update the gbl env - ; updGblEnv ( \ gbl -> - gbl { - tcg_rdr_env = tcg_rdr_env gbl `plusGlobalRdrEnv` rdr_env, - tcg_imports = tcg_imports gbl `plusImportAvails` imports, - tcg_rn_imports = rn_imports, - 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 - }) $ do { - - ; traceRn "rn1" (ppr (imp_direct_dep_mods imports)) - -- Fail if there are any errors so far - -- The error printing (if needed) takes advantage - -- of the tcg_env we have now set --- ; traceIf (text "rdr_env: " <+> ppr rdr_env) - ; failIfErrsM - - -- Load any orphan-module (including orphan family - -- instance-module) interfaces, so that their rules and - -- instance decls will be found. But filter out a - -- self hs-boot: these instances will be checked when - -- we define them locally. - -- (We don't need to load non-orphan family instance - -- modules until we either try to use the instances they - -- define, or define our own family instances, at which - -- point we need to check them for consistency.) - ; loadModuleInterfaces (text "Loading orphan modules") - (filter (/= this_mod) (imp_orphs imports)) - - -- 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 - . imp_mods - $ imports } - ; checkFamInstConsistency dir_imp_mods - ; traceRn "rn1: } checking family instance consistency" empty - - ; getGblEnv } } - -{- -************************************************************************ -* * - Type-checking the top level of a module -* * -************************************************************************ --} - -tcRnSrcDecls :: Bool -- False => no 'module M(..) where' header at all - -> Maybe (LocatedL [LIE GhcPs]) - -> [LHsDecl GhcPs] -- Declarations - -> TcM TcGblEnv -tcRnSrcDecls explicit_mod_hdr export_ies decls - = do { -- Do all the declarations - ; (tcg_env, tcl_env, lie) <- tc_rn_src_decls decls - - ------ Simplify constraints --------- - -- - -- We do this after checkMainType, so that we use the type - -- info that checkMainType adds - -- - -- We do it with both global and local env in scope: - -- * the global env exposes the instances to simplifyTop, - -- and affects how names are rendered in error messages - -- * the local env exposes the local Ids to simplifyTop, - -- so that we get better error messages (monomorphism restriction) - ; new_ev_binds <- {-# SCC "simplifyTop" #-} - restoreEnvs (tcg_env, tcl_env) $ - do { lie_main <- checkMainType tcg_env - ; simplifyTop (lie `andWC` lie_main) } - - -- Emit Typeable bindings - ; tcg_env <- setGblEnv tcg_env $ - mkTypeableBinds - - ; traceTc "Tc9" empty - ; failIfErrsM -- Stop now if if there have been errors - -- Continuing is a waste of time; and we may get debug - -- warnings when zonking about strangely-typed TyCons! - - -- Zonk the final code. This must be done last. - -- Even simplifyTop may do some unification. - -- This pass also warns about missing type signatures - ; (id_env, ev_binds', binds', fords', imp_specs', rules') - <- zonkTcGblEnv new_ev_binds tcg_env - - --------- Run finalizers -------------- - -- Finalizers must run after constraints are simplified, lest types - -- might not be complete when using reify (see #12777). - -- and also after we zonk the first time because we run typed splices - -- in the zonker which gives rise to the finalisers. - ; let -- init_tcg_env: - -- * Remove accumulated bindings, rules and so on from - -- 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 - , tcg_ev_binds = emptyBag - , tcg_imp_specs = [] - , tcg_rules = [] - , tcg_fords = [] - , tcg_type_env = tcg_type_env tcg_env - `plusTypeEnv` id_env } - ; (tcg_env, tcl_env) <- setGblEnv init_tcg_env - run_th_modfinalizers - ; finishTH - ; traceTc "Tc11" empty - - --------- Deal with the exports ---------- - -- Can't be done earlier, because the export list must "see" - -- the declarations created by the finalizers - ; tcg_env <- restoreEnvs (tcg_env, tcl_env) $ - rnExports explicit_mod_hdr export_ies - - --------- Emit the ':Main.main = runMainIO main' declaration ---------- - -- Do this /after/ rnExports, so that it can consult - -- the tcg_exports created by rnExports - ; (tcg_env, main_ev_binds) - <- restoreEnvs (tcg_env, tcl_env) $ - do { (tcg_env, lie) <- captureTopConstraints $ - checkMain explicit_mod_hdr export_ies - ; ev_binds <- simplifyTop lie - ; return (tcg_env, ev_binds) } - - ; failIfErrsM -- Stop now if if there have been errors - -- Continuing is a waste of time; and we may get debug - -- warnings when zonking about strangely-typed TyCons! - - ---------- Final zonking --------------- - -- Zonk the new bindings arising from running the finalisers, - -- and main. This won't give rise to any more finalisers as you - -- can't nest finalisers inside finalisers. - ; (id_env_mf, ev_binds_mf, binds_mf, fords_mf, imp_specs_mf, rules_mf) - <- zonkTcGblEnv main_ev_binds tcg_env - - ; let { !final_type_env = tcg_type_env tcg_env - `plusTypeEnv` id_env_mf - -- Add the zonked Ids from the value bindings (they were in tcl_env) - -- Force !final_type_env, lest we retain an old reference - -- to the previous tcg_env - - ; tcg_env' = tcg_env - { tcg_binds = binds' `unionBags` binds_mf - , tcg_ev_binds = ev_binds' `unionBags` ev_binds_mf - , tcg_imp_specs = imp_specs' ++ imp_specs_mf - , tcg_rules = rules' ++ rules_mf - , tcg_fords = fords' ++ fords_mf } } ; - - ; setGlobalTypeEnv tcg_env' final_type_env - } - -zonkTcGblEnv :: Bag EvBind -> TcGblEnv - -> TcM (TypeEnv, Bag EvBind, LHsBinds GhcTc, - [LForeignDecl GhcTc], [LTcSpecPrag], [LRuleDecl GhcTc]) -zonkTcGblEnv ev_binds tcg_env@(TcGblEnv { tcg_binds = binds - , tcg_ev_binds = cur_ev_binds - , tcg_imp_specs = imp_specs - , tcg_rules = rules - , tcg_fords = fords }) - = {-# SCC "zonkTopDecls" #-} - setGblEnv tcg_env $ -- This sets the GlobalRdrEnv which is used when rendering - -- error messages during zonking (notably levity errors) - do { let all_ev_binds = cur_ev_binds `unionBags` ev_binds - ; zonkTopDecls all_ev_binds binds rules imp_specs fords } - --- | Runs TH finalizers and renames and typechecks the top-level declarations --- that they could introduce. -run_th_modfinalizers :: TcM (TcGblEnv, TcLclEnv) -run_th_modfinalizers = do - th_modfinalizers_var <- fmap tcg_th_modfinalizers getGblEnv - th_modfinalizers <- readTcRef th_modfinalizers_var - if null th_modfinalizers - then getEnvs - else do - writeTcRef th_modfinalizers_var [] - let run_finalizer (lcl_env, f) = - restoreLclEnv lcl_env (runRemoteModFinalizers f) - - (_, lie_th) <- captureTopConstraints $ - mapM_ run_finalizer th_modfinalizers - - -- Finalizers can add top-level declarations with addTopDecls, so - -- we have to run tc_rn_src_decls to get them - (tcg_env, tcl_env, lie_top_decls) <- tc_rn_src_decls [] - - restoreEnvs (tcg_env, tcl_env) $ do - -- Subsequent rounds of finalizers run after any new constraints are - -- simplified, or some types might not be complete when using reify - -- (see #12777). - new_ev_binds <- {-# SCC "simplifyTop2" #-} - simplifyTop (lie_th `andWC` lie_top_decls) - addTopEvBinds new_ev_binds run_th_modfinalizers - -- addTopDecls can add declarations which add new finalizers. - -tc_rn_src_decls :: [LHsDecl GhcPs] - -> TcM (TcGblEnv, TcLclEnv, WantedConstraints) --- Loops around dealing with each top level inter-splice group --- in turn, until it's dealt with the entire module --- Never emits constraints; calls captureTopConstraints internally -tc_rn_src_decls ds - = {-# SCC "tc_rn_src_decls" #-} - do { (first_group, group_tail) <- findSplice ds - -- If ds is [] we get ([], Nothing) - - -- Deal with decls up to, but not including, the first splice - ; (tcg_env, rn_decls) <- rnTopSrcDecls first_group - -- rnTopSrcDecls fails if there are any errors - - -- Get TH-generated top-level declarations and make sure they don't - -- contain any splices since we don't handle that at the moment - -- - -- The plumbing here is a bit odd: see #10853 - ; th_topdecls_var <- fmap tcg_th_topdecls getGblEnv - ; th_ds <- readTcRef th_topdecls_var - ; writeTcRef th_topdecls_var [] - - ; (tcg_env, rn_decls) <- - if null th_ds - then return (tcg_env, rn_decls) - else do { (th_group, th_group_tail) <- findSplice th_ds - ; case th_group_tail of - { Nothing -> return () - ; Just (SpliceDecl _ (L loc _) _, _) -> - setSrcSpanA loc - $ addErr (mkTcRnUnknownMessage $ mkPlainError noHints $ text - ("Declaration splices are not " - ++ "permitted inside top-level " - ++ "declarations added with addTopDecls")) - } - -- Rename TH-generated top-level declarations - ; (tcg_env, th_rn_decls) <- setGblEnv tcg_env - $ rnTopSrcDecls th_group - - -- Dump generated top-level declarations - ; let msg = "top-level declarations added with addTopDecls" - ; traceSplice - $ SpliceInfo { spliceDescription = msg - , spliceIsDecl = True - , spliceSource = Nothing - , spliceGenerated = ppr th_rn_decls } - ; return (tcg_env, appendGroups rn_decls th_rn_decls) - } - - -- Type check all declarations - -- NB: set the env **before** captureTopConstraints so that error messages - -- get reported w.r.t. the right GlobalRdrEnv. It is for this reason that - -- the captureTopConstraints must go here, not in tcRnSrcDecls. - ; ((tcg_env, tcl_env), lie1) <- setGblEnv tcg_env $ - captureTopConstraints $ - tcTopSrcDecls rn_decls - - -- If there is no splice, we're nearly done - ; restoreEnvs (tcg_env, tcl_env) $ - case group_tail of - { Nothing -> return (tcg_env, tcl_env, lie1) - - -- If there's a splice, we must carry on - ; Just (SpliceDecl _ (L _ splice) _, rest_ds) -> - do { - -- We need to simplify any constraints from the previous declaration - -- group, or else we might reify metavariables, as in #16980. - ; ev_binds1 <- simplifyTop lie1 - - -- Rename the splice expression, and get its supporting decls - ; (spliced_decls, splice_fvs) <- rnTopSpliceDecls splice - - -- Glue them on the front of the remaining decls and loop - ; setGblEnv (tcg_env `addTcgDUs` usesOnly splice_fvs) $ - addTopEvBinds ev_binds1 $ - tc_rn_src_decls (spliced_decls ++ rest_ds) - } - } - } - -{- -************************************************************************ -* * - Compiling hs-boot source files, and - comparing the hi-boot interface with the real thing -* * -************************************************************************ --} - -tcRnHsBootDecls :: HscSource -> [LHsDecl GhcPs] -> TcM TcGblEnv -tcRnHsBootDecls hsc_src decls - = do { (first_group, group_tail) <- findSplice decls - - -- Rename the declarations - ; (tcg_env, HsGroup { hs_tyclds = tycl_decls - , hs_derivds = deriv_decls - , hs_fords = for_decls - , hs_defds = def_decls - , hs_ruleds = rule_decls - , hs_annds = _ - , hs_valds = XValBindsLR (NValBinds val_binds val_sigs) }) - <- rnTopSrcDecls first_group - - -- The empty list is for extra dependencies coming from .hs-boot files - -- See Note [Extra dependencies from .hs-boot files] in GHC.Rename.Module - - ; (gbl_env, lie) <- setGblEnv tcg_env $ captureTopConstraints $ do { - -- NB: setGblEnv **before** captureTopConstraints so that - -- if the latter reports errors, it knows what's in scope - - -- Check for illegal declarations - ; case group_tail of - Just (SpliceDecl _ d _, _) -> badBootDecl hsc_src "splice" d - Nothing -> return () - ; mapM_ (badBootDecl hsc_src "foreign") for_decls - ; mapM_ (badBootDecl hsc_src "default") def_decls - ; mapM_ (badBootDecl hsc_src "rule") rule_decls - - -- Typecheck type/class/instance decls - ; traceTc "Tc2 (boot)" empty - ; (tcg_env, inst_infos, _deriv_binds, _th_bndrs) - <- tcTyClsInstDecls tycl_decls deriv_decls val_binds - ; setGblEnv tcg_env $ do { - - -- Emit Typeable bindings - ; tcg_env <- mkTypeableBinds - ; setGblEnv tcg_env $ do { - - -- Typecheck value declarations - ; traceTc "Tc5" empty - ; val_ids <- tcHsBootSigs val_binds val_sigs - - -- Wrap up - -- No simplification or zonking to do - ; traceTc "Tc7a" empty - ; gbl_env <- getGblEnv - - -- Make the final type-env - -- Include the dfun_ids so that their type sigs - -- are written into the interface file. - ; let { type_env0 = tcg_type_env gbl_env - ; type_env1 = extendTypeEnvWithIds type_env0 val_ids - ; type_env2 = extendTypeEnvWithIds type_env1 dfun_ids - ; dfun_ids = map iDFunId inst_infos - } - - ; setGlobalTypeEnv gbl_env type_env2 - }}} - ; traceTc "boot" (ppr lie); return gbl_env } - -badBootDecl :: HscSource -> String -> LocatedA decl -> TcM () -badBootDecl hsc_src what (L loc _) - = addErrAt (locA loc) $ mkTcRnUnknownMessage $ mkPlainError noHints $ - (char 'A' <+> text what - <+> text "declaration is not (currently) allowed in a" - <+> (case hsc_src of - HsBootFile -> text "hs-boot" - HsigFile -> text "hsig" - _ -> panic "badBootDecl: should be an hsig or hs-boot file") - <+> text "file") - -{- -Once we've typechecked the body of the module, we want to compare what -we've found (gathered in a TypeEnv) with the hi-boot details (if any). --} - -checkHiBootIface :: TcGblEnv -> SelfBootInfo -> TcM TcGblEnv --- Compare the hi-boot file for this module (if there is one) --- with the type environment we've just come up with --- In the common case where there is no hi-boot file, the list --- of boot_names is empty. - -checkHiBootIface tcg_env boot_info - | NoSelfBoot <- boot_info -- Common case - = return tcg_env - - | HsBootFile <- tcg_src tcg_env -- Current module is already a hs-boot file! - = return tcg_env - - | SelfBoot { sb_mds = boot_details } <- boot_info - , TcGblEnv { tcg_binds = binds - , tcg_insts = local_insts - , tcg_type_env = local_type_env - , tcg_exports = local_exports } <- tcg_env - = do { -- This code is tricky, see Note [DFun knot-tying] - ; dfun_prs <- checkHiBootIface' local_insts local_type_env - local_exports boot_details - - -- Now add the boot-dfun bindings $fxblah = $fblah - -- to (a) the type envt, and (b) the top-level bindings - ; let boot_dfuns = map fst dfun_prs - type_env' = extendTypeEnvWithIds local_type_env boot_dfuns - dfun_binds = listToBag [ mkVarBind boot_dfun (nlHsVar dfun) - | (boot_dfun, dfun) <- dfun_prs ] - tcg_env_w_binds - = tcg_env { tcg_binds = binds `unionBags` dfun_binds } - - ; type_env' `seq` - -- Why the seq? Without, we will put a TypeEnv thunk in - -- tcg_type_env_var. That thunk will eventually get - -- forced if we are typechecking interfaces, but that - -- is no good if we are trying to typecheck the very - -- DFun we were going to put in. - -- 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 -defined in the hs-boot file, such as - $fxEqT = $fEqT -We need these because the module and hi-boot file might differ in -the name it chose for the dfun: the name of a dfun is not -uniquely determined by its type; there might be multiple dfuns -which, individually, would map to the same name (in which case -we have to disambiguate them.) There's no way for the hi file -to know exactly what disambiguation to use... without looking -at the hi-boot file itself. - -In fact, the names will always differ because we always pick names -prefixed with "$fx" for boot dfuns, and "$f" for real dfuns -(so that this impedance matching is always possible). - -Note [DFun knot-tying] -~~~~~~~~~~~~~~~~~~~~~~ -The 'SelfBootInfo' that is fed into 'checkHiBootIface' comes from -typechecking the hi-boot file that we are presently implementing. -Suppose we are typechecking the module A: when we typecheck the -hi-boot file, whenever we see an identifier A.T, we knot-tie this -identifier to the *local* type environment (via if_rec_types.) The -contract then is that we don't *look* at 'SelfBootInfo' until we've -finished typechecking the module and updated the type environment with -the new tycons and ids. - -This most works well, but there is one problem: DFuns! We do not want -to look at the mb_insts of the ModDetails in SelfBootInfo, because a -dfun in one of those ClsInsts is gotten (in GHC.IfaceToCore.tcIfaceInst) by a -(lazily evaluated) lookup in the if_rec_types. We could extend the -type env, do a setGloblaTypeEnv etc; but that all seems very indirect. -It is much more directly simply to extract the DFunIds from the -md_types of the SelfBootInfo. - -See #4003, #16038 for why we need to take care here. --} - -checkHiBootIface' :: [ClsInst] -> TypeEnv -> [AvailInfo] - -> ModDetails -> TcM [(Id, Id)] --- Variant which doesn't require a full TcGblEnv; you could get the --- local components from another ModDetails. -checkHiBootIface' - local_insts local_type_env local_exports - (ModDetails { md_types = boot_type_env - , md_fam_insts = boot_fam_insts - , md_exports = boot_exports }) - = do { traceTc "checkHiBootIface" $ vcat - [ ppr boot_type_env, ppr boot_exports] - - -- Check the exports of the boot module, one by one - ; mapM_ check_export boot_exports - - -- Check for no family instances - ; unless (null boot_fam_insts) $ - panic ("GHC.Tc.Module.checkHiBootIface: Cannot handle family " ++ - "instances in boot files yet...") - -- FIXME: Why? The actual comparison is not hard, but what would - -- be the equivalent to the dfun bindings returned for class - -- instances? We can't easily equate tycons... - - -- Check instance declarations - -- and generate an impedance-matching binding - ; mb_dfun_prs <- mapM check_cls_inst boot_dfuns - - ; failIfErrsM - - ; return (catMaybes mb_dfun_prs) } - - where - boot_dfun_names = map idName boot_dfuns - boot_dfuns = filter isDFunId $ typeEnvIds boot_type_env - -- NB: boot_dfuns is /not/ defined thus: map instanceDFunId md_insts - -- We don't want to look at md_insts! - -- Why not? See Note [DFun knot-tying] - - check_export boot_avail -- boot_avail is exported by the boot iface - | name `elem` boot_dfun_names = return () - - -- Check that the actual module exports the same thing - | missing_name:_ <- missing_names - = addErrAt (nameSrcSpan missing_name) - (missingBootThing True missing_name "exported by") - - -- If the boot module does not *define* the thing, we are done - -- (it simply re-exports it, and names match, so nothing further to do) - | isNothing mb_boot_thing = return () - - -- Check that the actual module also defines the thing, and - -- then compare the definitions - | Just real_thing <- lookupTypeEnv local_type_env name, - Just boot_thing <- mb_boot_thing - = checkBootDeclM True boot_thing real_thing - - | otherwise - = addErrTc (missingBootThing True name "defined in") - where - name = availName boot_avail - mb_boot_thing = lookupTypeEnv boot_type_env name - missing_names = case lookupNameEnv local_export_env name of - Nothing -> [name] - Just avail -> availNames boot_avail `minusList` availNames avail - - local_export_env :: NameEnv AvailInfo - local_export_env = availsToNameEnv local_exports - - check_cls_inst :: DFunId -> TcM (Maybe (Id, Id)) - -- Returns a pair of the boot dfun in terms of the equivalent - -- real dfun. Delicate (like checkBootDecl) because it depends - -- on the types lining up precisely even to the ordering of - -- the type variables in the foralls. - check_cls_inst boot_dfun - | (real_dfun : _) <- find_real_dfun boot_dfun - , let local_boot_dfun = Id.mkExportedVanillaId - (idName boot_dfun) (idType real_dfun) - = return (Just (local_boot_dfun, real_dfun)) - -- Two tricky points here: - -- - -- * The local_boot_fun should have a Name from the /boot-file/, - -- but type from the dfun defined in /this module/. - -- That ensures that the TyCon etc inside the type are - -- the ones defined in this module, not the ones gotten - -- from the hi-boot file, which may have a lot less info - -- (#8743, comment:10). - -- - -- * The DFunIds from boot_details are /GlobalIds/, because - -- they come from typechecking M.hi-boot. - -- But all bindings in this module should be for /LocalIds/, - -- otherwise dependency analysis fails (#16038). This - -- is another reason for using mkExportedVanillaId, rather - -- that modifying boot_dfun, to make local_boot_fun. - - | otherwise - = setSrcSpan (nameSrcSpan (getName boot_dfun)) $ - do { traceTc "check_cls_inst" $ vcat - [ text "local_insts" <+> - vcat (map (ppr . idType . instanceDFunId) local_insts) - , text "boot_dfun_ty" <+> ppr (idType boot_dfun) ] - - ; addErrTc (instMisMatch boot_dfun) - ; return Nothing } - - find_real_dfun :: DFunId -> [DFunId] - find_real_dfun boot_dfun - = [dfun | inst <- local_insts - , let dfun = instanceDFunId inst - , idType dfun `eqType` boot_dfun_ty ] - where - boot_dfun_ty = idType boot_dfun - - --- In general, to perform these checks we have to --- compare the TyThing from the .hi-boot file to the TyThing --- in the current source file. We must be careful to allow alpha-renaming --- where appropriate, and also the boot declaration is allowed to omit --- constructors and class methods. --- --- See rnfail055 for a good test of this stuff. - --- | Compares two things for equivalence between boot-file and normal code, --- reporting an error if they don't match up. -checkBootDeclM :: Bool -- ^ True <=> an hs-boot file (could also be a sig) - -> TyThing -> TyThing -> TcM () -checkBootDeclM is_boot boot_thing real_thing - = whenIsJust (checkBootDecl is_boot boot_thing real_thing) $ \ err -> - addErrAt span - (bootMisMatch is_boot err real_thing boot_thing) - where - -- Here we use the span of the boot thing or, if it doesn't have a sensible - -- span, that of the real thing, - span - | let span = nameSrcSpan (getName boot_thing) - , isGoodSrcSpan span - = span - | otherwise - = nameSrcSpan (getName real_thing) - --- | Compares the two things for equivalence between boot-file and normal --- code. Returns @Nothing@ on success or @Just "some helpful info for user"@ --- failure. If the difference will be apparent to the user, @Just empty@ is --- perfectly suitable. -checkBootDecl :: Bool -> TyThing -> TyThing -> Maybe SDoc - -checkBootDecl _ (AnId id1) (AnId id2) - = assert (id1 == id2) $ - check (idType id1 `eqType` idType id2) - (text "The two types are different") - -checkBootDecl is_boot (ATyCon tc1) (ATyCon tc2) - = checkBootTyCon is_boot tc1 tc2 - -checkBootDecl _ (AConLike (RealDataCon dc1)) (AConLike (RealDataCon _)) - = pprPanic "checkBootDecl" (ppr dc1) - -checkBootDecl _ _ _ = Just empty -- probably shouldn't happen - --- | Combines two potential error messages -andThenCheck :: Maybe SDoc -> Maybe SDoc -> Maybe SDoc -Nothing `andThenCheck` msg = msg -msg `andThenCheck` Nothing = msg -Just d1 `andThenCheck` Just d2 = Just (d1 $$ d2) -infixr 0 `andThenCheck` - --- | If the test in the first parameter is True, succeed with @Nothing@; --- otherwise, return the provided check -checkUnless :: Bool -> Maybe SDoc -> Maybe SDoc -checkUnless True _ = Nothing -checkUnless False k = k - --- | Run the check provided for every pair of elements in the lists. --- The provided SDoc should name the element type, in the plural. -checkListBy :: (a -> a -> Maybe SDoc) -> [a] -> [a] -> SDoc - -> Maybe SDoc -checkListBy check_fun as bs whats = go [] as bs - where - herald = text "The" <+> whats <+> text "do not match" - - go [] [] [] = Nothing - go docs [] [] = Just (hang (herald <> colon) 2 (vcat $ reverse docs)) - go docs (x:xs) (y:ys) = case check_fun x y of - Just doc -> go (doc:docs) xs ys - Nothing -> go docs xs ys - go _ _ _ = Just (hang (herald <> colon) - 2 (text "There are different numbers of" <+> whats)) - --- | If the test in the first parameter is True, succeed with @Nothing@; --- otherwise, fail with the given SDoc. -check :: Bool -> SDoc -> Maybe SDoc -check True _ = Nothing -check False doc = Just doc - --- | A more perspicuous name for @Nothing@, for @checkBootDecl@ and friends. -checkSuccess :: Maybe SDoc -checkSuccess = Nothing - ----------------- -checkBootTyCon :: Bool -> TyCon -> TyCon -> Maybe SDoc -checkBootTyCon is_boot tc1 tc2 - | not (eqType (tyConKind tc1) (tyConKind tc2)) - = Just $ text "The types have different kinds" -- First off, check the kind - - | Just c1 <- tyConClass_maybe tc1 - , Just c2 <- tyConClass_maybe tc2 - , let (clas_tvs1, clas_fds1, sc_theta1, _, ats1, op_stuff1) - = classExtraBigSig c1 - (clas_tvs2, clas_fds2, sc_theta2, _, ats2, op_stuff2) - = classExtraBigSig c2 - , Just env <- eqVarBndrs emptyRnEnv2 clas_tvs1 clas_tvs2 - = let - eqSig (id1, def_meth1) (id2, def_meth2) - = check (name1 == name2) - (text "The names" <+> pname1 <+> text "and" <+> pname2 <+> - text "are different") `andThenCheck` - check (eqTypeX env op_ty1 op_ty2) - (text "The types of" <+> pname1 <+> - text "are different") `andThenCheck` - if is_boot - then check (liftEq eqDM def_meth1 def_meth2) - (text "The default methods associated with" <+> pname1 <+> - text "are different") - else check (subDM op_ty1 def_meth1 def_meth2) - (text "The default methods associated with" <+> pname1 <+> - text "are not compatible") - where - name1 = idName id1 - name2 = idName id2 - pname1 = quotes (ppr name1) - pname2 = quotes (ppr name2) - op_ty1 = classMethodTy id1 - op_ty2 = classMethodTy id2 - - eqAT (ATI tc1 def_ats1) (ATI tc2 def_ats2) - = checkBootTyCon is_boot tc1 tc2 `andThenCheck` - check (eqATDef def_ats1 def_ats2) - (text "The associated type defaults differ") - - eqDM (_, VanillaDM) (_, VanillaDM) = True - eqDM (_, GenericDM t1) (_, GenericDM t2) = eqTypeX env t1 t2 - eqDM _ _ = False - - -- NB: first argument is from hsig, second is from real impl. - -- Order of pattern matching matters. - subDM _ Nothing _ = True - subDM _ _ Nothing = False - - -- If the hsig wrote: - -- - -- f :: a -> a - -- default f :: a -> a - -- - -- this should be validly implementable using an old-fashioned - -- vanilla default method. - subDM t1 (Just (_, GenericDM gdm_t1)) (Just (_, VanillaDM)) - = eqType t1 gdm_t1 -- Take care (#22476). Both t1 and gdm_t1 come - -- from tc1, so use eqType, and /not/ eqTypeX - - -- This case can occur when merging signatures - subDM t1 (Just (_, VanillaDM)) (Just (_, GenericDM t2)) - = eqTypeX env t1 t2 - - subDM _ (Just (_, VanillaDM)) (Just (_, VanillaDM)) = True - subDM _ (Just (_, GenericDM t1)) (Just (_, GenericDM t2)) - = eqTypeX env t1 t2 - - -- Ignore the location of the defaults - eqATDef Nothing Nothing = True - eqATDef (Just (ty1, _loc1)) (Just (ty2, _loc2)) = eqTypeX env ty1 ty2 - eqATDef _ _ = False - - eqFD (as1,bs1) (as2,bs2) = - liftEq (eqTypeX env) (mkTyVarTys as1) (mkTyVarTys as2) && - liftEq (eqTypeX env) (mkTyVarTys bs1) (mkTyVarTys bs2) - in - checkRoles roles1 roles2 `andThenCheck` - -- Checks kind of class - check (liftEq eqFD clas_fds1 clas_fds2) - (text "The functional dependencies do not match") `andThenCheck` - checkUnless (isAbstractTyCon tc1) $ - check (liftEq (eqTypeX env) sc_theta1 sc_theta2) - (text "The class constraints do not match") `andThenCheck` - checkListBy eqSig op_stuff1 op_stuff2 (text "methods") `andThenCheck` - checkListBy eqAT ats1 ats2 (text "associated types") `andThenCheck` - check (classMinimalDef c1 `BF.implies` classMinimalDef c2) - (text "The MINIMAL pragmas are not compatible") - - | Just syn_rhs1 <- synTyConRhs_maybe tc1 - , Just syn_rhs2 <- synTyConRhs_maybe tc2 - , Just env <- eqVarBndrs emptyRnEnv2 (tyConTyVars tc1) (tyConTyVars tc2) - = assert (tc1 == tc2) $ - checkRoles roles1 roles2 `andThenCheck` - check (eqTypeX env syn_rhs1 syn_rhs2) empty -- nothing interesting to say - -- This allows abstract 'data T a' to be implemented using 'type T = ...' - -- and abstract 'class K a' to be implement using 'type K = ...' - -- See Note [Synonyms implement abstract data] - | not is_boot -- don't support for hs-boot yet - , isAbstractTyCon tc1 - , Just (tvs, ty) <- synTyConDefn_maybe tc2 - , Just (tc2', args) <- tcSplitTyConApp_maybe ty - = checkSynAbsData tvs ty tc2' args - -- TODO: When it's a synonym implementing a class, we really - -- should check if the fundeps are satisfied, but - -- there is not an obvious way to do this for a constraint synonym. - -- So for now, let it all through (it won't cause segfaults, anyway). - -- Tracked at #12704. - - -- This allows abstract 'data T :: Nat' to be implemented using - -- 'type T = 42' Since the kinds already match (we have checked this - -- upfront) all we need to check is that the implementation 'type T - -- = ...' defined an actual literal. See #15138 for the case this - -- handles. - | not is_boot - , isAbstractTyCon tc1 - , Just (_,ty2) <- synTyConDefn_maybe tc2 - , isJust (isLitTy ty2) - = Nothing - - | Just fam_flav1 <- famTyConFlav_maybe tc1 - , Just fam_flav2 <- famTyConFlav_maybe tc2 - = assert (tc1 == tc2) $ - let eqFamFlav OpenSynFamilyTyCon OpenSynFamilyTyCon = True - eqFamFlav (DataFamilyTyCon {}) (DataFamilyTyCon {}) = True - -- This case only happens for hsig merging: - eqFamFlav AbstractClosedSynFamilyTyCon AbstractClosedSynFamilyTyCon = True - eqFamFlav AbstractClosedSynFamilyTyCon (ClosedSynFamilyTyCon {}) = True - eqFamFlav (ClosedSynFamilyTyCon {}) AbstractClosedSynFamilyTyCon = True - eqFamFlav (ClosedSynFamilyTyCon ax1) (ClosedSynFamilyTyCon ax2) - = eqClosedFamilyAx ax1 ax2 - eqFamFlav (BuiltInSynFamTyCon {}) (BuiltInSynFamTyCon {}) = tc1 == tc2 - eqFamFlav _ _ = False - injInfo1 = tyConInjectivityInfo tc1 - injInfo2 = tyConInjectivityInfo tc2 - in - -- check equality of roles, family flavours and injectivity annotations - -- (NB: Type family roles are always nominal. But the check is - -- harmless enough.) - checkRoles roles1 roles2 `andThenCheck` - check (eqFamFlav fam_flav1 fam_flav2) - (whenPprDebug $ - text "Family flavours" <+> ppr fam_flav1 <+> text "and" <+> ppr fam_flav2 <+> - text "do not match") `andThenCheck` - check (injInfo1 == injInfo2) (text "Injectivities do not match") - - | isAlgTyCon tc1 && isAlgTyCon tc2 - , Just env <- eqVarBndrs emptyRnEnv2 (tyConTyVars tc1) (tyConTyVars tc2) - = assert (tc1 == tc2) $ - checkRoles roles1 roles2 `andThenCheck` - check (liftEq (eqTypeX env) - (tyConStupidTheta tc1) (tyConStupidTheta tc2)) - (text "The datatype contexts do not match") `andThenCheck` - eqAlgRhs tc1 (algTyConRhs tc1) (algTyConRhs tc2) - - | otherwise = Just empty -- two very different types -- should be obvious - where - roles1 = tyConRoles tc1 -- the abstract one - roles2 = tyConRoles tc2 - roles_msg = text "The roles do not match." $$ - (text "Roles on abstract types default to" <+> - quotes (text "representational") <+> text "in boot files.") - - roles_subtype_msg = text "The roles are not compatible:" $$ - text "Main module:" <+> ppr roles2 $$ - text "Hsig file:" <+> ppr roles1 - - checkRoles r1 r2 - | is_boot || isInjectiveTyCon tc1 Representational -- See Note [Role subtyping] - = check (r1 == r2) roles_msg - | otherwise = check (r2 `rolesSubtypeOf` r1) roles_subtype_msg - - -- Note [Role subtyping] - -- ~~~~~~~~~~~~~~~~~~~~~ - -- In the current formulation of roles, role subtyping is only OK if the - -- "abstract" TyCon was not representationally injective. Among the most - -- notable examples of non representationally injective TyCons are abstract - -- data, which can be implemented via newtypes (which are not - -- representationally injective). The key example is - -- in this example from #13140: - -- - -- -- In an hsig file - -- data T a -- abstract! - -- type role T nominal - -- - -- -- Elsewhere - -- foo :: Coercible (T a) (T b) => a -> b - -- foo x = x - -- - -- We must NOT allow foo to typecheck, because if we instantiate - -- T with a concrete data type with a phantom role would cause - -- Coercible (T a) (T b) to be provable. Fortunately, if T is not - -- representationally injective, we cannot make the inference that a ~N b if - -- T a ~R T b. - -- - -- Unconditional role subtyping would be possible if we setup - -- an extra set of roles saying when we can project out coercions - -- (we call these proj-roles); then it would NOT be valid to instantiate T - -- with a data type at phantom since the proj-role subtyping check - -- would fail. See #13140 for more details. - -- - -- One consequence of this is we get no role subtyping for non-abstract - -- data types in signatures. Suppose you have: - -- - -- signature A where - -- type role T nominal - -- data T a = MkT - -- - -- If you write this, we'll treat T as injective, and make inferences - -- like T a ~R T b ==> a ~N b (mkSelCo). But if we can - -- subsequently replace T with one at phantom role, we would then be able to - -- infer things like T Int ~R T Bool which is bad news. - -- - -- We could allow role subtyping here if we didn't treat *any* data types - -- defined in signatures as injective. But this would be a bit surprising, - -- replacing a data type in a module with one in a signature could cause - -- your code to stop typechecking (whereas if you made the type abstract, - -- it is more understandable that the type checker knows less). - -- - -- It would have been best if this was purely a question of defaults - -- (i.e., a user could explicitly ask for one behavior or another) but - -- the current role system isn't expressive enough to do this. - -- Having explicit proj-roles would solve this problem. - - rolesSubtypeOf [] [] = True - -- NB: this relation is the OPPOSITE of the subroling relation - rolesSubtypeOf (x:xs) (y:ys) = x >= y && rolesSubtypeOf xs ys - rolesSubtypeOf _ _ = False - - -- Note [Synonyms implement abstract data] - -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -- An abstract data type or class can be implemented using a type synonym, - -- but ONLY if the type synonym is nullary and has no type family - -- applications. This arises from two properties of skolem abstract data: - -- - -- For any T (with some number of parameters), - -- - -- 1. T is a valid type (it is "curryable"), and - -- - -- 2. T is valid in an instance head (no type families). - -- - -- See also 'HowAbstract' and Note [Skolem abstract data]. - - -- Given @type T tvs = ty@, where @ty@ decomposes into @tc2' args@, - -- check that this synonym is an acceptable implementation of @tc1@. - -- See Note [Synonyms implement abstract data] - checkSynAbsData :: [TyVar] -> Type -> TyCon -> [Type] -> Maybe SDoc - checkSynAbsData tvs ty tc2' args = - check (null (tcTyFamInsts ty)) - (text "Illegal type family application in implementation of abstract data.") - `andThenCheck` - check (null tvs) - (text "Illegal parameterized type synonym in implementation of abstract data." $$ - text "(Try eta reducing your type synonym so that it is nullary.)") - `andThenCheck` - -- Don't report roles errors unless the type synonym is nullary - checkUnless (not (null tvs)) $ - assert (null roles2) $ - -- If we have something like: - -- - -- signature H where - -- data T a - -- module H where - -- data K a b = ... - -- type T = K Int - -- - -- we need to drop the first role of K when comparing! - checkRoles roles1 (drop (length args) (tyConRoles tc2')) -{- - -- Hypothetically, if we were allow to non-nullary type synonyms, here - -- is how you would check the roles - if length tvs == length roles1 - then checkRoles roles1 roles2 - else case tcSplitTyConApp_maybe ty of - Just (tc2', args) -> - checkRoles roles1 (drop (length args) (tyConRoles tc2') ++ roles2) - Nothing -> Just roles_msg --} - - eqAlgRhs _ (AbstractTyCon {}) _rhs2 - = checkSuccess -- rhs2 is guaranteed to be injective, since it's an AlgTyCon - eqAlgRhs _ tc1@DataTyCon{} tc2@DataTyCon{} = - checkListBy eqCon (data_cons tc1) (data_cons tc2) (text "constructors") - eqAlgRhs _ tc1@NewTyCon{} tc2@NewTyCon{} = - eqCon (data_con tc1) (data_con tc2) - eqAlgRhs _ _ _ = Just (text "Cannot match a" <+> quotes (text "data") <+> - text "definition with a" <+> quotes (text "newtype") <+> - text "definition") - - eqCon c1 c2 - = check (name1 == name2) - (text "The names" <+> pname1 <+> text "and" <+> pname2 <+> - text "differ") `andThenCheck` - check (dataConIsInfix c1 == dataConIsInfix c2) - (text "The fixities of" <+> pname1 <+> - text "differ") `andThenCheck` - check (liftEq eqHsBang (dataConImplBangs c1) (dataConImplBangs c2)) - (text "The strictness annotations for" <+> pname1 <+> - text "differ") `andThenCheck` - check (map flSelector (dataConFieldLabels c1) == map flSelector (dataConFieldLabels c2)) - (text "The record label lists for" <+> pname1 <+> - text "differ") `andThenCheck` - check (eqType (dataConWrapperType c1) (dataConWrapperType c2)) - (text "The types for" <+> pname1 <+> text "differ") - where - name1 = dataConName c1 - name2 = dataConName c2 - pname1 = quotes (ppr name1) - pname2 = quotes (ppr name2) - - eqClosedFamilyAx Nothing Nothing = True - eqClosedFamilyAx Nothing (Just _) = False - eqClosedFamilyAx (Just _) Nothing = False - eqClosedFamilyAx (Just (CoAxiom { co_ax_branches = branches1 })) - (Just (CoAxiom { co_ax_branches = branches2 })) - = numBranches branches1 == numBranches branches2 - && (and $ zipWith eqClosedFamilyBranch branch_list1 branch_list2) - where - branch_list1 = fromBranches branches1 - branch_list2 = fromBranches branches2 - - eqClosedFamilyBranch (CoAxBranch { cab_tvs = tvs1, cab_cvs = cvs1 - , cab_lhs = lhs1, cab_rhs = rhs1 }) - (CoAxBranch { cab_tvs = tvs2, cab_cvs = cvs2 - , cab_lhs = lhs2, cab_rhs = rhs2 }) - | Just env1 <- eqVarBndrs emptyRnEnv2 tvs1 tvs2 - , Just env <- eqVarBndrs env1 cvs1 cvs2 - = liftEq (eqTypeX env) lhs1 lhs2 && - eqTypeX env rhs1 rhs2 - - | otherwise = False - -emptyRnEnv2 :: RnEnv2 -emptyRnEnv2 = mkRnEnv2 emptyInScopeSet - ----------------- -missingBootThing :: Bool -> Name -> String -> TcRnMessage -missingBootThing is_boot name what - = mkTcRnUnknownMessage $ mkPlainError noHints $ - quotes (ppr name) <+> text "is exported by the" - <+> (if is_boot then text "hs-boot" else text "hsig") - <+> text "file, but not" - <+> text what <+> text "the module" - -badReexportedBootThing :: Bool -> Name -> Name -> TcRnMessage -badReexportedBootThing is_boot name name' - = mkTcRnUnknownMessage $ mkPlainError noHints $ - withUserStyle alwaysQualify AllTheWay $ vcat - [ text "The" <+> (if is_boot then text "hs-boot" else text "hsig") - <+> text "file (re)exports" <+> quotes (ppr name) - , text "but the implementing module exports a different identifier" <+> quotes (ppr name') - ] - -bootMisMatch :: Bool -> SDoc -> TyThing -> TyThing -> TcRnMessage -bootMisMatch is_boot extra_info real_thing boot_thing - = mkTcRnUnknownMessage $ mkPlainError noHints $ - pprBootMisMatch is_boot extra_info real_thing real_doc boot_doc - where - to_doc - = pprTyThingInContext $ showToHeader { ss_forall = - if is_boot - then ShowForAllMust - else ShowForAllWhen } - - real_doc = to_doc real_thing - boot_doc = to_doc boot_thing - - pprBootMisMatch :: Bool -> SDoc -> TyThing -> SDoc -> SDoc -> SDoc - pprBootMisMatch is_boot extra_info real_thing real_doc boot_doc - = vcat - [ ppr real_thing <+> - text "has conflicting definitions in the module", - text "and its" <+> - (if is_boot - then text "hs-boot file" - else text "hsig file"), - text "Main module:" <+> real_doc, - (if is_boot - then text "Boot file: " - else text "Hsig file: ") - <+> boot_doc, - extra_info - ] - -instMisMatch :: DFunId -> TcRnMessage -instMisMatch dfun - = mkTcRnUnknownMessage $ mkPlainError noHints $ - hang (text "instance" <+> ppr (idType dfun)) - 2 (text "is defined in the hs-boot file, but not in the module itself") - -{- -************************************************************************ -* * - Type-checking the top level of a module (continued) -* * -************************************************************************ --} - -rnTopSrcDecls :: HsGroup GhcPs -> TcM (TcGblEnv, HsGroup GhcRn) --- Fails if there are any errors -rnTopSrcDecls group - = do { -- Rename the source decls - traceRn "rn12" empty ; - (tcg_env, rn_decls) <- checkNoErrs $ rnSrcDecls group ; - traceRn "rn13" empty ; - (tcg_env, rn_decls) <- runRenamerPlugin tcg_env rn_decls ; - traceRn "rn13-plugin" empty ; - - -- save the renamed syntax, if we want it - let { tcg_env' - | Just grp <- tcg_rn_decls tcg_env - = tcg_env{ tcg_rn_decls = Just (appendGroups grp rn_decls) } - | otherwise - = tcg_env }; - - -- Dump trace of renaming part - rnDump rn_decls ; - return (tcg_env', rn_decls) - } - -tcTopSrcDecls :: HsGroup GhcRn -> TcM (TcGblEnv, TcLclEnv) -tcTopSrcDecls (HsGroup { hs_tyclds = tycl_decls, - hs_derivds = deriv_decls, - hs_fords = foreign_decls, - hs_defds = default_decls, - hs_annds = annotation_decls, - hs_ruleds = rule_decls, - hs_valds = hs_val_binds@(XValBindsLR - (NValBinds val_binds val_sigs)) }) - = do { -- Type-check the type and class decls, and all imported decls - -- The latter come in via tycl_decls - traceTc "Tc2 (src)" empty ; - - -- Source-language instances, including derivings, - -- and import the supporting declarations - traceTc "Tc3" empty ; - (tcg_env, inst_infos, th_bndrs, - XValBindsLR (NValBinds deriv_binds deriv_sigs)) - <- tcTyClsInstDecls tycl_decls deriv_decls val_binds ; - - updLclEnv (\tcl_env -> tcl_env { tcl_th_bndrs = th_bndrs `plusNameEnv` tcl_th_bndrs tcl_env }) $ - setGblEnv tcg_env $ do { - - -- Generate Applicative/Monad proposal (AMP) warnings - traceTc "Tc3b" empty ; - - -- Generate Semigroup/Monoid warnings - traceTc "Tc3c" empty ; - tcSemigroupWarnings ; - - -- Foreign import declarations next. - traceTc "Tc4" empty ; - (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 - -- may be defined in terms of the former. (For instance, - -- the bindings produced in a Data instance.) - traceTc "Tc5" empty ; - tc_envs <- tcTopBinds val_binds val_sigs; - restoreEnvs tc_envs $ do { - - -- Now GHC-generated derived bindings, generics, and selectors - -- Do not generate warnings from compiler-generated code; - -- hence the use of discardWarnings - tc_envs@(tcg_env, tcl_env) - <- discardWarnings (tcTopBinds deriv_binds deriv_sigs) ; - restoreEnvs tc_envs $ do { -- Environment doesn't change now - - -- Second pass over class and instance declarations, - -- now using the kind-checked decls - traceTc "Tc6" empty ; - inst_binds <- tcInstDecls2 (tyClGroupTyClDecls tycl_decls) inst_infos ; - - -- Foreign exports - traceTc "Tc7" empty ; - (foe_binds, foe_decls, foe_gres) <- tcForeignExports foreign_decls ; - - -- Annotations - annotations <- tcAnnotations annotation_decls ; - - -- Rules - rules <- tcRules rule_decls ; - - -- Wrap up - traceTc "Tc7a" empty ; - let { all_binds = inst_binds `unionBags` - foe_binds - - ; fo_gres = fi_gres `unionBags` foe_gres - ; fo_fvs = foldr (\gre fvs -> fvs `addOneFV` greMangledName gre) - emptyFVs fo_gres - - ; sig_names = mkNameSet (collectHsValBinders CollNoDictBinders hs_val_binds) - `minusNameSet` getTypeSigNames val_sigs - - -- 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_sigs = tcg_sigs tcg_env `unionNameSet` sig_names - , tcg_rules = tcg_rules tcg_env - ++ flattenRuleDecls rules - , tcg_anns = tcg_anns tcg_env ++ annotations - , tcg_ann_env = extendAnnEnvList (tcg_ann_env tcg_env) annotations - , tcg_fords = tcg_fords tcg_env ++ foe_decls ++ fi_decls - , tcg_dus = tcg_dus tcg_env `plusDU` usesOnly fo_fvs } } ; - -- tcg_dus: see Note [Newtype constructor usage in foreign declarations] - - -- See Note [Newtype constructor usage in foreign declarations] - addUsedGREs (bagToList fo_gres) ; - - return (tcg_env', tcl_env) - }}}}}} - -tcTopSrcDecls _ = panic "tcTopSrcDecls: ValBindsIn" - - -tcSemigroupWarnings :: TcM () -tcSemigroupWarnings = do - mod <- getModule - -- ghc-prim doesn't depend on base - unless (moduleUnit mod == primUnit) $ do - traceTc "tcSemigroupWarnings" empty - let warnFlag = Opt_WarnSemigroup - tcPreludeClashWarn warnFlag sappendName - tcMissingParentClassWarn warnFlag monoidClassName semigroupClassName - - --- | Warn on local definitions of names that would clash with future Prelude --- elements. --- --- A name clashes if the following criteria are met: --- 1. It would is imported (unqualified) from Prelude --- 2. It is locally defined in the current module --- 3. It has the same literal name as the reference function --- 4. It is not identical to the reference function -tcPreludeClashWarn :: WarningFlag - -> Name - -> TcM () -tcPreludeClashWarn warnFlag name = do - { warn <- woptM warnFlag - ; when warn $ do - { traceTc "tcPreludeClashWarn/wouldBeImported" empty - -- Is the name imported (unqualified) from Prelude? (Point 4 above) - ; rnImports <- fmap (map unLoc . tcg_rn_imports) getGblEnv - -- (Note that this automatically handles -XNoImplicitPrelude, as Prelude - -- will not appear in rnImports automatically if it is set.) - - -- Continue only the name is imported from Prelude - ; when (importedViaPrelude name rnImports) $ do - -- Handle 2.-4. - { rdrElts <- fmap (concat . nonDetOccEnvElts . tcg_rdr_env) getGblEnv - - ; let clashes :: GlobalRdrElt -> Bool - clashes x = isLocalDef && nameClashes && isNotInProperModule - where - isLocalDef = gre_lcl x == True - -- Names are identical ... - nameClashes = nameOccName (greMangledName x) == nameOccName name - -- ... but not the actual definitions, because we don't want to - -- warn about a bad definition of e.g. <> in Data.Semigroup, which - -- is the (only) proper place where this should be defined - isNotInProperModule = greMangledName x /= name - - -- List of all offending definitions - clashingElts :: [GlobalRdrElt] - clashingElts = filter clashes rdrElts - - ; traceTc "tcPreludeClashWarn/prelude_functions" - (hang (ppr name) 4 (sep [ppr clashingElts])) - - ; let warn_msg x = addDiagnosticAt (nameSrcSpan (greMangledName x)) $ - mkTcRnUnknownMessage $ - mkPlainDiagnostic (WarningWithFlag warnFlag) noHints $ (hsep - [ text "Local definition of" - , (quotes . ppr . nameOccName . greMangledName) x - , text "clashes with a future Prelude name." ] - $$ - text "This will become an error in a future release." ) - ; mapM_ warn_msg clashingElts - }}} - - where - - -- Is the given name imported via Prelude? - -- - -- Possible scenarios: - -- a) Prelude is imported implicitly, issue warnings. - -- b) Prelude is imported explicitly, but without mentioning the name in - -- question. Issue no warnings. - -- c) Prelude is imported hiding the name in question. Issue no warnings. - -- d) Qualified import of Prelude, no warnings. - importedViaPrelude :: Name - -> [ImportDecl GhcRn] - -> Bool - importedViaPrelude name = any importViaPrelude - where - isPrelude :: ImportDecl GhcRn -> Bool - isPrelude imp = unLoc (ideclName imp) == pRELUDE_NAME - - -- Implicit (Prelude) import? - isImplicit :: ImportDecl GhcRn -> Bool - isImplicit = ideclImplicit . ideclExt - - -- Unqualified import? - isUnqualified :: ImportDecl GhcRn -> Bool - isUnqualified = not . isImportDeclQualified . ideclQualified - - -- List of explicitly imported (or hidden) Names from a single import. - -- Nothing -> No explicit imports - -- Just (False, ) -> Explicit import list of - -- Just (True , ) -> Explicit hiding of - importListOf :: ImportDecl GhcRn -> Maybe (ImportListInterpretation, [Name]) - importListOf = fmap toImportList . ideclImportList - where - toImportList (h, loc) = (h, map (ieName . unLoc) (unLoc loc)) - - isExplicit :: ImportDecl GhcRn -> Bool - isExplicit x = case importListOf x of - Nothing -> False - Just (Exactly, explicit) - -> nameOccName name `elem` map nameOccName explicit - Just (EverythingBut, hidden) - -> nameOccName name `notElem` map nameOccName hidden - - -- Check whether the given name would be imported (unqualified) from - -- an import declaration. - importViaPrelude :: ImportDecl GhcRn -> Bool - importViaPrelude x = isPrelude x - && isUnqualified x - && (isImplicit x || isExplicit x) - - --- Notation: is* is for classes the type is an instance of, should* for those --- that it should also be an instance of based on the corresponding --- is*. -tcMissingParentClassWarn :: WarningFlag - -> Name -- ^ Instances of this ... - -> Name -- ^ should also be instances of this - -> TcM () -tcMissingParentClassWarn warnFlag isName shouldName - = do { warn <- woptM warnFlag - ; when warn $ do - { traceTc "tcMissingParentClassWarn" empty - ; isClass' <- tcLookupClass_maybe isName - ; shouldClass' <- tcLookupClass_maybe shouldName - ; case (isClass', shouldClass') of - (Just isClass, Just shouldClass) -> do - { localInstances <- tcGetInsts - ; let isInstance m = is_cls m == isClass - isInsts = filter isInstance localInstances - ; traceTc "tcMissingParentClassWarn/isInsts" (ppr isInsts) - ; forM_ isInsts (checkShouldInst isClass shouldClass) - } - (is',should') -> - traceTc "tcMissingParentClassWarn/notIsShould" - (hang (ppr isName <> text "/" <> ppr shouldName) 2 ( - (hsep [ quotes (text "Is"), text "lookup for" - , ppr isName - , text "resulted in", ppr is' ]) - $$ - (hsep [ quotes (text "Should"), text "lookup for" - , ppr shouldName - , text "resulted in", ppr should' ]))) - }} - where - -- Check whether the desired superclass exists in a given environment. - checkShouldInst :: Class -- Class of existing instance - -> Class -- Class there should be an instance of - -> ClsInst -- Existing instance - -> TcM () - checkShouldInst isClass shouldClass isInst - = do { instEnv <- tcGetInstEnvs - ; let (instanceMatches, shouldInsts, _) - = lookupInstEnv False instEnv shouldClass (is_tys isInst) - - ; traceTc "tcMissingParentClassWarn/checkShouldInst" - (hang (ppr isInst) 4 - (sep [ppr instanceMatches, ppr shouldInsts])) - - -- ": Warning: is an instance of but not - -- " e.g. "Foo is an instance of Monad but not Applicative" - ; let instLoc = srcLocSpan . nameSrcLoc $ getName isInst - warnMsg (RM_KnownTc name:_) = - addDiagnosticAt instLoc $ - mkTcRnUnknownMessage $ mkPlainDiagnostic (WarningWithFlag warnFlag) noHints $ - hsep [ (quotes . ppr . nameOccName) name - , text "is an instance of" - , (ppr . nameOccName . className) isClass - , text "but not" - , (ppr . nameOccName . className) shouldClass ] - <> text "." - $$ - hsep [ text "This will become an error in" - , text "a future release." ] - warnMsg _ = pure () - ; when (nullUnifiers shouldInsts && null instanceMatches) $ - warnMsg (is_tcs isInst) - } - - tcLookupClass_maybe :: Name -> TcM (Maybe Class) - tcLookupClass_maybe name = tcLookupImported_maybe name >>= \case - Succeeded (ATyCon tc) | cls@(Just _) <- tyConClass_maybe tc -> pure cls - _else -> pure Nothing - - ---------------------------- -tcTyClsInstDecls :: [TyClGroup GhcRn] - -> [LDerivDecl GhcRn] - -> [(RecFlag, LHsBinds GhcRn)] - -> TcM (TcGblEnv, -- The full inst env - [InstInfo GhcRn], -- Source-code instance decls to - -- process; contains all dfuns for - -- this module - ThBindEnv, -- TH binding levels - HsValBinds GhcRn) -- Supporting bindings for derived - -- instances - -tcTyClsInstDecls tycl_decls deriv_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@. - -- - -- Careful to quit now in case there were instance errors, so that - -- the deriving errors don't pile up as well. - ; failIfErrsM - ; (tcg_env', inst_info', val_binds) - <- tcInstDeclsDeriv deriv_info deriv_decls - ; setGblEnv tcg_env' $ do { - failIfErrsM - ; pure ( tcg_env', inst_info' ++ inst_info, th_bndrs, val_binds ) - }}} - -{- ********************************************************************* -* * - Checking for 'main' -* * -************************************************************************ --} - -checkMainType :: TcGblEnv -> TcRn WantedConstraints --- If this is the Main module, and it defines a function main, --- check that its type is of form IO tau. --- If not, do nothing --- See Note [Dealing with main] -checkMainType tcg_env - = do { hsc_env <- getTopEnv - ; if tcg_mod tcg_env /= mainModIs (hsc_HUE hsc_env) - then return emptyWC else - - do { rdr_env <- getGlobalRdrEnv - ; let dflags = hsc_dflags hsc_env - main_occ = getMainOcc dflags - main_gres = lookupGlobalRdrEnv rdr_env main_occ - ; case filter isLocalGRE main_gres of { - [] -> return emptyWC ; - (_:_:_) -> return emptyWC ; - [main_gre] -> - - do { let main_name = greMangledName main_gre - ctxt = FunSigCtxt main_name NoRRC - ; main_id <- tcLookupId main_name - ; (io_ty,_) <- getIOType - ; let main_ty = idType main_id - eq_orig = TypeEqOrigin { uo_actual = main_ty - , uo_expected = io_ty - , uo_thing = Nothing - , uo_visible = True } - ; (_, lie) <- captureTopConstraints $ - setMainCtxt main_name io_ty $ - tcSubTypeSigma eq_orig ctxt main_ty io_ty - ; return lie } } } } - -checkMain :: Bool -- False => no 'module M(..) where' header at all - -> Maybe (LocatedL [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 --- See Note [Dealing with main] -checkMain explicit_mod_hdr export_ies - = do { hsc_env <- getTopEnv - ; tcg_env <- getGblEnv - - ; let dflags = hsc_dflags hsc_env - main_mod = mainModIs (hsc_HUE hsc_env) - main_occ = getMainOcc dflags - - exported_mains :: [Name] - -- Exported things that are called 'main' - exported_mains = [ name | avail <- tcg_exports tcg_env - , name <- availNames avail - , nameOccName name == main_occ ] - - ; if | tcg_mod tcg_env /= main_mod - -> -- Not the main module - return tcg_env - - | [main_name] <- exported_mains - -> -- The module indeed exports a function called 'main' - generateMainBinding tcg_env main_name - - | otherwise - -> assert (null exported_mains) $ - -- A fully-checked export list can't contain more - -- than one function with the same OccName - do { complain_no_main dflags main_mod main_occ - ; return tcg_env } } - where - complain_no_main dflags main_mod main_occ - = unless (interactive && not explicit_mod_hdr) $ - addErrTc (noMainMsg main_mod main_occ) -- #12906 - where - interactive = ghcLink dflags == LinkInMemory - -- Without an explicit module header... - -- in interactive mode, don't worry about the absence of 'main'. - -- in other modes, add error message and go on with typechecking. - - noMainMsg main_mod main_occ - = mkTcRnUnknownMessage $ mkPlainError noHints $ - text "The" <+> ppMainFn main_occ - <+> text "is not" <+> text defOrExp <+> text "module" - <+> quotes (ppr main_mod) - - defOrExp | explicit_export_list = "exported by" - | otherwise = "defined in" - explicit_export_list = explicit_mod_hdr && isJust export_ies - --- | Get the unqualified name of the function to use as the \"main\" for the main module. --- Either returns the default name or the one configured on the command line with -main-is -getMainOcc :: DynFlags -> OccName -getMainOcc dflags = case mainFunIs dflags of - Just fn -> mkVarOccFS (mkFastString fn) - Nothing -> mainOcc - -ppMainFn :: OccName -> SDoc -ppMainFn main_occ - | main_occ == mainOcc - = text "IO action" <+> quotes (ppr main_occ) - | otherwise - = text "main IO action" <+> quotes (ppr main_occ) - -mainOcc :: OccName -mainOcc = mkVarOccFS (fsLit "main") - -generateMainBinding :: TcGblEnv -> Name -> TcM TcGblEnv --- There is a single exported 'main' function, called 'foo' (say), --- which may be locally defined or imported --- Define and typecheck the binding --- :Main.main :: IO res_ty = runMainIO res_ty foo --- This wraps the user's main function in the top-level stuff --- defined in runMainIO (eg catching otherwise un-caught exceptions) --- See Note [Dealing with main] -generateMainBinding tcg_env main_name = do - { 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)) - ; (ev_binds, main_expr) <- setMainCtxt main_name io_ty $ - tcCheckMonoExpr main_expr_rn io_ty - - -- See Note [Root-main Id] - -- Construct the binding - -- :Main.main :: IO res_ty = runMainIO res_ty main - ; run_main_id <- tcLookupId runMainIOName - ; let { root_main_name = mkExternalName rootMainKey rOOT_MAIN - (mkVarOccFS (fsLit "main")) - (getSrcSpan main_name) - ; root_main_id = Id.mkExportedVanillaId root_main_name io_ty - ; co = mkWpTyApps [res_ty] - -- The ev_binds of the `main` function may contain deferred - -- type errors when type of `main` is not `IO a`. The `ev_binds` - -- must be put inside `runMainIO` to ensure the deferred type - -- error can be emitted correctly. See #13838. - ; rhs = nlHsApp (mkLHsWrap co (nlHsVar run_main_id)) $ - mkHsDictLet ev_binds main_expr - ; main_bind = mkVarBind root_main_id rhs } - - ; return (tcg_env { tcg_main = Just main_name - , tcg_binds = tcg_binds tcg_env - `snocBag` main_bind - , tcg_dus = tcg_dus tcg_env - `plusDU` usesOnly (unitFV main_name) }) - -- Record the use of 'main', so that we don't - -- complain about it being defined but not used - } - -getIOType :: TcM (TcType, TcType) --- Return (IO alpha, alpha) for fresh alpha -getIOType = do { ioTyCon <- tcLookupTyCon ioTyConName - ; res_ty <- newFlexiTyVarTy liftedTypeKind - ; return (mkTyConApp ioTyCon [res_ty], res_ty) } - -setMainCtxt :: Name -> TcType -> TcM a -> TcM (TcEvBinds, a) -setMainCtxt main_name io_ty thing_inside - = setSrcSpan (getSrcSpan main_name) $ - addErrCtxt main_ctxt $ - 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] -~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Dealing with the 'main' declaration is surprisingly tricky. Here are -the moving parts: - -* The flag -main-is=M.foo allows you to set the main module to 'M', - and the main function to 'foo'. We access them through - mainModIs :: HscEnv -> Module -- returns M - getMainOcc :: DynFlags -> OccName -- returns foo - Of course usually M = Main, and foo = main. - -* checkMainType: when typechecking module M, we add an extra check that - foo :: IO tau, for some type tau. - This avoids getting ambiguous-type errors from the monomorphism restriction - applying to things like - main = return () - Note that checkMainType does not consult the export list because - we have not yet done rnExports (and can't do it until later). - -* rnExports: checks the export list. Very annoyingly, we can only do - this after running any finalisers, which may add new declarations. - That's why checkMainType and checkMain have to be separate. - -* checkMain: does two things: - - check that the export list does indeed export something called 'foo' - - generateMainBinding: generate the root-main binding - :Main.main = runMainIO M.foo - See Note [Root-main Id] - -An annoying consequence of having both checkMainType and checkMain is -that, when (but only when) -fdefer-type-errors is on, we may report an -ill-typed 'main' twice (as warnings): once in checkMainType and once -in checkMain. See test typecheck/should_fail/T13292. - -We have the following tests to check this processing: -----------------+----------------------------------------------------------------------------------+ - | Module Header: | - +-------------+-------------+-------------+-------------+-------------+------------+ - | module | module Main | | module Main |module |module Main | - | Main(main) | | | (module X)| Main () | (Sub.main)| -----------------+==================================================================================+ -`main` function | ERROR: | Main.main | ERROR: | Main.main | ERROR: | Sub.main | -in Main module | Ambiguous | | Ambiguous | | `main` not | | -and in imported | | | | | exported | | -module Sub. | T19397E1 | T16453M0 | T19397E2 | T16453M3 | | T16453M1 | - | | | | X = Main | Remark 2) | | -----------------+-------------+-------------+-------------+-------------+-------------+------------+ -`main`function | Sub.main | ERROR: | Sub.main | Sub.main | ERROR: | Sub.main | -only in imported| | No `main` in| | | `main` not | | -submodule Sub. | | `Main` | | | exported | | - | T19397M0 | T16453E1 | T19397M1 | T16453M4 | | T16453M5 | - | | | | X = Sub | Remark 2) | | -----------------+-------------+-------------+-------------+-------------+-------------+------------+ -`foo` function | Sub.foo | ERROR: | Sub.foo | Sub.foo | ERROR: | Sub.foo | -in submodule | | No `foo` in | | | `foo` not | | -Sub. | | `Main` | | | exported | | -GHC option: | | | | | | | - -main-is foo | T19397M2 | T19397E3 | T19397M3 | T19397M4 | T19397E4 | T16453M6 | - | Remark 1) | | | X = Sub | | Remark 3) | -----------------+-------------+-------------+-------------+-------------+-------------+------------+ - -Remarks: -* The first line shows the exported `main` function or the error. -* The second line shows the coresponding test case. -* The module `Sub` contains the following functions: - main :: IO () - foo :: IO () -* Remark 1) Here the header is `Main (foo)`. -* Remark 2) Here we have no extra test case. It would exercise the same code path as `T19397E4`. -* Remark 3) Here the header is `Main (Sub.foo)`. - - -Note [Root-main Id] -~~~~~~~~~~~~~~~~~~~ -The function that the RTS invokes is always :Main.main, which we call -root_main_id. (Because GHC allows the user to have a module not -called Main as the main module, we can't rely on the main function -being called "Main.main". That's why root_main_id has a fixed module -":Main".) - -This is unusual: it's a LocalId whose Name has a Module from another -module. Tiresomely, we must filter it out again in GHC.Iface.Make, less we -get two defns for 'main' in the interface file! - -When using `-fwrite-if-simplified-core` the root_main_id can end up in an interface file. -When the interface is read back in we have to add a special case when creating the -Id because otherwise we would go looking for the :Main module which obviously doesn't -exist. For this logic see GHC.IfaceToCore.mk_top_id. - -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. - - -********************************************************* -* * - GHCi stuff -* * -********************************************************* --} - -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 $ - do { traceTc "setInteractiveContext" $ - vcat [ text "ic_tythings:" <+> vcat (map ppr (ic_tythings icxt)) - , text "ic_insts:" <+> vcat (map (pprBndr LetBind . instanceDFunId) (instEnvElts ic_insts)) - , text "icReaderEnv (LocalDef)" <+> - vcat (map ppr [ local_gres | gres <- nonDetOccEnvElts (icReaderEnv icxt) - , 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) - - ; !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)) - (renameRawPkgQual (hsc_unit_env hsc_env) (unLoc $ ideclName i) (ideclPkgQual i)) - - ; let imports = emptyImportAvails { imp_orphs = orphs } - - upd_envs (gbl_env, lcl_env) = (gbl_env', lcl_env') - where - gbl_env' = gbl_env { tcg_rdr_env = icReaderEnv icxt - , tcg_type_env = type_env - - , tcg_inst_env = tcg_inst_env gbl_env `unionInstEnv` ic_insts `unionInstEnv` home_insts - , tcg_fam_inst_env = extendFamInstEnvList - (extendFamInstEnvList (tcg_fam_inst_env gbl_env) - ic_finsts) - home_fam_insts - , tcg_field_env = mkNameEnv con_fields - -- setting tcg_field_env is necessary - -- to make RecordWildCards work (test: ghci049) - , tcg_fix_env = ic_fix_env icxt - , tcg_default = ic_default icxt - -- must calculate imp_orphs of the ImportAvails - -- so that instance visibility is done correctly - , tcg_imports = imports } - - lcl_env' = tcExtendLocalTypeEnv lcl_env lcl_ids - - ; 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) - - is_closed :: TyThing -> Either (Name, TcTyThing) TyThing - -- Put Ids with free type variables (always RuntimeUnks) - -- in the *local* type environment - -- See Note [Initialising the type environment for GHCi] - is_closed thing - | AnId id <- thing - , not (isTypeClosedLetBndr id) - = Left (idName id, ATcId { tct_id = id - , tct_info = NotLetBound }) - | otherwise - = Right thing - - type_env1 = mkTypeEnvWithImplicits top_ty_things - type_env = extendTypeEnvWithIds type_env1 (map instanceDFunId (instEnvElts ic_insts)) - -- Putting the dfuns in the type_env - -- is just to keep Core Lint happy - - con_fields = [ (dataConName c, dataConFieldLabels c) - | ATyCon t <- top_ty_things - , c <- tyConDataCons t ] - - -{- Note [Initialising the type environment for GHCi] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Most of the Ids in ic_things, defined by the user in 'let' stmts, -have closed types. E.g. - ghci> let foo x y = x && not y - -However the GHCi debugger creates top-level bindings for Ids whose -types have free RuntimeUnk skolem variables, standing for unknown -types. If we don't register these free TyVars as global TyVars then -the typechecker will try to quantify over them and fall over in -skolemiseQuantifiedTyVar. so we must add any free TyVars to the -typechecker's global TyVar set. That is done by using -tcExtendLocalTypeEnv. - -We do this by splitting out the Ids with open types, using 'is_closed' -to do the partition. The top-level things go in the global TypeEnv; -the open, NotTopLevel, Ids, with free RuntimeUnk tyvars, go in the -local TypeEnv. - -Note that we don't extend the local RdrEnv (tcl_rdr); all the in-scope -things are already in the interactive context's GlobalRdrEnv. -Extending the local RdrEnv isn't terrible, but it means there is an -entry for the same Name in both global and local RdrEnvs, and that -lead to duplicate "perhaps you meant..." suggestions (e.g. T5564). - -We don't bother with the tcl_th_bndrs environment either. --} - --- | The returned [Id] is the list of new Ids bound by this statement. It can --- be used to extend the InteractiveContext via extendInteractiveContext. --- --- The returned TypecheckedHsExpr is of type IO [ () ], a list of the bound --- values, coerced to (). -tcRnStmt :: HscEnv -> GhciLStmt GhcPs - -> IO (Messages TcRnMessage, Maybe ([Id], LHsExpr GhcTc, FixityEnv)) -tcRnStmt hsc_env rdr_stmt - = runTcInteractive hsc_env $ do { - - -- The real work is done here - ((bound_ids, tc_expr), fix_env) <- tcUserStmt rdr_stmt ; - zonked_expr <- zonkTopLExpr tc_expr ; - zonked_ids <- zonkTopBndrs bound_ids ; - - failIfErrsM ; -- we can't do the next step if there are - -- representation polymorphism errors - -- test case: ghci/scripts/T13202{,a} - - -- None of the Ids should be of unboxed type, because we - -- cast them all to HValues in the end! - mapM_ bad_unboxed (filter (mightBeUnliftedType . idType) zonked_ids) ; - - traceTc "tcs 1" empty ; - this_mod <- getModule ; - global_ids <- mapM (externaliseAndTidyId this_mod) zonked_ids ; - -- Note [Interactively-bound Ids in GHCi] in GHC.Driver.Env - - traceOptTcRn Opt_D_dump_tc - (vcat [text "Bound Ids" <+> pprWithCommas ppr global_ids, - text "Typechecked expr" <+> ppr zonked_expr]) ; - - return (global_ids, zonked_expr, fix_env) - } - where - bad_unboxed id = addErr $ mkTcRnUnknownMessage $ mkPlainError noHints $ - (sep [text "GHCi can't bind a variable of unlifted type:", - nest 2 (pprPrefixOcc id <+> dcolon <+> ppr (idType id))]) - -{- --------------------------------------------------------------------------- - Typechecking Stmts in GHCi - -Here is the grand plan, implemented in tcUserStmt - - What you type The IO [HValue] that hscStmt returns - ------------- ------------------------------------ - let pat = expr ==> let pat = expr in return [coerce HVal x, coerce HVal y, ...] - bindings: [x,y,...] - - pat <- expr ==> expr >>= \ pat -> return [coerce HVal x, coerce HVal y, ...] - bindings: [x,y,...] - - expr (of IO type) ==> expr >>= \ it -> return [coerce HVal it] - [NB: result not printed] bindings: [it] - - expr (of non-IO type, ==> let it = expr in print it >> return [coerce HVal it] - result showable) bindings: [it] - - expr (of non-IO type, - result not showable) ==> error --} - --- | A plan is an attempt to lift some code into the IO monad. -type PlanResult = ([Id], LHsExpr GhcTc) -type Plan = TcM PlanResult - --- | Try the plans in order. If one fails (by raising an exn), try the next. --- If one succeeds, take it. -runPlans :: NonEmpty Plan -> Plan -runPlans = foldr1 (flip tryTcDiscardingErrs) - --- | Typecheck (and 'lift') a stmt entered by the user in GHCi into the --- GHCi 'environment'. --- --- By 'lift' and 'environment we mean that the code is changed to --- execute properly in an IO monad. See Note [Interactively-bound Ids --- in GHCi] in GHC.Driver.Env for more details. We do this lifting by trying --- different ways ('plans') of lifting the code into the IO monad and --- type checking each plan until one succeeds. -tcUserStmt :: GhciLStmt GhcPs -> TcM (PlanResult, FixityEnv) - --- An expression typed at the prompt is treated very specially -tcUserStmt (L loc (BodyStmt _ expr _ _)) - = do { (rn_expr, fvs) <- checkNoErrs (rnLExpr expr) - - ; dumpOptTcRn Opt_D_dump_rn_ast "Renamer" FormatHaskell - (showAstData NoBlankSrcSpan NoBlankEpAnnotations rn_expr) - -- Don't try to typecheck if the renamer fails! - ; ghciStep <- getGhciStepIO - ; uniq <- newUnique - ; let loc' = noAnnSrcSpan $ locA loc - ; interPrintName <- getInteractivePrintName - ; let fresh_it = itName uniq (locA loc) - matches = [mkMatch (mkPrefixFunRhs (L loc' fresh_it)) [] rn_expr - emptyLocalBinds] - -- [it = expr] - the_bind = L loc $ (mkTopFunBind FromSource - (L loc' fresh_it) matches) - { fun_ext = fvs } - -- Care here! In GHCi the expression might have - -- free variables, and they in turn may have free type variables - -- (if we are at a breakpoint, say). We must put those free vars - - -- [let it = expr] - let_stmt = L loc $ LetStmt noAnn $ HsValBinds noAnn - $ XValBindsLR - (NValBinds [(NonRecursive,unitBag the_bind)] []) - - -- [it <- e] - bind_stmt = L loc $ BindStmt - (XBindStmtRn - { xbsrn_bindOp = mkRnSyntaxExpr bindIOName - , xbsrn_failOp = Nothing - }) - (L loc (VarPat noExtField (L loc' fresh_it))) - (nlHsApp ghciStep rn_expr) - - -- [; print it] - print_it = L loc $ BodyStmt noExtField - (nlHsApp (nlHsVar interPrintName) - (nlHsVar fresh_it)) - (mkRnSyntaxExpr thenIOName) - noSyntaxExpr - - -- NewA - no_it_a = L loc $ BodyStmt noExtField (nlHsApps bindIOName - [rn_expr , nlHsVar interPrintName]) - (mkRnSyntaxExpr thenIOName) - noSyntaxExpr - - no_it_b = L loc $ BodyStmt noExtField (rn_expr) - (mkRnSyntaxExpr thenIOName) - noSyntaxExpr - - no_it_c = L loc $ BodyStmt noExtField - (nlHsApp (nlHsVar interPrintName) rn_expr) - (mkRnSyntaxExpr thenIOName) - noSyntaxExpr - - -- See Note [GHCi Plans] - - it_plans = - -- Plan A - do { stuff@([it_id], _) <- tcGhciStmts [bind_stmt, print_it] - ; it_ty <- zonkTcType (idType it_id) - ; when (isUnitTy it_ty) failM - ; return stuff } :| - - -- Plan B; a naked bind statement - [ tcGhciStmts [bind_stmt] - - -- Plan C; check that the let-binding is typeable all by itself. - -- If not, fail; if so, try to print it. - -- The two-step process avoids getting two errors: one from - -- the expression itself, and one from the 'print it' part - -- This two-step story is very clunky, alas - , do { _ <- checkNoErrs (tcGhciStmts [let_stmt]) - --- checkNoErrs defeats the error recovery of let-bindings - ; tcGhciStmts [let_stmt, print_it] } ] - - -- Plans where we don't bind "it" - no_it_plans = - tcGhciStmts [no_it_a] :| - tcGhciStmts [no_it_b] : - tcGhciStmts [no_it_c] : - [] - - ; generate_it <- goptM Opt_NoIt - - -- We disable `-fdefer-type-errors` in GHCi for naked expressions. - -- See Note [Deferred type errors in GHCi] - - -- NB: The flag `-fdefer-type-errors` implies `-fdefer-type-holes` - -- and `-fdefer-out-of-scope-variables`. However the flag - -- `-fno-defer-type-errors` doesn't imply `-fdefer-type-holes` and - -- `-fno-defer-out-of-scope-variables`. Thus the later two flags - -- also need to be unset here. - ; plan <- unsetGOptM Opt_DeferTypeErrors $ - unsetGOptM Opt_DeferTypedHoles $ - unsetGOptM Opt_DeferOutOfScopeVariables $ - runPlans $ if generate_it - then no_it_plans - else it_plans - - ; dumpOptTcRn Opt_D_dump_tc_ast "Typechecker AST" FormatHaskell - (showAstData NoBlankSrcSpan NoBlankEpAnnotations plan) - - ; fix_env <- getFixityEnv - ; return (plan, fix_env) } - -{- Note [Deferred type errors in GHCi] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In GHCi, we ensure that type errors don't get deferred when type checking the -naked expressions. Deferring type errors here is unhelpful because the -expression gets evaluated right away anyway. It also would potentially emit -two redundant type-error warnings, one from each plan. - -#14963 reveals another bug that when deferred type errors is enabled -in GHCi, any reference of imported/loaded variables (directly or indirectly) -in interactively issued naked expressions will cause ghc panic. See more -detailed discussion in #14963. - -The interactively issued declarations, statements, as well as the modules -loaded into GHCi, are not affected. That means, for declaration, you could -have - - Prelude> :set -fdefer-type-errors - Prelude> x :: IO (); x = putStrLn True - :14:26: warning: [-Wdeferred-type-errors] - ? Couldn't match type ‘Bool’ with ‘[Char]’ - Expected type: String - Actual type: Bool - ? In the first argument of ‘putStrLn’, namely ‘True’ - In the expression: putStrLn True - In an equation for ‘x’: x = putStrLn True - -But for naked expressions, you will have - - Prelude> :set -fdefer-type-errors - Prelude> putStrLn True - :2:10: error: - ? Couldn't match type ‘Bool’ with ‘[Char]’ - Expected type: String - Actual type: Bool - ? In the first argument of ‘putStrLn’, namely ‘True’ - In the expression: putStrLn True - In an equation for ‘it’: it = putStrLn True - - Prelude> let x = putStrLn True - :2:18: warning: [-Wdeferred-type-errors] - ? Couldn't match type ‘Bool’ with ‘[Char]’ - Expected type: String - Actual type: Bool - ? In the first argument of ‘putStrLn’, namely ‘True’ - In the expression: putStrLn True - In an equation for ‘x’: x = putStrLn True --} - -tcUserStmt rdr_stmt@(L loc _) - = do { (([rn_stmt], fix_env), fvs) <- checkNoErrs $ - rnStmts (HsDoStmt GhciStmtCtxt) rnExpr [rdr_stmt] $ \_ -> do - fix_env <- getFixityEnv - return (fix_env, emptyFVs) - -- Don't try to typecheck if the renamer fails! - ; traceRn "tcRnStmt" (vcat [ppr rdr_stmt, ppr rn_stmt, ppr fvs]) - ; rnDump rn_stmt ; - - ; ghciStep <- getGhciStepIO - ; let gi_stmt - | (L loc (BindStmt x pat expr)) <- rn_stmt - = L loc $ BindStmt x pat (nlHsApp ghciStep expr) - | otherwise = rn_stmt - - ; opt_pr_flag <- goptM Opt_PrintBindResult - ; let print_result_plan - | opt_pr_flag -- The flag says "print result" - , [v] <- collectLStmtBinders CollNoDictBinders gi_stmt -- One binder - = Just $ mk_print_result_plan gi_stmt v - | otherwise = Nothing - - -- The plans are: - -- [stmt; print v] if one binder and not v::() - -- [stmt] otherwise - ; plan <- runPlans $ maybe id (NE.<|) print_result_plan $ NE.singleton $ tcGhciStmts [gi_stmt] - ; return (plan, fix_env) } - where - mk_print_result_plan stmt v - = do { stuff@([v_id], _) <- tcGhciStmts [stmt, print_v] - ; v_ty <- zonkTcType (idType v_id) - ; when (isUnitTy v_ty || not (isTauTy v_ty)) failM - ; return stuff } - where - print_v = L loc $ BodyStmt noExtField (nlHsApp (nlHsVar printName) - (nlHsVar v)) - (mkRnSyntaxExpr thenIOName) noSyntaxExpr - -{- -Note [GHCi Plans] -~~~~~~~~~~~~~~~~~ -When a user types an expression in the repl we try to print it in three different -ways. Also, depending on whether -fno-it is set, we bind a variable called `it` -which can be used to refer to the result of the expression subsequently in the repl. - -The normal plans are : - A. [it <- e; print e] but not if it::() - B. [it <- e] - C. [let it = e; print it] - -When -fno-it is set, the plans are: - A. [e >>= print] - B. [e] - C. [let it = e in print it] - -The reason for -fno-it is explained in #14336. `it` can lead to the repl -leaking memory as it is repeatedly queried. --} - --- | Typecheck the statements given and then return the results of the --- statement in the form 'IO [()]'. -tcGhciStmts :: [GhciLStmt GhcRn] -> TcM PlanResult -tcGhciStmts stmts - = do { ioTyCon <- tcLookupTyCon ioTyConName - ; ret_id <- tcLookupId returnIOName -- return @ IO - ; let ret_ty = mkListTy unitTy - io_ret_ty = mkTyConApp ioTyCon [ret_ty] - tc_io_stmts = tcStmtsAndThen (HsDoStmt GhciStmtCtxt) tcDoStmt stmts - (mkCheckExpType io_ret_ty) - names = collectLStmtsBinders CollNoDictBinders stmts - - -- OK, we're ready to typecheck the stmts - ; traceTc "GHC.Tc.Module.tcGhciStmts: tc stmts" empty - ; ((tc_stmts, ids), lie) <- captureTopConstraints $ - tc_io_stmts $ \ _ -> - mapM tcLookupId names - -- Look up the names right in the middle, - -- where they will all be in scope - - -- Simplify the context - ; traceTc "GHC.Tc.Module.tcGhciStmts: simplify ctxt" empty - ; const_binds <- checkNoErrs (simplifyInteractive lie) - -- checkNoErrs ensures that the plan fails if context redn fails - - - ; traceTc "GHC.Tc.Module.tcGhciStmts: done" empty - - -- ret_expr is the expression - -- returnIO @[()] [unsafeCoerce# () x, .., unsafeCoerce# () z] - -- - -- Despite the inconvenience of building the type applications etc, - -- this *has* to be done in type-annotated post-typecheck form - -- because we are going to return a list of *polymorphic* values - -- coerced to type (). If we built a *source* stmt - -- return [coerce x, ..., coerce z] - -- then the type checker would instantiate x..z, and we wouldn't - -- get their *polymorphic* values. (And we'd get ambiguity errs - -- if they were overloaded, since they aren't applied to anything.) - - ; AnId unsafe_coerce_id <- tcLookupGlobal unsafeCoercePrimName - -- We use unsafeCoerce# here because of (U11) in - -- Note [Implementing unsafeCoerce] in base:Unsafe.Coerce - - ; let ret_expr = nlHsApp (nlHsTyApp ret_id [ret_ty]) $ - noLocA $ ExplicitList unitTy $ - map mk_item ids - - mk_item id = unsafe_coerce_id `nlHsTyApp` [ getRuntimeRep (idType id) - , getRuntimeRep unitTy - , idType id, unitTy] - `nlHsApp` nlHsVar id - stmts = tc_stmts ++ [noLocA (mkLastStmt ret_expr)] - - ; return (ids, mkHsDictLet (EvBinds const_binds) $ - noLocA (HsDo io_ret_ty GhciStmtCtxt (noLocA stmts))) - } - --- | Generate a typed ghciStepIO expression (ghciStep :: Ty a -> IO a) -getGhciStepIO :: TcM (LHsExpr GhcRn) -getGhciStepIO = do - ghciTy <- getGHCiMonad - a_tv <- newName (mkTyVarOccFS (fsLit "a")) - let ghciM = nlHsAppTy (nlHsTyVar NotPromoted ghciTy) (nlHsTyVar NotPromoted a_tv) - ioM = nlHsAppTy (nlHsTyVar NotPromoted ioTyConName) (nlHsTyVar NotPromoted a_tv) - - step_ty :: LHsSigType GhcRn - step_ty = noLocA $ HsSig - { sig_bndrs = HsOuterImplicit{hso_ximplicit = [a_tv]} - , sig_ext = noExtField - , sig_body = nlHsFunTy ghciM ioM } - - stepTy :: LHsSigWcType GhcRn - stepTy = mkEmptyWildCardBndrs step_ty - - return (noLocA $ ExprWithTySig noExtField (nlHsVar ghciStepIoMName) stepTy) - -isGHCiMonad :: HscEnv -> String -> IO (Messages TcRnMessage, Maybe Name) -isGHCiMonad hsc_env ty - = runTcInteractive hsc_env $ do - rdrEnv <- getGlobalRdrEnv - let occIO = lookupOccEnv rdrEnv (mkOccName tcName ty) - case occIO of - Just [n] -> do - let name = greMangledName n - ghciClass <- tcLookupClass ghciIoClassName - userTyCon <- tcLookupTyCon name - let userTy = mkTyConApp userTyCon [] - _ <- tcLookupInstance ghciClass [userTy] - return name - - Just _ -> failWithTc $ mkTcRnUnknownMessage $ mkPlainError noHints $ text "Ambiguous type!" - Nothing -> failWithTc $ mkTcRnUnknownMessage $ mkPlainError noHints $ text ("Can't find type:" ++ ty) - --- | How should we infer a type? See Note [TcRnExprMode] -data TcRnExprMode = TM_Inst -- ^ Instantiate inferred quantifiers only (:type) - | TM_Default -- ^ Instantiate all quantifiers, - -- and do eager defaulting (:type +d) - --- | tcRnExpr just finds the type of an expression --- for :type -tcRnExpr :: HscEnv - -> TcRnExprMode - -> LHsExpr GhcPs - -> IO (Messages TcRnMessage, Maybe Type) -tcRnExpr hsc_env mode rdr_expr - = runTcInteractive hsc_env $ - do { - - (rn_expr, _fvs) <- rnLExpr rdr_expr ; - failIfErrsM ; - - -- Typecheck the expression - ((tclvl, res_ty), lie) - <- captureTopConstraints $ - pushTcLevelM $ - tcInferSigma inst rn_expr ; - - -- Generalise - uniq <- newUnique ; - let { fresh_it = itName uniq (getLocA rdr_expr) } ; - ((qtvs, dicts, _, _), residual) - <- captureConstraints $ - simplifyInfer tclvl infer_mode - [] {- No sig vars -} - [(fresh_it, res_ty)] - lie ; - - -- Ignore the dictionary bindings - _ <- perhaps_disable_default_warnings $ - simplifyInteractive residual ; - - let { all_expr_ty = mkInfForAllTys qtvs $ - mkPhiTy (map idType dicts) res_ty } ; - ty <- zonkTcType all_expr_ty ; - - -- See Note [Normalising the type in :type] - fam_envs <- tcGetFamInstEnvs ; - let { normalised_type = reductionReducedType $ normaliseType fam_envs Nominal ty - -- normaliseType returns a coercion which we discard, so the Role is irrelevant. - ; final_type = if isSigmaTy res_ty then ty else normalised_type } ; - return final_type } - where - -- Optionally instantiate the type of the expression - -- See Note [TcRnExprMode] - (inst, infer_mode, perhaps_disable_default_warnings) = case mode of - TM_Inst -> (False, NoRestrictions, id) - TM_Default -> (True, EagerDefaulting, unsetWOptM Opt_WarnTypeDefaults) - -{- Note [Implementing :type] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider :type const - -We want forall a b. a -> b -> a -and not forall {a}{b}. a -> b -> a - -The latter is what we'd get if we eagerly instantiated and then -re-generalised with Inferred binders. It makes a difference, because -it tells us we where we can use Visible Type Application (VTA). - -And also for :type const @Int -we want forall b. Int -> b -> Int -and not forall {b}. Int -> b -> Int - -Solution: use tcInferSigma, which in turn uses tcInferApp, which -has a special case for application chains. - -Note [Normalising the type in :type] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In :t we usually normalise the type (to simplify type functions) -before displaying the result. Reason (see #10321): otherwise we may show -types like - :: Vec (1+2) Int -rather than the simpler - :: Vec 3 Int -In GHC.Tc.Gen.Bind.mkInferredPolyId we normalise for a very similar reason. - -However this normalisation is less helpful when is just -an identifier, whose user-written type happens to contain type-function -applications. E.g. (#20974) - test :: F [Monad, A, B] m => m () -where F is a type family. If we say `:t test`, we'd prefer to see -the type family un-expanded. - -We adopt the following ad-hoc solution: if the type inferred for -(before generalisation, namely res_ty) is a SigmaType (i.e. is not -fully instantiated) then do not normalise; otherwise normalise. -This is not ideal; for example, suppose x :: F Int. Then - :t x -would be normalised because `F Int` is not a SigmaType. But -anything here is ad-hoc, and it's a user-sought improvement. --} - --------------------------- -tcRnImportDecls :: HscEnv - -> [LImportDecl GhcPs] - -> IO (Messages TcRnMessage, Maybe GlobalRdrEnv) --- Find the new chunk of GlobalRdrEnv created by this list of import --- 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 - ; return (tcg_rdr_env gbl_env) } - where - zap_rdr_env gbl_env = gbl_env { tcg_rdr_env = emptyGlobalRdrEnv } - --- tcRnType just finds the kind of a type -tcRnType :: HscEnv - -> ZonkFlexi - -> Bool -- Normalise the returned type - -> LHsType GhcPs - -> IO (Messages TcRnMessage, Maybe (Type, Kind)) -tcRnType hsc_env flexi normalise rdr_type - = runTcInteractive hsc_env $ - setXOptM LangExt.PolyKinds $ -- See Note [Kind-generalise in tcRnType] - do { (HsWC { hswc_ext = wcs, hswc_body = rn_sig_type@(L _ (HsSig{sig_bndrs = outer_bndrs, sig_body = body })) }, _fvs) - -- we are using 'rnHsSigWcType' to bind the unbound type variables - -- and in combination with 'tcOuterTKBndrs' we are able to - -- implicitly quantify them as if the user wrote 'forall' by - -- hand (see #19217). This allows kind check to work in presence - -- of free type variables : - -- ghci> :k [a] - -- [a] :: * - <- rnHsSigWcType GHCiCtx (mkHsWildCardBndrs $ noLocA (mkHsImplicitSigType rdr_type)) - -- The type can have wild cards, but no implicit - -- generalisation; e.g. :kind (T _) - ; failIfErrsM - - -- We follow Note [Recipe for checking a signature] in GHC.Tc.Gen.HsType here - - -- Now kind-check the type - -- It can have any rank or kind - -- First bring into scope any wildcards - ; traceTc "tcRnType" (vcat [ppr wcs, ppr rn_sig_type]) - ; si <- mkSkolemInfo $ SigTypeSkol (GhciCtxt True) - ; ((_, (ty, kind)), wanted) - <- captureTopConstraints $ - pushTcLevelM_ $ - bindNamedWildCardBinders wcs $ \ wcs' -> - do { mapM_ emitNamedTypeHole wcs' - ; tcOuterTKBndrs si outer_bndrs $ tcInferLHsTypeUnsaturated body } - -- Since all the wanteds are equalities, the returned bindings will be empty - ; empty_binds <- simplifyTop wanted - ; massertPpr (isEmptyBag empty_binds) (ppr empty_binds) - - -- Do kind generalisation; see Note [Kind-generalise in tcRnType] - ; kvs <- kindGeneralizeAll unkSkol kind - - ; e <- mkEmptyZonkEnv flexi - ; ty <- zonkTcTypeToTypeX e ty - - -- Do validity checking on type - ; checkValidType (GhciCtxt True) ty - - -- Optionally (:k vs :k!) normalise the type. Does two things: - -- normaliseType: expand type-family applications - -- expandTypeSynonyms: expand type synonyms (#18828) - ; fam_envs <- tcGetFamInstEnvs - ; let ty' | normalise = expandTypeSynonyms $ reductionReducedType $ - normaliseType fam_envs Nominal ty - | otherwise = ty - - ; traceTc "tcRnExpr" (debugPprType ty $$ debugPprType ty') - ; return (ty', mkInfForAllTys kvs (typeKind ty')) } - - -{- Note [TcRnExprMode] -~~~~~~~~~~~~~~~~~~~~~~ -How should we infer a type when a user asks for the type of an expression e -at the GHCi prompt? We offer 2 different possibilities, described below. Each -considers this example, with -fprint-explicit-foralls enabled. See also -https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0179-printing-foralls.rst - -:type / TM_Inst - - In this mode, we report the type obtained by instantiating only the - /inferred/ quantifiers of e's type, solving constraints, and - re-generalising, as discussed in #11376. - - > :type reverse - reverse :: forall a. [a] -> [a] - - -- foo :: forall a f b. (Show a, Num b, Foldable f) => a -> f b -> String - > :type foo @Int - forall f b. (Show Int, Num b, Foldable f) => Int -> f b -> String - - Note that Show Int is still reported, because the solver never got a chance - to see it. - -:type +d / TM_Default - - This mode is for the benefit of users who wish to see instantiations - of generalized types, and in particular to instantiate Foldable and - Traversable. In this mode, all type variables (inferred or - specified) are instantiated. Because GHCi uses - -XExtendedDefaultRules, this means that Foldable and Traversable are - defaulted. - - > :type +d reverse - reverse :: forall {a}. [a] -> [a] - - -- foo :: forall a f b. (Show a, Num b, Foldable f) => a -> f b -> String - > :type +d foo @Int - Int -> [Integer] -> String - - Note that this mode can sometimes lead to a type error, if a type variable is - used with a defaultable class but cannot actually be defaulted: - - bar :: (Num a, Monoid a) => a -> a - > :type +d bar - ** error ** - - The error arises because GHC tries to default a but cannot find a concrete - type in the defaulting list that is both Num and Monoid. (If this list is - modified to include an element that is both Num and Monoid, the defaulting - would succeed, of course.) - - Note that the variables and constraints are reordered here, because this - is possible during regeneralization. Also note that the variables are - reported as Inferred instead of Specified. - -Note [Kind-generalise in tcRnType] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We switch on PolyKinds when kind-checking a user type, so that we will -kind-generalise the type, even when PolyKinds is not otherwise on. -This gives the right default behaviour at the GHCi prompt, where if -you say ":k T", and T has a polymorphic kind, you'd like to see that -polymorphism. Of course. If T isn't kind-polymorphic you won't get -anything unexpected, but the apparent *loss* of polymorphism, for -types that you know are polymorphic, is quite surprising. See Trac -#7688 for a discussion. - -Note that the goal is to generalise the *kind of the type*, not -the type itself! Example: - ghci> data SameKind :: k -> k -> Type - ghci> :k SameKind _ - -We want to get `k -> Type`, not `Any -> Type`, which is what we would -get without kind-generalisation. Note that `:k SameKind` is OK, as -GHC will not instantiate SameKind here, and so we see its full kind -of `forall k. k -> k -> Type`. - -************************************************************************ -* * - tcRnDeclsi -* * -************************************************************************ - -tcRnDeclsi exists to allow class, data, and other declarations in GHCi. --} - -tcRnDeclsi :: HscEnv - -> [LHsDecl GhcPs] - -> IO (Messages TcRnMessage, Maybe TcGblEnv) -tcRnDeclsi hsc_env local_decls - = runTcInteractive hsc_env $ - tcRnSrcDecls False Nothing local_decls - -externaliseAndTidyId :: Module -> Id -> TcM Id -externaliseAndTidyId this_mod id - = do { name' <- externaliseName this_mod (idName id) - ; return $ globaliseId id - `setIdName` name' - `setIdType` tidyTopType (idType id) } - - -{- -************************************************************************ -* * - More GHCi stuff, to do with browsing and getting info -* * -************************************************************************ --} - --- | ASSUMES that the module is either in the 'HomePackageTable' or is --- a package module with an interface on disk. If neither of these is --- true, then the result will be an error indicating the interface --- could not be found. -getModuleInterface :: HscEnv -> Module -> IO (Messages TcRnMessage, Maybe ModIface) -getModuleInterface hsc_env mod - = runTcInteractive hsc_env $ - loadModuleInterface (text "getModuleInterface") mod - -tcRnLookupRdrName :: HscEnv -> LocatedN RdrName - -> IO (Messages TcRnMessage, Maybe [Name]) --- ^ Find all the Names that this RdrName could mean, in GHCi -tcRnLookupRdrName hsc_env (L loc rdr_name) - = runTcInteractive hsc_env $ - setSrcSpanA loc $ - do { -- If the identifier is a constructor (begins with an - -- upper-case letter), then we need to consider both - -- constructor and type class identifiers. - let rdr_names = dataTcOccs rdr_name - ; names_s <- mapM lookupInfoOccRn rdr_names - ; let names = concat names_s - ; when (null names) (addErrTc $ mkTcRnUnknownMessage $ mkPlainError noHints $ - (text "Not in scope:" <+> quotes (ppr rdr_name))) - ; return names } - -tcRnLookupName :: HscEnv -> Name -> IO (Messages TcRnMessage, Maybe TyThing) -tcRnLookupName hsc_env name - = runTcInteractive hsc_env $ - tcRnLookupName' name - --- To look up a name we have to look in the local environment (tcl_lcl) --- as well as the global environment, which is what tcLookup does. --- But we also want a TyThing, so we have to convert: - -tcRnLookupName' :: Name -> TcRn TyThing -tcRnLookupName' name = do - tcthing <- tcLookup name - case tcthing of - AGlobal thing -> return thing - ATcId{tct_id=id} -> return (AnId id) - _ -> panic "tcRnLookupName'" - -tcRnGetInfo :: HscEnv - -> Name - -> IO ( Messages TcRnMessage - , Maybe (TyThing, Fixity, [ClsInst], [FamInst], SDoc)) - --- Used to implement :info in GHCi --- --- Look up a RdrName and return all the TyThings it might be --- A capitalised RdrName is given to us in the DataName namespace, --- but we want to treat it as *both* a data constructor --- *and* as a type or class constructor; --- hence the call to dataTcOccs, and we return up to two results -tcRnGetInfo hsc_env name - = runTcInteractive hsc_env $ - do { loadUnqualIfaces hsc_env (hsc_IC hsc_env) - -- Load the interface for all unqualified types and classes - -- That way we will find all the instance declarations - -- (Packages have not orphan modules, and we assume that - -- in the home package all relevant modules are loaded.) - - ; thing <- tcRnLookupName' name - ; fixity <- lookupFixityRn name - ; (cls_insts, fam_insts) <- lookupInsts thing - ; let info = lookupKnownNameInfo name - ; return (thing, fixity, cls_insts, fam_insts, info) } - - --- Lookup all class and family instances for a type constructor. --- --- This function filters all instances in the type environment, so there --- is a lot of duplicated work if it is called many times in the same --- type environment. If this becomes a problem, the NameEnv computed --- in GHC.getNameToInstancesIndex could be cached in TcM and both functions --- could be changed to consult that index. -lookupInsts :: TyThing -> TcM ([ClsInst],[FamInst]) -lookupInsts (ATyCon tc) - = do { InstEnvs { ie_global = pkg_ie, ie_local = home_ie, ie_visible = vis_mods } <- tcGetInstEnvs - ; (pkg_fie, home_fie) <- tcGetFamInstEnvs - -- Load all instances for all classes that are - -- in the type environment (which are all the ones - -- we've seen in any interface file so far) - - -- Return only the instances relevant to the given thing, i.e. - -- the instances whose head contains the thing's name. - ; let cls_insts = - [ ispec -- Search all - | ispec <- instEnvElts home_ie ++ instEnvElts pkg_ie - , instIsVisible vis_mods ispec - , tc_name `elemNameSet` orphNamesOfClsInst ispec ] - ; let fam_insts = - [ fispec - | fispec <- famInstEnvElts home_fie ++ famInstEnvElts pkg_fie - , tc_name `elemNameSet` orphNamesOfFamInst fispec ] - ; return (cls_insts, fam_insts) } - where - tc_name = tyConName tc - -lookupInsts _ = return ([],[]) - -loadUnqualIfaces :: HscEnv -> InteractiveContext -> TcM () --- Load the interface for everything that is in scope unqualified --- This is so that we can accurately report the instances for --- something -loadUnqualIfaces hsc_env ictxt - = initIfaceTcRn $ - mapM_ (loadSysInterface doc) (moduleSetElts (mkModuleSet unqual_mods)) - where - home_unit = hsc_home_unit hsc_env - - unqual_mods = [ nameModule name - | gre <- globalRdrEnvElts (icReaderEnv ictxt) - , let name = greMangledName gre - , nameIsFromExternalPackage home_unit name - , isTcOcc (nameOccName name) -- Types and classes only - , unQualOK gre ] -- In scope unqualified - doc = text "Need interface for module whose export(s) are in scope unqualified" - - - -{- -************************************************************************ -* * - Debugging output - This is what happens when you do -ddump-types -* * -************************************************************************ --} - --- | Dump, with a banner, if -ddump-rn -rnDump :: (Outputable a, Data a) => a -> TcRn () -rnDump rn = dumpOptTcRn Opt_D_dump_rn "Renamer" FormatHaskell (ppr rn) - -tcDump :: TcGblEnv -> TcRn () -tcDump env - = do { unit_state <- hsc_units <$> getTopEnv ; - logger <- getLogger ; - - -- Dump short output if -ddump-types or -ddump-tc - when (logHasDumpFlag logger Opt_D_dump_types || logHasDumpFlag logger Opt_D_dump_tc) - (dumpTcRn True Opt_D_dump_types - "" FormatText (pprWithUnitState unit_state short_dump)) ; - - -- Dump bindings if -ddump-tc - dumpOptTcRn Opt_D_dump_tc "Typechecker" FormatHaskell full_dump; - - -- Dump bindings as an hsSyn AST if -ddump-tc-ast - dumpOptTcRn Opt_D_dump_tc_ast "Typechecker AST" FormatHaskell ast_dump - } - where - short_dump = pprTcGblEnv env - full_dump = pprLHsBinds (tcg_binds env) - -- NB: foreign x-d's have undefined's in their types; - -- hence can't show the tc_fords - ast_dump = showAstData NoBlankSrcSpan NoBlankEpAnnotations (tcg_binds env) - --- It's unpleasant having both pprModGuts and pprModDetails here -pprTcGblEnv :: TcGblEnv -> SDoc -pprTcGblEnv (TcGblEnv { tcg_type_env = type_env, - tcg_insts = insts, - tcg_fam_insts = fam_insts, - tcg_rules = rules, - tcg_imports = imports }) - = getPprDebug $ \debug -> - vcat [ ppr_types debug type_env - , ppr_tycons debug fam_insts type_env - , ppr_datacons debug type_env - , ppr_patsyns type_env - , ppr_insts insts - , ppr_fam_insts fam_insts - , ppr_rules rules - , text "Dependent modules:" <+> - (ppr . sort . installedModuleEnvElts $ imp_direct_dep_mods imports) - , text "Dependent packages:" <+> - ppr (S.toList $ imp_dep_direct_pkgs imports)] - -- The use of sort is just to reduce unnecessary - -- wobbling in testsuite output - -ppr_rules :: [LRuleDecl GhcTc] -> SDoc -ppr_rules rules - = ppUnless (null rules) $ - hang (text "RULES") - 2 (vcat (map ppr rules)) - -ppr_types :: Bool -> TypeEnv -> SDoc -ppr_types debug type_env - = ppr_things "TYPE SIGNATURES" ppr_sig - (sortBy (comparing getOccName) ids) - where - ids = [id | id <- typeEnvIds type_env, want_sig id] - want_sig id - | debug = True - | otherwise = hasTopUserName id - && case idDetails id of - VanillaId -> True - WorkerLikeId{} -> True - RecSelId {} -> True - ClassOpId {} -> True - FCallId {} -> True - _ -> False - -- Data cons (workers and wrappers), pattern synonyms, - -- etc are suppressed (unless -dppr-debug), - -- because they appear elsewhere - - ppr_sig id = hang (pprPrefixOcc id <+> dcolon) 2 (ppr (tidyTopType (idType id))) - -ppr_tycons :: Bool -> [FamInst] -> TypeEnv -> SDoc -ppr_tycons debug fam_insts type_env - = vcat [ ppr_things "TYPE CONSTRUCTORS" ppr_tc tycons - , ppr_things "COERCION AXIOMS" ppr_ax - (typeEnvCoAxioms type_env) ] - where - fi_tycons = famInstsRepTyCons fam_insts - - tycons = sortBy (comparing getOccName) $ - [tycon | tycon <- typeEnvTyCons type_env - , want_tycon tycon] - -- Sort by OccName to reduce unnecessary changes - want_tycon tycon | debug = True - | otherwise = isExternalName (tyConName tycon) && - not (tycon `elem` fi_tycons) - ppr_tc tc - = vcat [ hang (ppr (tyConFlavour tc) <+> pprPrefixOcc (tyConName tc) - <> braces (ppr (tyConArity tc)) <+> dcolon) - 2 (ppr (tidyTopType (tyConKind tc))) - , nest 2 $ - ppWhen show_roles $ - text "roles" <+> (sep (map ppr roles)) ] - where - show_roles = debug || not (all (== boring_role) roles) - roles = tyConRoles tc - boring_role | isClassTyCon tc = Nominal - | otherwise = Representational - -- Matches the choice in GHC.Iface.Syntax, calls to pprRoles - - ppr_ax ax = ppr (coAxiomToIfaceDecl ax) - -- We go via IfaceDecl rather than using pprCoAxiom - -- This way we get the full axiom (both LHS and RHS) with - -- wildcard binders tidied to _1, _2, etc. - -ppr_datacons :: Bool -> TypeEnv -> SDoc -ppr_datacons debug type_env - = ppr_things "DATA CONSTRUCTORS" ppr_dc wanted_dcs - -- The filter gets rid of class data constructors - where - ppr_dc dc = sdocOption sdocLinearTypes (\show_linear_types -> - ppr dc <+> dcolon <+> ppr (dataConDisplayType show_linear_types dc)) - all_dcs = typeEnvDataCons type_env - wanted_dcs | debug = all_dcs - | otherwise = filterOut is_cls_dc all_dcs - is_cls_dc dc = isClassTyCon (dataConTyCon dc) - -ppr_patsyns :: TypeEnv -> SDoc -ppr_patsyns type_env - = ppr_things "PATTERN SYNONYMS" ppr_ps - (typeEnvPatSyns type_env) - where - ppr_ps ps = pprPrefixOcc ps <+> dcolon <+> pprPatSynType ps - -ppr_insts :: [ClsInst] -> SDoc -ppr_insts ispecs - = ppr_things "CLASS INSTANCES" pprInstance ispecs - -ppr_fam_insts :: [FamInst] -> SDoc -ppr_fam_insts fam_insts - = ppr_things "FAMILY INSTANCES" pprFamInst fam_insts - -ppr_things :: String -> (a -> SDoc) -> [a] -> SDoc -ppr_things herald ppr_one things - | null things = empty - | otherwise = text herald $$ nest 2 (vcat (map ppr_one things)) - -hasTopUserName :: NamedThing x => x -> Bool --- A top-level thing whose name is not "derived" --- Thus excluding things like $tcX, from Typeable boilerplate --- and C:Coll from class-dictionary data constructors -hasTopUserName x - = isExternalName name && not (isDerivedOccName (nameOccName name)) - where - name = getName x - -{- -******************************************************************************** - -Type Checker Plugins - -******************************************************************************** --} - -withTcPlugins :: HscEnv -> TcM a -> TcM a -withTcPlugins hsc_env m = - case catMaybes $ mapPlugins (hsc_plugins hsc_env) tcPlugin of - [] -> m -- Common fast case - plugins -> do - (solvers, rewriters, stops) <- - unzip3 `fmap` mapM start_plugin plugins - let - rewritersUniqFM :: UniqFM TyCon [TcPluginRewriter] - !rewritersUniqFM = sequenceUFMList rewriters - -- The following ensures that tcPluginStop is called even if a type - -- error occurs during compilation (Fix of #10078) - eitherRes <- tryM $ - updGblEnv (\e -> e { tcg_tc_plugin_solvers = solvers - , tcg_tc_plugin_rewriters = rewritersUniqFM }) m - mapM_ runTcPluginM stops - case eitherRes of - Left _ -> failM - Right res -> return res - where - start_plugin (TcPlugin start solve rewrite stop) = - do s <- runTcPluginM start - return (solve s, rewrite s, stop s) - -withDefaultingPlugins :: HscEnv -> TcM a -> TcM a -withDefaultingPlugins hsc_env m = - do case catMaybes $ mapPlugins (hsc_plugins hsc_env) defaultingPlugin of - [] -> m -- Common fast case - plugins -> do (plugins,stops) <- mapAndUnzipM start_plugin plugins - -- This ensures that dePluginStop is called even if a type - -- error occurs during compilation - eitherRes <- tryM $ do - updGblEnv (\e -> e { tcg_defaulting_plugins = plugins }) m - mapM_ runTcPluginM stops - case eitherRes of - Left _ -> failM - Right res -> return res - where - start_plugin (DefaultingPlugin start fill stop) = - do s <- runTcPluginM start - return (fill s, stop s) - -withHoleFitPlugins :: HscEnv -> TcM a -> TcM a -withHoleFitPlugins hsc_env m = - case catMaybes $ mapPlugins (hsc_plugins hsc_env) holeFitPlugin of - [] -> m -- Common fast case - plugins -> do (plugins,stops) <- mapAndUnzipM start_plugin plugins - -- This ensures that hfPluginStop is called even if a type - -- error occurs during compilation. - eitherRes <- tryM $ - updGblEnv (\e -> e { tcg_hf_plugins = plugins }) m - sequence_ stops - case eitherRes of - Left _ -> failM - Right res -> return res - where - start_plugin (HoleFitPluginR init plugin stop) = - do ref <- init - return (plugin ref, stop ref) - - -runRenamerPlugin :: TcGblEnv - -> HsGroup GhcRn - -> TcM (TcGblEnv, HsGroup GhcRn) -runRenamerPlugin gbl_env hs_group = do - hsc_env <- getTopEnv - withPlugins (hsc_plugins hsc_env) - (\p opts (e, g) -> ( mark_plugin_unsafe (hsc_dflags hsc_env) - >> renamedResultAction p opts e g)) - (gbl_env, hs_group) - - --- XXX: should this really be a Maybe X? Check under which circumstances this --- can become a Nothing and decide whether this should instead throw an --- exception/signal an error. -type RenamedStuff = - (Maybe (HsGroup GhcRn, [LImportDecl GhcRn], Maybe [(LIE GhcRn, Avails)], - Maybe (LHsDoc GhcRn))) - --- | 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_decls tc_result) - -runTypecheckerPlugin :: ModSummary -> TcGblEnv -> TcM TcGblEnv -runTypecheckerPlugin sum gbl_env = do - hsc_env <- getTopEnv - withPlugins (hsc_plugins hsc_env) - (\p opts env -> mark_plugin_unsafe (hsc_dflags hsc_env) - >> typeCheckResultAction p opts sum env) - gbl_env - -mark_plugin_unsafe :: DynFlags -> TcM () -mark_plugin_unsafe dflags = unless (gopt Opt_PluginTrustworthy dflags) $ - recordUnsafeInfer pluginUnsafe - where - !diag_opts = initDiagOpts dflags - pluginUnsafe = - singleMessage $ - mkPlainMsgEnvelope diag_opts noSrcSpan TcRnUnsafeDueToPlugin +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NondecreasingIndentation #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE MultiWayIf #-} + +{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} + +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + +-} + +-- | Typechecking a whole module +-- +-- https://gitlab.haskell.org/ghc/ghc/wikis/commentary/compiler/type-checker +module GHC.Tc.Module ( + tcRnStmt, tcRnExpr, TcRnExprMode(..), + tcRnType, tcRnTypeSkolemising, + tcRnImportDecls, + tcRnLookupRdrName, + getModuleInterface, + tcRnDeclsi, + isGHCiMonad, + runTcInteractive, -- Used by GHC API clients (#8878) + withTcPlugins, -- Used by GHC API clients (#20499) + withHoleFitPlugins, -- Used by GHC API clients (#20499) + tcRnLookupName, + tcRnGetInfo, + tcRnModule, tcRnModuleTcRnM, + tcTopSrcDecls, + rnTopSrcDecls, + checkBootDecl, checkHiBootIface', + findExtraSigImports, + implicitRequirements, + checkUnit, + mergeSignatures, + tcRnMergeSignatures, + instantiateSignature, + tcRnInstantiateSignature, + loadUnqualIfaces, + -- More private... + checkBootDeclM, + getRenamedStuff, RenamedStuff + ) where + +import GHC.Prelude + +import GHC.Driver.Env +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 +import {-# SOURCE #-} GHC.Tc.Gen.Splice ( finishTH, runRemoteModFinalizers ) +import GHC.Tc.Gen.HsType +import GHC.Tc.Validity( checkValidType ) +import GHC.Tc.Gen.Match +import GHC.Tc.Utils.Unify( checkConstraints, tcSubTypeSigma ) +import GHC.Tc.Zonk.Type +import GHC.Tc.Gen.Expr +import GHC.Tc.Utils.Monad +import GHC.Tc.Gen.Export +import GHC.Tc.Types.Evidence +import GHC.Tc.Types.Constraint +import GHC.Tc.Types.Origin +import GHC.Tc.Instance.Family +import GHC.Tc.Gen.Annotation +import GHC.Tc.Gen.Bind +import GHC.Tc.Gen.Default +import GHC.Tc.Utils.Env +import GHC.Tc.Gen.Sig( tcRules ) +import GHC.Tc.Gen.Foreign +import GHC.Tc.TyCl.Instance +import GHC.Tc.Utils.TcMType +import GHC.Tc.Utils.TcType +import GHC.Tc.Solver +import GHC.Tc.TyCl +import GHC.Tc.Instance.Typeable ( mkTypeableBinds ) +import GHC.Tc.Utils.Backpack +import GHC.Tc.Zonk.TcType + +import GHC.Rename.Bind ( rejectBootDecls ) +import GHC.Rename.Splice ( rnTopSpliceDecls, traceSplice, SpliceInfo(..) ) +import GHC.Rename.HsType +import GHC.Rename.Expr +import GHC.Rename.Fixity ( lookupFixityRn ) +import GHC.Rename.Names +import GHC.Rename.Env +import GHC.Rename.Module +import GHC.Rename.Doc +import GHC.Rename.Utils ( mkNameClashErr, mkRnSyntaxExpr ) + +import GHC.Iface.Decl ( coAxiomToIfaceDecl ) +import GHC.Iface.Env ( externaliseName ) +import GHC.Iface.Load + +import GHC.Builtin.Types ( mkListTy, anyTypeOfKind ) +import GHC.Builtin.Names +import GHC.Builtin.Utils + +import GHC.Hs hiding ( FunDep(..) ) +import GHC.Hs.Dump + +import GHC.Core.PatSyn +import GHC.Core.Predicate ( classMethodTy ) +import GHC.Core.InstEnv +import GHC.Core.TyCon +import GHC.Core.DataCon +import GHC.Core.TyCo.Rep +import GHC.Core.Type +import GHC.Core.Class +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 ) + +import GHC.Parser.Header ( mkPrelImports ) + +import GHC.IfaceToCore + +import GHC.Runtime.Context + +import GHC.Utils.Error +import GHC.Utils.Outputable as Outputable +import GHC.Utils.Panic +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(..) ) +import GHC.Types.Var.Env +import GHC.Types.TypeEnv +import GHC.Types.Unique.FM +import GHC.Types.Name +import GHC.Types.Name.Env +import GHC.Types.Name.Set +import GHC.Types.Avail +import GHC.Types.Basic hiding( SuccessFlag(..) ) +import GHC.Types.Annotations +import GHC.Types.SrcLoc +import GHC.Types.SourceFile +import qualified GHC.LanguageExtensions as LangExt + +import GHC.Unit.Env as UnitEnv +import GHC.Unit.External +import GHC.Unit.Types +import GHC.Unit.State +import GHC.Unit.Home +import GHC.Unit.Module +import GHC.Unit.Module.Warnings +import GHC.Unit.Module.ModSummary +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 +import GHC.Data.List.SetOps +import GHC.Data.Bag +import qualified GHC.Data.BooleanFormula as BF + +import Control.Arrow ( second ) +import Control.DeepSeq +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 ( 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 ) + + + +{- +************************************************************************ +* * + Typecheck and rename a module +* * +************************************************************************ +-} + +-- | Top level entry point for typechecker and renamer +tcRnModule :: HscEnv + -> ModSummary + -> Bool -- True <=> save renamed syntax + -> HsParsedModule + -> IO (Messages TcRnMessage, Maybe TcGblEnv) + +tcRnModule hsc_env mod_sum save_rn_syntax + parsedModule@HsParsedModule {hpm_module= L loc this_module} + | RealSrcSpan real_loc _ <- loc + = withTiming logger + (text "Renamer/typechecker"<+>brackets (ppr this_mod)) + (const ()) $ + initTc hsc_env hsc_src save_rn_syntax this_mod real_loc $ + withTcPlugins hsc_env $ + withDefaultingPlugins hsc_env $ + withHoleFitPlugins hsc_env $ + + tcRnModuleTcRnM hsc_env mod_sum parsedModule pair + + | otherwise + = return (err_msg `addMessage` emptyMessages, Nothing) + + where + hsc_src = ms_hsc_src mod_sum + logger = hsc_logger hsc_env + home_unit = hsc_home_unit hsc_env + err_msg = mkPlainErrorMsgEnvelope loc $ + TcRnModMissingRealSrcSpan this_mod + + pair :: (Module, SrcSpan) + pair@(this_mod,_) + | Just (L mod_loc mod) <- hsmodName this_module + = (mkHomeModule home_unit mod, locA mod_loc) + + | otherwise -- 'module M where' is omitted + = (mkHomeModule home_unit mAIN_NAME, srcLocSpan (srcSpanStart loc)) + + + + +tcRnModuleTcRnM :: HscEnv + -> ModSummary + -> HsParsedModule + -> (Module, SrcSpan) + -> TcRn TcGblEnv +-- Factored out separately from tcRnModule so that a Core plugin can +-- call the type checker directly +tcRnModuleTcRnM hsc_env mod_sum + (HsParsedModule { + hpm_module = + (L loc (HsModule (XModulePs _ _ mod_deprec maybe_doc_hdr) + maybe_mod export_ies import_decls local_decls)), + hpm_src_files = src_files + }) + (this_mod, prel_imp_loc) + = setSrcSpan loc $ + do { let { explicit_mod_hdr = isJust maybe_mod + ; hsc_src = ms_hsc_src mod_sum } + ; -- Load the hi-boot interface for this module, if any + -- We do this now so that the boot_names can be passed + -- to tcTyAndClassDecls, because the boot_names are + -- automatically considered to be loop breakers + tcg_env <- getGblEnv + ; boot_info <- tcHiBootIface hsc_src this_mod + ; setGblEnv (tcg_env { tcg_self_boot = boot_info }) + $ do + { -- Deal with imports; first add implicit prelude + implicit_prelude <- xoptM LangExt.ImplicitPrelude + ; let { prel_imports = mkPrelImports (moduleName this_mod) prel_imp_loc + implicit_prelude import_decls } + + ; when (notNull prel_imports) $ do + addDiagnostic TcRnImplicitImportOfPrelude + + ; -- TODO This is a little skeevy; maybe handle a bit more directly + let { simplifyImport (L _ idecl) = + ( renameRawPkgQual (hsc_unit_env hsc_env) (unLoc $ ideclName idecl) (ideclPkgQual idecl) + , reLoc $ ideclName idecl) + } + ; raw_sig_imports <- liftIO + $ findExtraSigImports hsc_env hsc_src + (moduleName this_mod) + ; raw_req_imports <- liftIO + $ implicitRequirements hsc_env + (map simplifyImport (prel_imports + ++ import_decls)) + ; let { mkImport mod_name = noLocA + $ (simpleImportDecl mod_name) + { ideclImportList = Just (Exactly, noLocA [])}} + ; let { withReason t imps = map (,text t) imps } + ; let { all_imports = withReason "is implicitly imported" prel_imports + ++ withReason "is directly imported" import_decls + ++ 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 + (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 + -- module header when we're splicing TH, since it can be accessed via + -- 'getDoc'. + -- We will rename it properly after renaming everything else so that + -- haddock can link the identifiers + ; tcg_env <- return (tcg_env + { 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 + ; tcg_env1 <- case mod_deprec of + Just (L _ txt) -> do { txt' <- rnWarningTxt txt + ; pure $ tcg_env {tcg_warns = WarnAll txt'} + } + Nothing -> pure tcg_env + ; setGblEnv tcg_env1 + $ do { -- Rename and type check the declarations + 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 + ; tcg_env <- setGblEnv tcg_env $ + rnExports explicit_mod_hdr export_ies + ; traceRn "rn4b: after exports" empty + ; return tcg_env + } + HsSrcFile -> + {-# SCC "tcRnSrcDecls" #-} + tcRnSrcDecls explicit_mod_hdr export_ies local_decls + + ; whenM (goptM Opt_DoCoreLinting) $ + lintGblEnv (hsc_logger hsc_env) (hsc_dflags hsc_env) tcg_env + + ; setGblEnv tcg_env + $ do { -- Compare hi-boot iface (if any) with the real thing + -- Must be done after processing the exports + tcg_env <- checkHiBootIface tcg_env boot_info + ; -- The new type env is already available to stuff + -- slurped from interface files, via + -- GHC.Tc.Utils.Env.setGlobalTypeEnv. It's important that this + -- includes the stuff in checkHiBootIface, + -- because the latter might add new bindings for + -- boot_dfuns, which may be mentioned in imported + -- unfoldings. + ; -- Report unused names + -- Do this /after/ type inference, so that when reporting + -- 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_hdr_info = (maybe_doc_hdr, maybe_mod) }) + + ; -- add extra source files to tcg_dependent_files + addDependentFiles src_files + -- Ensure plugins run with the same tcg_env that we pass in + ; setGblEnv tcg_env + $ do { tcg_env <- runTypecheckerPlugin mod_sum tcg_env + ; -- Dump output and return + tcDump tcg_env + ; return tcg_env + } + } + } + } + } + +{- 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 + +{- +************************************************************************ +* * + Import declarations +* * +************************************************************************ +-} + +tcRnImports :: HscEnv -> [(LImportDecl GhcPs, SDoc)] -> TcM ([NonEmpty ClassDefaults], TcGblEnv) +tcRnImports hsc_env 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 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) <- 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, + -- and any other incrementally-performed imports + ; when (isOneShot (ghcMode (hsc_dflags hsc_env))) $ do { + updateEps_ $ \eps -> eps { eps_is_boot = imp_boot_mods imports } + } + + -- Update the gbl env + ; updGblEnv ( \ gbl -> + gbl { + tcg_rdr_env = tcg_rdr_env gbl `plusGlobalRdrEnv` rdr_env, + tcg_imports = tcg_imports gbl `plusImportAvails` imports, + tcg_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 + }) $ do { + + ; traceRn "rn1" (ppr (imp_direct_dep_mods imports)) + -- Fail if there are any errors so far + -- The error printing (if needed) takes advantage + -- of the tcg_env we have now set +-- ; traceIf (text "rdr_env: " <+> ppr rdr_env) + ; failIfErrsM + + -- Load any orphan-module (including orphan family + -- instance-module) interfaces, so that their rules and + -- instance decls will be found. But filter out a + -- self hs-boot: these instances will be checked when + -- we define them locally. + -- (We don't need to load non-orphan family instance + -- modules until we either try to use the instances they + -- define, or define our own family instances, at which + -- point we need to check them for consistency.) + ; loadModuleInterfaces (text "Loading orphan modules") + (filter (/= this_mod) (imp_orphs imports)) + + -- 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 = M.keys + . imp_mods + $ imports } + ; logger <- getLogger + ; withTiming logger (text "ConsistencyCheck"<+>brackets (ppr this_mod)) (const ()) + $ checkFamInstConsistency dir_imp_mods + ; traceRn "rn1: } checking family instance consistency" empty + + ; gbl_env <- getGblEnv + ; return (tc_defaults, gbl_env) } } + +{- +************************************************************************ +* * + Type-checking the top level of a module +* * +************************************************************************ +-} + +tcRnSrcDecls :: Bool -- False => no 'module M(..) where' header at all + -> Maybe (LocatedLI [LIE GhcPs]) + -> [LHsDecl GhcPs] -- Declarations + -> TcM TcGblEnv +tcRnSrcDecls explicit_mod_hdr export_ies decls + = do { -- Do all the declarations + ; (tcg_env, tcl_env, lie) <- tc_rn_src_decls decls + + ------ Simplify constraints --------- + -- + -- We do this after checkMainType, so that we use the type + -- info that checkMainType adds + -- + -- We do it with both global and local env in scope: + -- * the global env exposes the instances to simplifyTop, + -- and affects how names are rendered in error messages + -- * the local env exposes the local Ids to simplifyTop, + -- so that we get better error messages (monomorphism restriction) + ; new_ev_binds <- {-# SCC "simplifyTop" #-} + restoreEnvs (tcg_env, tcl_env) $ + do { lie_main <- checkMainType tcg_env + ; simplifyTop (lie `andWC` lie_main) } + + -- Emit Typeable bindings + ; tcg_env <- setGblEnv tcg_env $ + mkTypeableBinds + + ; traceTc "Tc9" empty + ; failIfErrsM -- Stop now if if there have been errors + -- Continuing is a waste of time; and we may get debug + -- warnings when zonking about strangely-typed TyCons! + + -- Zonk the final code. This must be done last. + -- Even simplifyTop may do some unification. + -- This pass also warns about missing type signatures + ; (id_env, ev_binds', binds', fords', imp_specs', rules') + <- zonkTcGblEnv new_ev_binds tcg_env + + --------- Run finalizers -------------- + -- Finalizers must run after constraints are simplified, lest types + -- might not be complete when using reify (see #12777). + -- and also after we zonk the first time because we run typed splices + -- in the zonker which gives rise to the finalisers. + ; let -- init_tcg_env: + -- * Remove accumulated bindings, rules and so on from + -- 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 = [] + , tcg_ev_binds = emptyBag + , tcg_imp_specs = [] + , tcg_rules = [] + , tcg_fords = [] + , tcg_type_env = tcg_type_env tcg_env + `plusTypeEnv` id_env } + ; (tcg_env, tcl_env) <- setGblEnv init_tcg_env + run_th_modfinalizers + ; finishTH + ; traceTc "Tc11" empty + + --------- Deal with the exports ---------- + -- Can't be done earlier, because the export list must "see" + -- the declarations created by the finalizers + ; tcg_env <- restoreEnvs (tcg_env, tcl_env) $ + rnExports explicit_mod_hdr export_ies + + --------- Emit the ':Main.main = runMainIO main' declaration ---------- + -- Do this /after/ rnExports, so that it can consult + -- the tcg_exports created by rnExports + ; (tcg_env, main_ev_binds) + <- restoreEnvs (tcg_env, tcl_env) $ + do { (tcg_env, lie) <- captureTopConstraints $ + checkMain explicit_mod_hdr export_ies + ; ev_binds <- simplifyTop lie + ; return (tcg_env, ev_binds) } + + ; failIfErrsM -- Stop now if if there have been errors + -- Continuing is a waste of time; and we may get debug + -- warnings when zonking about strangely-typed TyCons! + + ---------- Final zonking --------------- + -- Zonk the new bindings arising from running the finalisers, + -- and main. This won't give rise to any more finalisers as you + -- can't nest finalisers inside finalisers. + ; (id_env_mf, ev_binds_mf, binds_mf, fords_mf, imp_specs_mf, rules_mf) + <- zonkTcGblEnv main_ev_binds tcg_env + + ; let { !final_type_env = tcg_type_env tcg_env + `plusTypeEnv` id_env_mf + -- Add the zonked Ids from the value bindings (they were in tcl_env) + -- Force !final_type_env, lest we retain an old reference + -- to the previous tcg_env + + ; tcg_env' = tcg_env + { 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 + , tcg_fords = fords' ++ fords_mf } } ; + + ; setGlobalTypeEnv tcg_env' final_type_env + } + +zonkTcGblEnv :: Bag EvBind -> TcGblEnv + -> TcM (TypeEnv, Bag EvBind, LHsBinds GhcTc, + [LForeignDecl GhcTc], [LTcSpecPrag], [LRuleDecl GhcTc]) +zonkTcGblEnv ev_binds tcg_env@(TcGblEnv { tcg_binds = binds + , tcg_ev_binds = cur_ev_binds + , tcg_imp_specs = imp_specs + , tcg_rules = rules + , tcg_fords = fords }) + = {-# SCC "zonkTopDecls" #-} + setGblEnv tcg_env $ -- This sets the GlobalRdrEnv which is used when rendering + -- error messages during zonking (notably levity errors) + do { let all_ev_binds = cur_ev_binds `unionBags` ev_binds + ; zonkTopDecls all_ev_binds binds rules imp_specs fords } + +-- | Runs TH finalizers and renames and typechecks the top-level declarations +-- that they could introduce. +run_th_modfinalizers :: TcM (TcGblEnv, TcLclEnv) +run_th_modfinalizers = do + th_modfinalizers_var <- fmap tcg_th_modfinalizers getGblEnv + th_modfinalizers <- readTcRef th_modfinalizers_var + if null th_modfinalizers + then getEnvs + else do + writeTcRef th_modfinalizers_var [] + let run_finalizer (lcl_env, f) = + restoreLclEnv lcl_env (runRemoteModFinalizers f) + + (_, lie_th) <- captureTopConstraints $ + mapM_ run_finalizer th_modfinalizers + + -- Finalizers can add top-level declarations with addTopDecls, so + -- we have to run tc_rn_src_decls to get them + (tcg_env, tcl_env, lie_top_decls) <- tc_rn_src_decls [] + + restoreEnvs (tcg_env, tcl_env) $ do + -- Subsequent rounds of finalizers run after any new constraints are + -- simplified, or some types might not be complete when using reify + -- (see #12777). + new_ev_binds <- {-# SCC "simplifyTop2" #-} + simplifyTop (lie_th `andWC` lie_top_decls) + addTopEvBinds new_ev_binds run_th_modfinalizers + -- addTopDecls can add declarations which add new finalizers. + +tc_rn_src_decls :: [LHsDecl GhcPs] + -> TcM (TcGblEnv, TcLclEnv, WantedConstraints) +-- Loops around dealing with each top level inter-splice group +-- in turn, until it's dealt with the entire module +-- Never emits constraints; calls captureTopConstraints internally +tc_rn_src_decls ds + = {-# SCC "tc_rn_src_decls" #-} + do { (first_group, group_tail) <- findSplice ds + -- If ds is [] we get ([], Nothing) + + -- Deal with decls up to, but not including, the first splice + ; (tcg_env, rn_decls) <- rnTopSrcDecls first_group + -- rnTopSrcDecls fails if there are any errors + + -- Get TH-generated top-level declarations and make sure they don't + -- contain any splices since we don't handle that at the moment + -- + -- The plumbing here is a bit odd: see #10853 + ; th_topdecls_var <- fmap tcg_th_topdecls getGblEnv + ; th_ds <- readTcRef th_topdecls_var + ; writeTcRef th_topdecls_var [] + + ; (tcg_env, rn_decls) <- + if null th_ds + then return (tcg_env, rn_decls) + else do { (th_group, th_group_tail) <- findSplice th_ds + ; case th_group_tail of + { Nothing -> return () + ; Just (SpliceDecl _ (L loc _) _, _) -> + setSrcSpanA loc $ addErr $ + TcRnTHError $ AddTopDeclsError + AddTopDeclsUnexpectedDeclarationSplice + } + -- Rename TH-generated top-level declarations + ; (tcg_env, th_rn_decls) <- setGblEnv tcg_env + $ rnTopSrcDecls th_group + + -- Dump generated top-level declarations + ; let msg = "top-level declarations added with 'addTopDecls'" + ; traceSplice + $ SpliceInfo { spliceDescription = msg + , spliceIsDecl = True + , spliceSource = Nothing + , spliceGenerated = ppr th_rn_decls } + ; return (tcg_env, appendGroups rn_decls th_rn_decls) + } + + -- Type check all declarations + -- NB: set the env **before** captureTopConstraints so that error messages + -- get reported w.r.t. the right GlobalRdrEnv. It is for this reason that + -- the captureTopConstraints must go here, not in tcRnSrcDecls. + ; ((tcg_env, tcl_env), lie1) <- setGblEnv tcg_env $ + captureTopConstraints $ + tcTopSrcDecls rn_decls + + -- If there is no splice, we're nearly done + ; restoreEnvs (tcg_env, tcl_env) $ + case group_tail of + { Nothing -> return (tcg_env, tcl_env, lie1) + + -- If there's a splice, we must carry on + ; Just (SpliceDecl _ (L _ splice) _, rest_ds) -> + do { + -- We need to simplify any constraints from the previous declaration + -- group, or else we might reify metavariables, as in #16980. + ; ev_binds1 <- simplifyTop lie1 + + -- Rename the splice expression, and get its supporting decls + ; (spliced_decls, splice_fvs) <- rnTopSpliceDecls splice + + -- Glue them on the front of the remaining decls and loop + ; setGblEnv (tcg_env `addTcgDUs` usesOnly splice_fvs) $ + addTopEvBinds ev_binds1 $ + tc_rn_src_decls (spliced_decls ++ rest_ds) + } + } + } + +{- +************************************************************************ +* * + Compiling hs-boot source files, and + comparing the hi-boot interface with the real thing +* * +************************************************************************ +-} + +tcRnHsBootDecls :: HsBootOrSig -> [LHsDecl GhcPs] -> TcM TcGblEnv +tcRnHsBootDecls boot_or_sig decls + = do { (first_group, group_tail) <- findSplice decls + + -- Rename the declarations + ; (tcg_env, HsGroup { hs_tyclds = tycl_decls + , hs_derivds = deriv_decls + , hs_fords = for_decls + , hs_defds = def_decls + , hs_ruleds = rule_decls + , hs_annds = _ + , hs_valds = XValBindsLR (NValBinds val_binds val_sigs) }) + <- rnTopSrcDecls first_group + + ; (gbl_env, lie) <- setGblEnv tcg_env $ captureTopConstraints $ do { + -- NB: setGblEnv **before** captureTopConstraints so that + -- if the latter reports errors, it knows what's in scope + + -- Check for illegal declarations + ; case group_tail of + Just (SpliceDecl _ d _, _) -> rejectBootDecls boot_or_sig BootSpliceDecls [d] + Nothing -> return () + ; rejectBootDecls boot_or_sig BootForeignDecls for_decls + ; rejectBootDecls boot_or_sig BootDefaultDecls def_decls + ; rejectBootDecls boot_or_sig BootRuleDecls rule_decls + + -- Typecheck type/class/instance decls + ; traceTc "Tc2 (boot)" empty + ; (tcg_env, inst_infos, _deriv_binds, _th_bndrs) + <- tcTyClsInstDecls tycl_decls deriv_decls def_decls val_binds + ; setGblEnv tcg_env $ do { + + -- Emit Typeable bindings + ; tcg_env <- mkTypeableBinds + ; setGblEnv tcg_env $ do { + + -- Typecheck value declarations + ; traceTc "Tc5" empty + ; val_ids <- tcHsBootSigs val_binds val_sigs + + -- Wrap up + -- No simplification or zonking to do + ; traceTc "Tc7a" empty + ; gbl_env <- getGblEnv + + -- Make the final type-env + -- Include the dfun_ids so that their type sigs + -- are written into the interface file. + ; let { type_env0 = tcg_type_env gbl_env + ; type_env1 = extendTypeEnvWithIds type_env0 val_ids + ; type_env2 = extendTypeEnvWithIds type_env1 dfun_ids + ; dfun_ids = map iDFunId inst_infos + } + + ; setGlobalTypeEnv gbl_env type_env2 + }}} + ; traceTc "boot" (ppr lie); return gbl_env } + +{- +Once we've typechecked the body of the module, we want to compare what +we've found (gathered in a TypeEnv) with the hi-boot details (if any). +-} + +checkHiBootIface :: TcGblEnv -> SelfBootInfo -> TcM TcGblEnv +-- Compare the hi-boot file for this module (if there is one) +-- with the type environment we've just come up with +-- In the common case where there is no hi-boot file, the list +-- of boot_names is empty. + +checkHiBootIface tcg_env boot_info + | NoSelfBoot <- boot_info -- Common case + = return tcg_env + + | HsBootFile <- tcg_src tcg_env -- Current module is already a hs-boot file! + = return tcg_env + + | SelfBoot { sb_mds = boot_details } <- boot_info + , TcGblEnv { tcg_binds = binds + , tcg_insts = local_insts + , tcg_type_env = local_type_env + , tcg_exports = local_exports } <- tcg_env + = do { -- This code is tricky, see Note [DFun knot-tying] + ; imp_prs <- checkHiBootIface' local_insts local_type_env + local_exports boot_details + + -- Now add the impedance-matching boot bindings: + -- + -- - dfun bindings $fxblah = $fblah + -- - record bindings fld{var} = fld{rec field of ..} + -- + -- 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 = [ mkVarBind boot_id (nlHsVar id) + | (boot_id, id) <- imp_prs ] + tcg_env_w_binds + = tcg_env { tcg_binds = binds ++ impedance_binds } + + ; type_env' `seq` + -- Why the seq? Without, we will put a TypeEnv thunk in + -- tcg_type_env_var. That thunk will eventually get + -- forced if we are typechecking interfaces, but that + -- is no good if we are trying to typecheck the very + -- DFun we were going to put in. + -- TODO: Maybe setGlobalTypeEnv should be strict. + setGlobalTypeEnv tcg_env_w_binds type_env' } + +{- Note [DFun impedance matching] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We return a list of "impedance-matching" bindings for the dfuns +defined in the hs-boot file, such as + $fxEqT = $fEqT +We need these because the module and hi-boot file might differ in +the name it chose for the dfun: the name of a dfun is not +uniquely determined by its type; there might be multiple dfuns +which, individually, would map to the same name (in which case +we have to disambiguate them.) There's no way for the hi file +to know exactly what disambiguation to use... without looking +at the hi-boot file itself. + +In fact, the names will always differ because we always pick names +prefixed with "$fx" for boot dfuns, and "$f" for real dfuns +(so that this impedance matching is always possible). + +Note [Record field impedance matching] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When a hs-boot file defines a function whose implementation in the hs file +is a record selector, we have to do something similar to Note [DFun impedance matching]. + +Example: + + -- M.hs-boot + module M where + data A + fld :: A -> () + + -- M.hs + module M where + data A = MkA { fld :: () } + +Recall from Note [Record field namespacing] in GHC.Types.Name.Occurrence that +record fields have their own namespaces. This means that M.hs exports the Id +fld{record selector of MkA} :: A -> (), while M.hs-boot exports the Id +fld{variable} :: A -> (). + +To remedy this, we add an impedance-matching binding in M.hs: + + fld{variable} :: A -> () + fld{variable} = fld{record selector of MkA} + +Note that we imperatively need to add a binding for fld{variable} in M.hs, as we +might have an exact Name reference to it (e.g. in a module that imports M.hs-boot). +Not doing so would cause Core Lint errors, at the very least. + +These bindings are returned by the check_export in checkHiBootIface', and +added to the DFun impedance-matching bindings. + +[Wrinkle: exports] + + We MUST NOT add fld{variable} to the export list of M.hs, as this + would mean that M.hs exports both a record field and variable with the same + occNameFS, which would cause ambiguity errors at use-sites. + It's OK to only export the field name even though the boot-file exported + the variable: name resolution will take care of that. + +Another situation is that we are re-exporting, e.g. (with M as above): + + -- N.hs-boot + module N ( module M ) where + import {-# SOURCE #-} M + + -- N.hs + module N ( module M where ) + import M + +In this case, N.hs-boot re-exports the variable fld, and N re-exports the +record field fld, but not the variable fld. We don't need to do anything in +this situation; in particular, don't re-export the variable name from N.hs, +as per [Wrinkle: exports] above. + +Note [DFun knot-tying] +~~~~~~~~~~~~~~~~~~~~~~ +The 'SelfBootInfo' that is fed into 'checkHiBootIface' comes from +typechecking the hi-boot file that we are presently implementing. +Suppose we are typechecking the module A: when we typecheck the +hi-boot file, whenever we see an identifier A.T, we knot-tie this +identifier to the *local* type environment (via if_rec_types.) The +contract then is that we don't *look* at 'SelfBootInfo' until we've +finished typechecking the module and updated the type environment with +the new tycons and ids. + +This most works well, but there is one problem: DFuns! We do not want +to look at the mb_insts of the ModDetails in SelfBootInfo, because a +dfun in one of those ClsInsts is gotten (in GHC.IfaceToCore.tcIfaceInst) by a +(lazily evaluated) lookup in the if_rec_types. We could extend the +type env, do a setGloblaTypeEnv etc; but that all seems very indirect. +It is much more directly simply to extract the DFunIds from the +md_types of the SelfBootInfo. + +See #4003, #16038 for why we need to take care here. +-} + +checkHiBootIface' :: [ClsInst] -> TypeEnv -> [AvailInfo] + -> ModDetails -> TcM [(Id, Id)] +-- Variant which doesn't require a full TcGblEnv; you could get the +-- local components from another ModDetails. +checkHiBootIface' + local_insts local_type_env local_exports + (ModDetails { md_types = boot_type_env + , md_fam_insts = boot_fam_insts + , md_exports = boot_exports }) + = 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 + ; fld_prs <- mapMaybeM (check_export gre_env) boot_exports + + -- Check for no family instances + ; unless (null boot_fam_insts) $ + panic ("GHC.Tc.Module.checkHiBootIface: Cannot handle family " ++ + "instances in boot files yet...") + -- FIXME: Why? The actual comparison is not hard, but what would + -- be the equivalent to the dfun bindings returned for class + -- instances? We can't easily equate tycons... + + -- Check instance declarations + -- and generate an impedance-matching binding + ; dfun_prs <- mapMaybeM check_cls_inst boot_dfuns + + ; failIfErrsM + + ; return (fld_prs ++ dfun_prs) }} + + where + boot_dfun_names = map idName boot_dfuns + boot_dfuns = filter isDFunId $ typeEnvIds boot_type_env + -- NB: boot_dfuns is /not/ defined thus: map instanceDFunId md_insts + -- We don't want to look at md_insts! + -- Why not? See Note [DFun knot-tying] + + check_export gre_env boot_avail -- boot_avail is exported by the boot iface + | name `elem` boot_dfun_names + = return Nothing + + -- Check that the actual module exports the same thing + | missing_name:_ <- missing_names + = -- Lookup might have failed because the hs-boot file defines a variable + -- that is implemented in the hs file as a record selector, which + -- lives in a different namespace. + -- + -- See Note [Record field impedance matching]. + let missing_occ = nameOccName missing_name + mb_ok :: GlobalRdrElt -> Maybe (GlobalRdrElt, Maybe Id) + mb_ok gre + -- Ensure that this GRE refers to an Id that is exported. + | isNothing $ lookupNameEnv local_export_env (greName gre) + = Nothing + -- We locally define the field: create an impedance-matching + -- binding for the variable. + | Just (AnId id) <- lookupTypeEnv local_type_env (greName gre) + = Just (gre, Just id) + -- We are re-exporting the field but not the variable: not a problem, + -- as per [Wrinkle: exports] in Note [Record field impedance matching]. + | otherwise + = Just (gre, Nothing) + matching_flds + | isVarOcc missing_occ -- (This only applies to variables.) + = lookupGRE gre_env $ + LookupOccName missing_occ (RelevantGREsFOS WantField) + | otherwise + = [] -- BootFldReexport T18999_NoDisambiguateRecordFields T16745A + + in case mapMaybe mb_ok $ matching_flds of + + -- At least 2 matches: report an ambiguity error. + (gre1,_):(gre2,_):gres_ids -> do + addErrAt (nameSrcSpan missing_name) $ + mkNameClashErr gre_env (nameRdrName missing_name) + (gre1 NE.:| gre2 : map fst gres_ids) + return Nothing + + -- Single match: resolve the issue. + [(_,mb_fld_id)] -> + -- See Note [Record field impedance matching]. + for mb_fld_id $ \ fld_id -> do + let local_boot_var = + Id.mkExportedVanillaId missing_name (idType fld_id) + return (local_boot_var, fld_id) + + -- Otherwise: report that the hs file does not export something + -- that the hs-boot file exports. + [] -> do + addErrAt (nameSrcSpan missing_name) + (missingBootThing HsBoot missing_name MissingBootExport) + return Nothing + + -- If the boot module does not *define* the thing, we are done + -- (it simply re-exports it, and names match, so nothing further to do) + | isNothing mb_boot_thing + = return Nothing + + -- Check that the actual module also defines the thing, and + -- then compare the definitions + | Just real_thing <- lookupTypeEnv local_type_env name, + Just boot_thing <- mb_boot_thing + = do checkBootDeclM HsBoot boot_thing real_thing + return Nothing + + | otherwise + = do addErrTc (missingBootThing HsBoot name MissingBootDefinition) + return Nothing + where + name = availName boot_avail + mb_boot_thing = lookupTypeEnv boot_type_env name + missing_names = case lookupNameEnv local_export_env name of + Nothing -> [name] + Just avail -> availNames boot_avail + `minusList` availNames avail + + local_export_env :: NameEnv AvailInfo + local_export_env = availsToNameEnv local_exports + + check_cls_inst :: DFunId -> TcM (Maybe (Id,Id)) + -- Returns a pair of the boot dfun in terms of the equivalent + -- real dfun. Delicate (like checkBootDecl) because it depends + -- on the types lining up precisely even to the ordering of + -- the type variables in the foralls. + check_cls_inst boot_dfun + | (real_dfun : _) <- find_real_dfun boot_dfun + , let dfun_name = idName boot_dfun + local_boot_dfun = Id.mkExportedVanillaId dfun_name (idType real_dfun) + = return $ Just (local_boot_dfun, real_dfun) + -- Two tricky points here: + -- + -- * The local_boot_fun should have a Name from the /boot-file/, + -- but type from the dfun defined in /this module/. + -- That ensures that the TyCon etc inside the type are + -- the ones defined in this module, not the ones gotten + -- from the hi-boot file, which may have a lot less info + -- (#8743, comment:10). + -- + -- * The DFunIds from boot_details are /GlobalIds/, because + -- they come from typechecking M.hi-boot. + -- But all bindings in this module should be for /LocalIds/, + -- otherwise dependency analysis fails (#16038). This + -- is another reason for using mkExportedVanillaId, rather + -- that modifying boot_dfun, to make local_boot_fun. + -- + -- See Note [DFun impedance matching]. + + | otherwise + = setSrcSpan (nameSrcSpan (getName boot_dfun)) $ + do { traceTc "check_cls_inst" $ vcat + [ text "local_insts" <+> + vcat (map (ppr . idType . instanceDFunId) local_insts) + , text "boot_dfun_ty" <+> ppr (idType boot_dfun) ] + + ; addErrTc $ TcRnBootMismatch HsBoot + $ MissingBootInstance boot_dfun + ; return Nothing } + + find_real_dfun :: DFunId -> [DFunId] + find_real_dfun boot_dfun + = [dfun | inst <- local_insts + , let dfun = instanceDFunId inst + , idType dfun `eqType` boot_dfun_ty ] + where + boot_dfun_ty = idType boot_dfun + + +-- In general, to perform these checks we have to +-- compare the TyThing from the .hi-boot file to the TyThing +-- in the current source file. We must be careful to allow alpha-renaming +-- where appropriate, and also the boot declaration is allowed to omit +-- constructors and class methods. +-- +-- See rnfail055 for a good test of this stuff. + +-- | Compares two things for equivalence between boot-file and normal code, +-- reporting an error if they don't match up. +checkBootDeclM :: HsBootOrSig + -> TyThing -- ^ boot thing + -> TyThing -- ^ real thing + -> TcM () +checkBootDeclM boot_or_sig boot_thing real_thing + = for_ boot_errs $ \ boot_err -> + addErrAt span $ + TcRnBootMismatch boot_or_sig $ + BootMismatch boot_thing real_thing boot_err + where + boot_errs = execWriter $ checkBootDecl boot_or_sig boot_thing real_thing + + -- Here we use the span of the boot thing or, if it doesn't have a sensible + -- span, that of the real thing, + span + | let span = nameSrcSpan (getName boot_thing) + , isGoodSrcSpan span + = span + | otherwise + = nameSrcSpan (getName real_thing) + +-- | Writer monad for accumulating errors when comparing an hs-boot or +-- signature file with its implementing module. +type BootErrsM err = Writer [err] () + +-- | If the test in the first parameter is True, succeed. +-- Otherwise, record the given error. +check :: Bool -> err -> BootErrsM err +check True _ = checkSuccess +check False err = bootErr err + +-- | Record an error. +bootErr :: err -> BootErrsM err +bootErr err = tell [err] + +-- | A convenience synonym for a lack of errors, for @checkBootDecl@ and friends. +checkSuccess :: BootErrsM err +checkSuccess = return () + +-- | Map over the error types in an error-accumulating computation. +embedErrs :: (err1 -> err2) -> BootErrsM err1 -> BootErrsM err2 +embedErrs f = mapWriter (second (fmap f)) + +-- | Wrap up a list of errors into a single message. +wrapErrs :: (NE.NonEmpty err1 -> err2) -> BootErrsM err1 -> BootErrsM err2 +wrapErrs f w = + case execWriter w of + [] -> checkSuccess + err : errs -> bootErr (f $ err :| errs) + +-- | Compares the two things for equivalence between boot-file and normal +-- code. Returns @Nothing@ on success or @Just "some helpful info for user"@ +-- failure. If the difference will be apparent to the user, @Just empty@ is +-- perfectly suitable. +checkBootDecl :: HsBootOrSig -> TyThing -> TyThing -> BootErrsM BootMismatchWhat + +checkBootDecl _ (AnId id1) (AnId id2) + = assert (id1 == id2) $ + check (idType id1 `eqType` idType id2) + (BootMismatchedIdTypes id1 id2) + +checkBootDecl boot_or_sig (ATyCon tc1) (ATyCon tc2) + = wrapErrs (BootMismatchedTyCons tc1 tc2) $ + checkBootTyCon boot_or_sig tc1 tc2 + +checkBootDecl _ t1 t2 + = pprPanic "checkBootDecl" (ppr t1 $$ ppr t2) + +-- | Run the check provided for every pair of elements in the lists. +-- +-- Records an error: +-- +-- - when any two items at the same position in the two lists don't match +-- according to the given function, +-- - when the lists are of different lengths. +checkListBy :: (a -> a -> BootErrsM err) -> [a] -> [a] + -> (BootListMismatches a err -> err2) + -> BootErrsM err2 +checkListBy check_fun as bs mk_err = wrapErrs mk_err $ go 1 as bs + where + go _ [] [] = checkSuccess + go !i (x:xs) (y:ys) = + do { embedErrs (MismatchedThing i x y) $ check_fun x y + ; go (i+1) xs ys } + go _ _ _ = bootErr MismatchedLength + +---------------- +checkBootTyCon :: HsBootOrSig -> TyCon -> TyCon -> BootErrsM BootTyConMismatch +checkBootTyCon boot_or_sig tc1 tc2 + | not (eqType (tyConKind tc1) (tyConKind tc2)) + -- First off, check the kind + = bootErr TyConKindMismatch + + | Just c1 <- tyConClass_maybe tc1 + , Just c2 <- tyConClass_maybe tc2 + , let (clas_tvs1, clas_fds1, sc_theta1, _, ats1, op_stuff1) + = classExtraBigSig c1 + (clas_tvs2, clas_fds2, sc_theta2, _, ats2, op_stuff2) + = classExtraBigSig c2 + , Just env <- eqVarBndrs emptyRnEnv2 clas_tvs1 clas_tvs2 + = do { check_roles + ; embedErrs (TyConMismatchedClasses c1 c2) $ + do { -- Checks kind of class + ; check (liftEq (eqFD env) clas_fds1 clas_fds2) + MismatchedFunDeps + ; unless (isAbstractTyCon tc1) $ + do { check (liftEq (eqTypeX env) sc_theta1 sc_theta2) + MismatchedSuperclasses + ; checkListBy (compatClassOp env boot_or_sig) op_stuff1 op_stuff2 + MismatchedMethods + ; checkListBy (compatAT env boot_or_sig) ats1 ats2 + MismatchedATs + ; check (classMinimalDef c1 `BF.implies` classMinimalDef c2) + MismatchedMinimalPragmas + } } } + + | Just syn_rhs1 <- synTyConRhs_maybe tc1 + , Just syn_rhs2 <- synTyConRhs_maybe tc2 + , Just env <- eqVarBndrs emptyRnEnv2 (tyConTyVars tc1) (tyConTyVars tc2) + = assert (tc1 == tc2) $ + do { check_roles + ; check (eqTypeX env syn_rhs1 syn_rhs2) $ + TyConSynonymMismatch syn_rhs1 syn_rhs2 } + + -- This allows abstract 'data T a' to be implemented using 'type T = ...' + -- and abstract 'class K a' to be implement using 'type K = ...' + -- See Note [Synonyms implement abstract data] + | Hsig <- boot_or_sig -- don't support for hs-boot yet + , isAbstractTyCon tc1 + , Just (tvs, ty) <- synTyConDefn_maybe tc2 + = checkSynAbsData tc1 tc2 tvs ty + + | Just fam_flav1 <- famTyConFlav_maybe tc1 + , Just fam_flav2 <- famTyConFlav_maybe tc2 + = assert (tc1 == tc2) $ + do { let injInfo1 = tyConInjectivityInfo tc1 + injInfo2 = tyConInjectivityInfo tc2 + ; -- check equality of roles, family flavours and injectivity annotations + -- (NB: Type family roles are always nominal. But the check is + -- harmless enough.) + ; check_roles + ; compatFamFlav fam_flav1 fam_flav2 + ; check (injInfo1 == injInfo2) TyConInjectivityMismatch } + + | isAlgTyCon tc1 && isAlgTyCon tc2 + , Just env <- eqVarBndrs emptyRnEnv2 (tyConTyVars tc1) (tyConTyVars tc2) + = assert (tc1 == tc2) $ + do { check_roles + ; let rhs1 = algTyConRhs tc1 + rhs2 = algTyConRhs tc2 + ; embedErrs (TyConMismatchedData rhs1 rhs2) $ + do { check (liftEq (eqTypeX env) + (tyConStupidTheta tc1) (tyConStupidTheta tc2)) + MismatchedDatatypeContexts + ; compatAlgRhs rhs1 rhs2 } } + + | otherwise = bootErr TyConsVeryDifferent + -- two very different types; + -- should be obvious to the user what the problem is + where + check_roles = checkRoles boot_or_sig tc1 (tyConRoles tc2) + + +emptyRnEnv2 :: RnEnv2 +emptyRnEnv2 = mkRnEnv2 emptyInScopeSet + +-- | Check that two class methods have compatible type signatures. +compatClassOp :: RnEnv2 -> HsBootOrSig -> ClassOpItem -> ClassOpItem -> BootErrsM BootMethodMismatch +compatClassOp env boot_or_sig (id1, def_meth1) (id2, def_meth2) + = do { check (name1 == name2) $ + MismatchedMethodNames + ; check (eqTypeX env op_ty1 op_ty2) $ + MismatchedMethodTypes op_ty1 op_ty2 + ; case boot_or_sig of + HsBoot -> + check (liftEq eqDM def_meth1 def_meth2) $ + MismatchedDefaultMethods False + Hsig -> + check (subDM op_ty1 def_meth1 def_meth2) $ + MismatchedDefaultMethods True } + where + name1 = idName id1 + name2 = idName id2 + op_ty1 = classMethodTy id1 + op_ty2 = classMethodTy id2 + + eqDM (_, VanillaDM) (_, VanillaDM) = True + eqDM (_, GenericDM t1) (_, GenericDM t2) = eqTypeX env t1 t2 + eqDM _ _ = False + + -- NB: first argument is from hsig, second is from real impl. + -- Order of pattern matching matters. + subDM _ Nothing _ = True + subDM _ _ Nothing = False + + -- If the hsig wrote: + -- + -- f :: a -> a + -- default f :: a -> a + -- + -- this should be validly implementable using an old-fashioned + -- vanilla default method. + subDM t1 (Just (_, GenericDM gdm_t1)) (Just (_, VanillaDM)) + = eqType t1 gdm_t1 -- Take care (#22476). Both t1 and gdm_t1 come + -- from tc1, so use eqType, and /not/ eqTypeX + + -- This case can occur when merging signatures + subDM t1 (Just (_, VanillaDM)) (Just (_, GenericDM t2)) + = eqTypeX env t1 t2 + + subDM _ (Just (_, VanillaDM)) (Just (_, VanillaDM)) = True + subDM _ (Just (_, GenericDM t1)) (Just (_, GenericDM t2)) + = eqTypeX env t1 t2 + +-- | Check that two associated types are compatible. +compatAT :: RnEnv2 -> HsBootOrSig -> ClassATItem -> ClassATItem + -> BootErrsM BootATMismatch +compatAT env boot_or_sig (ATI tc1 def_ats1) (ATI tc2 def_ats2) + = do { embedErrs MismatchedTyConAT $ + checkBootTyCon boot_or_sig tc1 tc2 + ; check (compatATDef def_ats1 def_ats2) + MismatchedATDefaultType } + + where + -- Ignore the location of the defaults + compatATDef Nothing Nothing = True + compatATDef (Just (ty1, _loc1)) (Just (ty2, _loc2)) = eqTypeX env ty1 ty2 + compatATDef _ _ = False + +-- | Check that two functional dependencies are the same. +eqFD :: RnEnv2 -> FunDep TyVar -> FunDep TyVar -> Bool +eqFD env (as1,bs1) (as2,bs2) = + liftEq (eqTypeX env) (mkTyVarTys as1) (mkTyVarTys as2) && + liftEq (eqTypeX env) (mkTyVarTys bs1) (mkTyVarTys bs2) + +-- | Check compatibility of two type family flavours. +compatFamFlav :: FamTyConFlav -> FamTyConFlav -> BootErrsM BootTyConMismatch +compatFamFlav OpenSynFamilyTyCon OpenSynFamilyTyCon + = checkSuccess +compatFamFlav (DataFamilyTyCon {}) (DataFamilyTyCon {}) + = checkSuccess +compatFamFlav AbstractClosedSynFamilyTyCon AbstractClosedSynFamilyTyCon + = checkSuccess -- This case only happens for hsig merging. +compatFamFlav AbstractClosedSynFamilyTyCon (ClosedSynFamilyTyCon {}) + = checkSuccess +compatFamFlav (ClosedSynFamilyTyCon {}) AbstractClosedSynFamilyTyCon + = checkSuccess +compatFamFlav (ClosedSynFamilyTyCon ax1) (ClosedSynFamilyTyCon ax2) + = eqClosedFamilyAx ax1 ax2 +compatFamFlav (BuiltInSynFamTyCon {}) (BuiltInSynFamTyCon {}) + = checkSuccess +compatFamFlav flav1 flav2 + = bootErr $ TyConFlavourMismatch flav1 flav2 + +-- | Check that two 'AlgTyConRhs's are compatible. +compatAlgRhs :: AlgTyConRhs -> AlgTyConRhs -> BootErrsM BootDataMismatch +compatAlgRhs (AbstractTyCon {}) _rhs2 = + checkSuccess -- rhs2 is guaranteed to be injective, since it's an AlgTyCon +compatAlgRhs tc1@DataTyCon{} tc2@DataTyCon{} = + checkListBy compatCon (data_cons tc1) (data_cons tc2) MismatchedConstructors +compatAlgRhs tc1@NewTyCon{ data_con = dc1 } tc2@NewTyCon{ data_con = dc2 } = + embedErrs (MismatchedConstructors . NE.singleton . MismatchedThing 1 dc1 dc2) $ + compatCon (data_con tc1) (data_con tc2) +compatAlgRhs _ _ = bootErr MismatchedNewtypeVsData + +-- | Check that two 'DataCon's are compatible. +compatCon :: DataCon -> DataCon -> BootErrsM BootDataConMismatch +compatCon c1 c2 + = do { check (dataConName c1 == dataConName c2) + MismatchedDataConNames + ; check (dataConIsInfix c1 == dataConIsInfix c2) + MismatchedDataConFixities + ; check (liftEq eqHsBang (dataConImplBangs c1) (dataConImplBangs c2)) + MismatchedDataConBangs + ; check (map flSelector (dataConFieldLabels c1) == map flSelector (dataConFieldLabels c2)) + MismatchedDataConFieldLabels + ; check (eqType (dataConWrapperType c1) (dataConWrapperType c2)) + MismatchedDataConTypes } + +eqClosedFamilyAx :: Maybe (CoAxiom br) -> Maybe (CoAxiom br1) + -> BootErrsM BootTyConMismatch +eqClosedFamilyAx Nothing Nothing = checkSuccess +eqClosedFamilyAx Nothing (Just _) = bootErr $ TyConAxiomMismatch $ NE.singleton MismatchedLength +eqClosedFamilyAx (Just _) Nothing = bootErr $ TyConAxiomMismatch $ NE.singleton MismatchedLength +eqClosedFamilyAx (Just (CoAxiom { co_ax_branches = branches1 })) + (Just (CoAxiom { co_ax_branches = branches2 })) + = checkListBy eqClosedFamilyBranch branch_list1 branch_list2 + TyConAxiomMismatch + where + branch_list1 = fromBranches branches1 + branch_list2 = fromBranches branches2 + +eqClosedFamilyBranch :: CoAxBranch -> CoAxBranch -> BootErrsM BootAxiomBranchMismatch +eqClosedFamilyBranch (CoAxBranch { cab_tvs = tvs1, cab_cvs = cvs1 + , cab_lhs = lhs1, cab_rhs = rhs1 }) + (CoAxBranch { cab_tvs = tvs2, cab_cvs = cvs2 + , cab_lhs = lhs2, cab_rhs = rhs2 }) + | Just env1 <- eqVarBndrs emptyRnEnv2 tvs1 tvs2 + , Just env <- eqVarBndrs env1 cvs1 cvs2 + = do { check (liftEq (eqTypeX env) lhs1 lhs2) MismatchedAxiomLHS + ; check (eqTypeX env rhs1 rhs2) MismatchedAxiomRHS } + | otherwise + = bootErr MismatchedAxiomBinders + +{- Note [Role subtyping] +~~~~~~~~~~~~~~~~~~~~~~~~ +In the current formulation of roles, role subtyping is only OK if the +"abstract" TyCon was not representationally injective. Among the most +notable examples of non representationally injective TyCons are abstract +data, which can be implemented via newtypes (which are not +representationally injective). The key example is +in this example from #13140: + + -- In an hsig file + data T a -- abstract! + type role T nominal + + -- Elsewhere + foo :: Coercible (T a) (T b) => a -> b + foo x = x + +We must NOT allow foo to typecheck, because if we instantiate +T with a concrete data type with a phantom role would cause +Coercible (T a) (T b) to be provable. Fortunately, if T is not +representationally injective, we cannot make the inference that a ~N b if +T a ~R T b. + +Unconditional role subtyping would be possible if we setup +an extra set of roles saying when we can project out coercions +(we call these proj-roles); then it would NOT be valid to instantiate T +with a data type at phantom since the proj-role subtyping check +would fail. See #13140 for more details. + +One consequence of this is we get no role subtyping for non-abstract +data types in signatures. Suppose you have: + + signature A where + type role T nominal + data T a = MkT + +If you write this, we'll treat T as injective, and make inferences +like T a ~R T b ==> a ~N b (mkSelCo). But if we can +subsequently replace T with one at phantom role, we would then be able to +infer things like T Int ~R T Bool which is bad news. + +We could allow role subtyping here if we didn't treat *any* data types +defined in signatures as injective. But this would be a bit surprising, +replacing a data type in a module with one in a signature could cause +your code to stop typechecking (whereas if you made the type abstract, +it is more understandable that the type checker knows less). + +It would have been best if this was purely a question of defaults +(i.e., a user could explicitly ask for one behavior or another) but +the current role system isn't expressive enough to do this. +Having explicit proj-roles would solve this problem. +-} + +checkRoles :: HsBootOrSig -> TyCon -> [Role] -> BootErrsM BootTyConMismatch +checkRoles boot_or_sig tc1 r2 + | boot_or_sig == HsBoot + || isInjectiveTyCon tc1 Representational -- See Note [Role subtyping] + = check (r1 == r2) (TyConRoleMismatch False) + | otherwise + = check (r2 `rolesSubtypeOf` r1) (TyConRoleMismatch True) + where + + r1 = tyConRoles tc1 + + rolesSubtypeOf [] [] = True + -- NB: this relation is the OPPOSITE of the subroling relation + rolesSubtypeOf (x:xs) (y:ys) = x >= y && rolesSubtypeOf xs ys + rolesSubtypeOf _ _ = False + +{- Note [Synonyms implement abstract data] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +An abstract data type or class can be implemented using a type synonym, +but ONLY if: + + 1. T, as a standalone occurrence, is a valid type + (T is "curryable"), and + + 2. T is valid in an instance head. + +This gives rise to the following conditions under which we can implement +an abstract data declaration @data T@ using a type synonym @type T tvs = rhs@: + + 1. The type synonym T is nullary (tvs is null). + + 2. The rhs must not contain any foralls, quantified types, or type family + applications. + See 'invalidAbsDataSubTypes' which computes a collection of + invalid subtypes. + +See also 'HowAbstract' and Note [Skolem abstract data]. +-} + +-- | We are implementing an abstract data declaration of the form @data T@ +-- in a signature file, with a type synonym @type T tvs = rhs@ in the +-- implementing module. +-- +-- This function checks that the implementation is valid: +-- +-- 1. the type synonym T is nullary, i.e. tvs is null, +-- 2. rhs doesn't contain any type families, foralls, or qualified types. +-- +-- See Note [Synonyms implement abstract data] +checkSynAbsData :: TyCon -- ^ @tc1@, the abstract data 'TyCon' we are implementing + -> TyCon -- ^ @tc2@, a type synonym @type T tvs = ty@ + -- we are using to implement @tc1@ + -> [TyVar] -- ^ @tvs@ + -> Type -- ^ @ty@ + -> BootErrsM BootTyConMismatch +checkSynAbsData tc1 tc2 syn_tvs syn_rhs + -- We are implementing @data T@ with @type T tvs = rhs@. + -- Check the conditions of Note [Synonyms implement abstract data]. + = do { -- (1): T is nullary. + ; check (null syn_tvs) $ + SynAbstractData SynAbsDataTySynNotNullary + -- (2): the RHS of the type synonym is valid. + ; case invalidAbsDataSubTypes syn_rhs of + [] -> checkSuccess + err:errs -> bootErr $ SynAbstractData $ + SynAbstractDataInvalidRHS (err :| errs) + -- NB: this allows implementing e.g. @data T :: Nat@ with @type T = 3@. + -- See #15138. + + -- TODO: When it's a synonym implementing a class, we really + -- should check that the fundeps are satisfied, but + -- there is not an obvious way to do this for a constraint synonym. + -- So for now, let it all through (it won't cause segfaults, anyway). + -- Tracked at #12704. + + -- ... we also need to check roles. + ; if | Just (tc2', args) <- tcSplitTyConApp_maybe syn_rhs + , null syn_tvs -- Don't report role errors unless the type synonym is nullary + -> assert (null (tyConRoles tc2)) $ + -- If we have something like: + -- + -- signature H where + -- data T a + -- module H where + -- data K a b = ... + -- type T = K Int + -- + -- we need to drop the first role of K when comparing! + checkRoles Hsig tc1 (drop (length args) (tyConRoles tc2')) + | otherwise + -> checkSuccess + } + +{- + -- Hypothetically, if we were allow to non-nullary type synonyms, here + -- is how you would check the roles + if length tvs == length roles1 + then checkRoles roles1 roles2 + else case tcSplitTyConApp_maybe ty of + Just (tc2', args) -> + checkRoles Hsig tc1 (drop (length args) (tyConRoles tc2') ++ roles2) + Nothing -> Just roles_msg +-} + +-- | Is this type a valid implementation of abstract data? +-- +-- Returns a list of invalid sub-types encountered. +invalidAbsDataSubTypes :: Type -> [Type] +invalidAbsDataSubTypes = execWriter . go + where + go :: Type -> Writer [Type] () + go ty + | Just ty' <- coreView ty + = go ty' + go TyVarTy{} + = ok -- We report an error at the binding site of type variables, + -- e.g. in the TySyn LHS or in the forall. + -- It's not useful to report a second error for their occurrences + go (AppTy t1 t2) + = do { go t1; go t2 } + go ty@(TyConApp tc tys) + | isTypeFamilyTyCon tc + = invalid ty + | otherwise + = mapM_ go tys + go ty@(ForAllTy{}) + = invalid ty + go ty@(FunTy af w t1 t2) + | af == FTF_T_T + = do { go w + ; go (typeKind t1) ; go t1 + ; go (typeKind t2) ; go t2 + } + | otherwise + = invalid ty + go LitTy{} + = ok + go ty@(CastTy{}) + = invalid ty + go ty@(CoercionTy{}) + = invalid ty + + ok = pure () + invalid ty = tell [ty] + +{- +************************************************************************ +* * + Type-checking the top level of a module (continued) +* * +************************************************************************ +-} + +rnTopSrcDecls :: HsGroup GhcPs -> TcM (TcGblEnv, HsGroup GhcRn) +-- Fails if there are any errors +rnTopSrcDecls group + = do { -- Rename the source decls + traceRn "rn12" empty ; + (tcg_env, rn_decls) <- checkNoErrs $ rnSrcDecls group ; + traceRn "rn13" empty ; + (tcg_env, rn_decls) <- runRenamerPlugin tcg_env rn_decls ; + traceRn "rn13-plugin" empty ; + + -- save the renamed syntax, if we want it + let { tcg_env' + | Just grp <- tcg_rn_decls tcg_env + = tcg_env{ tcg_rn_decls = Just (appendGroups grp rn_decls) } + | otherwise + = tcg_env }; + + -- Dump trace of renaming part + rnDump rn_decls ; + return (tcg_env', rn_decls) + } + +tcTopSrcDecls :: HsGroup GhcRn -> TcM (TcGblEnv, TcLclEnv) +tcTopSrcDecls (HsGroup { hs_tyclds = tycl_decls, + hs_derivds = deriv_decls, + hs_fords = foreign_decls, + hs_defds = default_decls, + hs_annds = annotation_decls, + hs_ruleds = rule_decls, + hs_valds = hs_val_binds@(XValBindsLR + (NValBinds val_binds val_sigs)) }) + = do { -- Type-check the type and class decls, and all imported decls + -- The latter come in via tycl_decls + traceTc "Tc2 (src)" empty ; + + -- Source-language instances, including derivings, + -- and import the supporting declarations + traceTc "Tc3" empty ; + (tcg_env, inst_infos, th_bndrs, + XValBindsLR (NValBinds deriv_binds deriv_sigs)) + <- 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 { + + -- Foreign import declarations next. + traceTc "Tc4" empty ; + (fi_ids, fi_decls, fi_gres) <- tcForeignImports foreign_decls ; + tcExtendGlobalValEnv fi_ids $ do { + + -- Value declarations next. + -- It is important that we check the top-level value bindings + -- before the GHC-generated derived bindings, since the latter + -- may be defined in terms of the former. (For instance, + -- the bindings produced in a Data instance.) + traceTc "Tc5" empty ; + tc_envs <- tcTopBinds val_binds val_sigs; + restoreEnvs tc_envs $ do { + + -- Now GHC-generated derived bindings, generics, and selectors + -- Do not generate warnings from compiler-generated code; + -- hence the use of discardWarnings + tc_envs@(tcg_env, tcl_env) + <- discardWarnings (tcTopBinds deriv_binds deriv_sigs) ; + restoreEnvs tc_envs $ do { -- Environment doesn't change now + + -- Second pass over class and instance declarations, + -- now using the kind-checked decls + traceTc "Tc6" empty ; + inst_binds <- tcInstDecls2 (tyClGroupTyClDecls tycl_decls) inst_infos ; + + -- Foreign exports + traceTc "Tc7" empty ; + (foe_binds, foe_decls, foe_gres) <- tcForeignExports foreign_decls ; + + -- Annotations + annotations <- tcAnnotations annotation_decls ; + + -- Rules + rules <- tcRules rule_decls ; + + -- Wrap up + traceTc "Tc7a" empty ; + let { all_binds = inst_binds ++ foe_binds + + ; fo_gres = fi_gres `unionBags` foe_gres + ; fo_fvs = foldr (\gre fvs -> fvs `addOneFV` (greName gre)) + emptyFVs fo_gres + + ; sig_names = mkNameSet (collectHsValBinders CollNoDictBinders hs_val_binds) + `minusNameSet` getTypeSigNames val_sigs + + -- Extend the GblEnv with the (as yet un-zonked) + -- bindings, rules, foreign decls + ; 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 + , tcg_anns = tcg_anns tcg_env ++ annotations + , tcg_ann_env = extendAnnEnvList (tcg_ann_env tcg_env) annotations + , tcg_fords = tcg_fords tcg_env ++ foe_decls ++ fi_decls + , tcg_dus = tcg_dus tcg_env `plusDU` usesOnly fo_fvs } } ; + -- tcg_dus: see Note [Newtype constructor usage in foreign declarations] + + -- See Note [Newtype constructor usage in foreign declarations] + 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 + -- process; contains all dfuns for + -- this module + ThBindEnv, -- TH binding levels + HsValBinds GhcRn) -- Supporting bindings for derived + -- instances + +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 + ; (tcg_env', inst_info', val_binds) + <- tcInstDeclsDeriv deriv_info deriv_decls + ; setGblEnv tcg_env' $ do { + failIfErrsM + ; pure ( tcg_env', inst_info' ++ inst_info, th_bndrs, val_binds ) + }}}} + +{- ********************************************************************* +* * + Checking for 'main' +* * +************************************************************************ +-} + +checkMainType :: TcGblEnv -> TcRn WantedConstraints +-- If this is the Main module, and it defines a function main, +-- check that its type is of form IO tau. +-- If not, do nothing +-- See Note [Dealing with main] +checkMainType tcg_env + = do { hsc_env <- getTopEnv + ; if tcg_mod tcg_env /= mainModIs (hsc_HUE hsc_env) + then return emptyWC else + + do { rdr_env <- getGlobalRdrEnv + ; let dflags = hsc_dflags hsc_env + main_occ = getMainOcc dflags + main_gres = lookupGRE rdr_env (LookupOccName main_occ SameNameSpace) + ; case filter isLocalGRE main_gres of { + [] -> return emptyWC ; + (_:_:_) -> return emptyWC ; + [main_gre] -> + + do { let main_name = greName main_gre + ctxt = FunSigCtxt main_name NoRRC + ; main_id <- tcLookupId main_name + ; (io_ty,_) <- getIOType + ; let main_ty = idType main_id + eq_orig = TypeEqOrigin { uo_actual = main_ty + , uo_expected = io_ty + , uo_thing = Nothing + , uo_visible = True } + ; (_, lie) <- captureTopConstraints $ + setMainCtxt main_name io_ty $ + tcSubTypeSigma eq_orig ctxt main_ty io_ty + ; return lie } } } } + +checkMain :: Bool -- False => no 'module M(..) where' header at all + -> 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 +-- See Note [Dealing with main] +checkMain explicit_mod_hdr export_ies + = do { hsc_env <- getTopEnv + ; tcg_env <- getGblEnv + + ; let dflags = hsc_dflags hsc_env + main_mod = mainModIs (hsc_HUE hsc_env) + main_occ = getMainOcc dflags + + exported_mains :: [Name] + -- Exported things that are called 'main' + exported_mains = [ name | avail <- tcg_exports tcg_env + , name <- availNames avail + , nameOccName name == main_occ ] + + ; if | tcg_mod tcg_env /= main_mod + -> -- Not the main module + return tcg_env + + | [main_name] <- exported_mains + -> -- The module indeed exports a function called 'main' + generateMainBinding tcg_env main_name + + | otherwise + -> assert (null exported_mains) $ + -- A fully-checked export list can't contain more + -- than one function with the same OccName + do { complain_no_main dflags main_mod main_occ + ; return tcg_env } } + where + complain_no_main dflags main_mod main_occ + = unless (interactive && not explicit_mod_hdr) $ + addErrTc (noMainMsg main_mod main_occ) -- #12906 + where + interactive = ghcLink dflags == LinkInMemory + -- Without an explicit module header... + -- in interactive mode, don't worry about the absence of 'main'. + -- in other modes, add error message and go on with typechecking. + + noMainMsg main_mod main_occ + = TcRnMissingMain explicit_export_list main_mod main_occ + explicit_export_list = explicit_mod_hdr && isJust export_ies + +-- | Get the unqualified name of the function to use as the \"main\" for the main module. +-- Either returns the default name or the one configured on the command line with -main-is +getMainOcc :: DynFlags -> OccName +getMainOcc dflags = case mainFunIs dflags of + Just fn -> mkVarOccFS (mkFastString fn) + Nothing -> mkVarOccFS (fsLit "main") + +generateMainBinding :: TcGblEnv -> Name -> TcM TcGblEnv +-- There is a single exported 'main' function, called 'foo' (say), +-- which may be locally defined or imported +-- Define and typecheck the binding +-- :Main.main :: IO res_ty = runMainIO res_ty foo +-- This wraps the user's main function in the top-level stuff +-- defined in runMainIO (eg catching otherwise un-caught exceptions) +-- See Note [Dealing with main] +generateMainBinding tcg_env main_name = do + { traceTc "checkMain found" (ppr main_name) + ; (io_ty, res_ty) <- getIOType + ; let loc = getSrcSpan 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 + + -- See Note [Root-main Id] + -- Construct the binding + -- :Main.main :: IO res_ty = runMainIO res_ty main + ; run_main_id <- tcLookupId runMainIOName + ; let { root_main_name = mkExternalName rootMainKey rOOT_MAIN + (mkVarOccFS (fsLit "main")) + (getSrcSpan main_name) + ; root_main_id = Id.mkExportedVanillaId root_main_name io_ty + ; co = mkWpTyApps [res_ty] + -- The ev_binds of the `main` function may contain deferred + -- type errors when type of `main` is not `IO a`. The `ev_binds` + -- must be put inside `runMainIO` to ensure the deferred type + -- error can be emitted correctly. See #13838. + ; rhs = nlHsApp (mkLHsWrap co (nlHsVar run_main_id)) $ + mkHsDictLet ev_binds main_expr + ; main_bind = mkVarBind root_main_id rhs } + + ; return (tcg_env { tcg_main = Just main_name + , tcg_binds = tcg_binds tcg_env + ++ [main_bind] + , tcg_dus = tcg_dus tcg_env + `plusDU` usesOnly (unitFV main_name) }) + -- Record the use of 'main', so that we don't + -- complain about it being defined but not used + } + +getIOType :: TcM (TcType, TcType) +-- Return (IO alpha, alpha) for fresh alpha +getIOType = do { ioTyCon <- tcLookupTyCon ioTyConName + ; res_ty <- newFlexiTyVarTy liftedTypeKind + ; return (mkTyConApp ioTyCon [res_ty], res_ty) } + +setMainCtxt :: Name -> TcType -> TcM a -> TcM (TcEvBinds, a) +setMainCtxt main_name io_ty thing_inside + = setSrcSpan (getSrcSpan main_name) $ + 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 [] + +{- Note [Dealing with main] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Dealing with the 'main' declaration is surprisingly tricky. Here are +the moving parts: + +* The flag -main-is=M.foo allows you to set the main module to 'M', + and the main function to 'foo'. We access them through + mainModIs :: HscEnv -> Module -- returns M + getMainOcc :: DynFlags -> OccName -- returns foo + Of course usually M = Main, and foo = main. + +* checkMainType: when typechecking module M, we add an extra check that + foo :: IO tau, for some type tau. + This avoids getting ambiguous-type errors from the monomorphism restriction + applying to things like + main = return () + Note that checkMainType does not consult the export list because + we have not yet done rnExports (and can't do it until later). + +* rnExports: checks the export list. Very annoyingly, we can only do + this after running any finalisers, which may add new declarations. + That's why checkMainType and checkMain have to be separate. + +* checkMain: does two things: + - check that the export list does indeed export something called 'foo' + - generateMainBinding: generate the root-main binding + :Main.main = runMainIO M.foo + See Note [Root-main Id] + +An annoying consequence of having both checkMainType and checkMain is +that, when (but only when) -fdefer-type-errors is on, we may report an +ill-typed 'main' twice (as warnings): once in checkMainType and once +in checkMain. See test typecheck/should_fail/T13292. + +We have the following tests to check this processing: +----------------+----------------------------------------------------------------------------------+ + | Module Header: | + +-------------+-------------+-------------+-------------+-------------+------------+ + | module | module Main | | module Main |module |module Main | + | Main(main) | | | (module X)| Main () | (Sub.main)| +----------------+==================================================================================+ +`main` function | ERROR: | Main.main | ERROR: | Main.main | ERROR: | Sub.main | +in Main module | Ambiguous | | Ambiguous | | `main` not | | +and in imported | | | | | exported | | +module Sub. | T19397E1 | T16453M0 | T19397E2 | T16453M3 | | T16453M1 | + | | | | X = Main | Remark 2) | | +----------------+-------------+-------------+-------------+-------------+-------------+------------+ +`main`function | Sub.main | ERROR: | Sub.main | Sub.main | ERROR: | Sub.main | +only in imported| | No `main` in| | | `main` not | | +submodule Sub. | | `Main` | | | exported | | + | T19397M0 | T16453E1 | T19397M1 | T16453M4 | | T16453M5 | + | | | | X = Sub | Remark 2) | | +----------------+-------------+-------------+-------------+-------------+-------------+------------+ +`foo` function | Sub.foo | ERROR: | Sub.foo | Sub.foo | ERROR: | Sub.foo | +in submodule | | No `foo` in | | | `foo` not | | +Sub. | | `Main` | | | exported | | +GHC option: | | | | | | | + -main-is foo | T19397M2 | T19397E3 | T19397M3 | T19397M4 | T19397E4 | T16453M6 | + | Remark 1) | | | X = Sub | | Remark 3) | +----------------+-------------+-------------+-------------+-------------+-------------+------------+ + +Remarks: +* The first line shows the exported `main` function or the error. +* The second line shows the coresponding test case. +* The module `Sub` contains the following functions: + main :: IO () + foo :: IO () +* Remark 1) Here the header is `Main (foo)`. +* Remark 2) Here we have no extra test case. It would exercise the same code path as `T19397E4`. +* Remark 3) Here the header is `Main (Sub.foo)`. + + +Note [Root-main Id] +~~~~~~~~~~~~~~~~~~~ +The function that the RTS invokes is always :Main.main, which we call +root_main_id. (Because GHC allows the user to have a module not +called Main as the main module, we can't rely on the main function +being called "Main.main". That's why root_main_id has a fixed module +":Main".) + +This is unusual: it's a LocalId whose Name has a Module from another +module. Tiresomely, we must filter it out again in GHC.Iface.Make, less we +get two defns for 'main' in the interface file! + +When using `-fwrite-if-simplified-core` the root_main_id can end up in an interface file. +When the interface is read back in we have to add a special case when creating the +Id because otherwise we would go looking for the :Main module which obviously doesn't +exist. For this logic see GHC.IfaceToCore.mk_top_id. + +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 +* * +********************************************************* +-} + +-- 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)) + , text "icReaderEnv (LocalDef)" <+> + vcat (map ppr [ local_gres | gres <- nonDetOccEnvElts (icReaderEnv icxt) + , let local_gres = filter isLocalGRE gres + , not (null local_gres) ]) ] + + ; 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 -> 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') + + where + gbl_env' = gbl_env + { tcg_rdr_env = icReaderEnv icxt + , tcg_type_env = type_env + , tcg_inst_env = tcg_inst_env gbl_env `unionInstEnv` ic_insts `unionInstEnv` home_insts + , tcg_fam_inst_env = extendFamInstEnvList + (extendFamInstEnvList (tcg_fam_inst_env gbl_env) + ic_finsts) + home_fam_insts + , tcg_fix_env = ic_fix_env icxt + , tcg_default = ic_default icxt + -- must calculate imp_orphs of the ImportAvails + -- so that instance visibility is done correctly + , tcg_imports = imports } + + lcl_env' = modifyLclCtxt (tcExtendLocalTypeEnv lcl_ids) lcl_env + + ; updEnvs upd_envs thing_inside } + where + icxt = hsc_IC hsc_env + (ic_insts, ic_finsts) = ic_instances icxt + (lcl_ids, top_ty_things) = partitionWith is_closed (ic_tythings icxt) + + is_closed :: TyThing -> Either (Name, TcTyThing) TyThing + -- Put Ids with free type variables (always RuntimeUnks) + -- in the *local* type environment + -- See Note [Initialising the type environment for GHCi] + is_closed thing + | AnId id <- thing + , not (isTypeClosedLetBndr id) + = Left (idName id, ATcId { tct_id = id + , tct_info = NotLetBound }) + | otherwise + = Right thing + + type_env1 = mkTypeEnvWithImplicits top_ty_things + type_env = extendTypeEnvWithIds type_env1 + $ map instanceDFunId (instEnvElts ic_insts) + -- Putting the dfuns in the type_env + -- is just to keep Core Lint happy + +{- Note [Initialising the type environment for GHCi] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Most of the Ids in ic_things, defined by the user in 'let' stmts, +have closed types. E.g. + ghci> let foo x y = x && not y + +However the GHCi debugger creates top-level bindings for Ids whose +types have free RuntimeUnk skolem variables, standing for unknown +types. If we don't register these free TyVars as global TyVars then +the typechecker will try to quantify over them and fall over in +skolemiseQuantifiedTyVar. so we must add any free TyVars to the +typechecker's global TyVar set. That is done by using +tcExtendLocalTypeEnv. + +We do this by splitting out the Ids with open types, using 'is_closed' +to do the partition. The top-level things go in the global TypeEnv; +the open, NotTopLevel, Ids, with free RuntimeUnk tyvars, go in the +local TypeEnv. + +Note that we don't extend the local RdrEnv (tcl_rdr); all the in-scope +things are already in the interactive context's GlobalRdrEnv. +Extending the local RdrEnv isn't terrible, but it means there is an +entry for the same Name in both global and local RdrEnvs, and that +lead to duplicate "perhaps you meant..." suggestions (e.g. T5564). + +We don't bother with the tcl_th_bndrs environment either. +-} + +-- | The returned [Id] is the list of new Ids bound by this statement. It can +-- be used to extend the InteractiveContext via extendInteractiveContext. +-- +-- The returned TypecheckedHsExpr is of type IO [ Any ], a list of the bound +-- values, coerced to Any. +tcRnStmt :: HscEnv -> GhciLStmt GhcPs + -> IO (Messages TcRnMessage, Maybe ([Id], LHsExpr GhcTc, FixityEnv)) +tcRnStmt hsc_env rdr_stmt + = runTcInteractive hsc_env $ do { + + -- The real work is done here + ((bound_ids, tc_expr), fix_env) <- tcUserStmt rdr_stmt ; + zonked_expr <- zonkTopLExpr tc_expr ; + zonked_ids <- zonkTopBndrs bound_ids ; + + failIfErrsM ; -- we can't do the next step if there are + -- representation polymorphism errors + -- test case: ghci/scripts/T13202{,a} + + -- None of the Ids should be of unboxed type, because we + -- cast them all to HValues in the end! + mapM_ (addErr . TcRnGhciUnliftedBind) $ + filter (mightBeUnliftedType . idType) zonked_ids ; + + traceTc "tcs 1" empty ; + this_mod <- getModule ; + global_ids <- mapM (externaliseAndTidyId this_mod) zonked_ids ; + -- Note [Interactively-bound Ids in GHCi] in GHC.Driver.Env + + traceOptTcRn Opt_D_dump_tc + (vcat [text "Bound Ids" <+> pprWithCommas ppr global_ids, + text "Typechecked expr" <+> ppr zonked_expr]) ; + + return (global_ids, zonked_expr, fix_env) + } + +{- +-------------------------------------------------------------------------- + Typechecking Stmts in GHCi + +Here is the grand plan, implemented in tcUserStmt + + What you type The IO [HValue] that hscStmt returns + ------------- ------------------------------------ + let pat = expr ==> let pat = expr in return [coerce HVal x, coerce HVal y, ...] + bindings: [x,y,...] + + pat <- expr ==> expr >>= \ pat -> return [coerce HVal x, coerce HVal y, ...] + bindings: [x,y,...] + + expr (of IO type) ==> expr >>= \ it -> return [coerce HVal it] + [NB: result not printed] bindings: [it] + + expr (of non-IO type, ==> let it = expr in print it >> return [coerce HVal it] + result showable) bindings: [it] + + expr (of non-IO type, + result not showable) ==> error +-} + +-- | A plan is an attempt to lift some code into the IO monad. +type PlanResult = ([Id], LHsExpr GhcTc) +type Plan = TcM PlanResult + +-- | Try the plans in order. If one fails (by raising an exn), try the next. +-- If one succeeds, take it. +runPlans :: NonEmpty Plan -> Plan +runPlans = foldr1 (flip tryTcDiscardingErrs) + +-- | Typecheck (and 'lift') a stmt entered by the user in GHCi into the +-- GHCi 'environment'. +-- +-- By 'lift' and 'environment we mean that the code is changed to +-- execute properly in an IO monad. See Note [Interactively-bound Ids +-- in GHCi] in GHC.Driver.Env for more details. We do this lifting by trying +-- different ways ('plans') of lifting the code into the IO monad and +-- type checking each plan until one succeeds. +tcUserStmt :: GhciLStmt GhcPs -> TcM (PlanResult, FixityEnv) + +-- An expression typed at the prompt is treated very specially +tcUserStmt (L loc (BodyStmt _ expr _ _)) + = do { (rn_expr, fvs) <- checkNoErrs (rnLExpr expr) + + ; dumpOptTcRn Opt_D_dump_rn_ast "Renamer" FormatHaskell + (showAstData NoBlankSrcSpan NoBlankEpAnnotations rn_expr) + -- Don't try to typecheck if the renamer fails! + ; ghciStep <- getGhciStepIO + ; uniq <- newUnique + ; let loc' = noAnnSrcSpan $ locA loc + ; interPrintName <- getInteractivePrintName + ; let fresh_it = itName uniq (locA loc) + matches = [mkMatch (mkPrefixFunRhs (L loc' fresh_it) noAnn) (noLocA []) rn_expr + emptyLocalBinds] + -- [it = expr] + the_bind = L loc $ (mkTopFunBind FromSource + (L loc' fresh_it) matches) + { fun_ext = fvs } + -- Care here! In GHCi the expression might have + -- free variables, and they in turn may have free type variables + -- (if we are at a breakpoint, say). We must put those free vars + + -- [let it = expr] + let_stmt = L loc $ LetStmt noAnn $ HsValBinds noAnn + $ XValBindsLR + (NValBinds [(NonRecursive,[the_bind])] []) + + -- [it <- e] + bind_stmt = L loc $ BindStmt + (XBindStmtRn + { xbsrn_bindOp = mkRnSyntaxExpr bindIOName + , xbsrn_failOp = Nothing + }) + (L loc (VarPat noExtField (L loc' fresh_it))) + (nlHsApp ghciStep rn_expr) + + -- [; print it] + print_it = L loc $ BodyStmt noExtField + (nlHsApp (nlHsVar interPrintName) + (nlHsVar fresh_it)) + (mkRnSyntaxExpr thenIOName) + noSyntaxExpr + + -- NewA + no_it_a = L loc $ BodyStmt noExtField (nlHsApps bindIOName + [rn_expr , nlHsVar interPrintName]) + (mkRnSyntaxExpr thenIOName) + noSyntaxExpr + + no_it_b = L loc $ BodyStmt noExtField (rn_expr) + (mkRnSyntaxExpr thenIOName) + noSyntaxExpr + + no_it_c = L loc $ BodyStmt noExtField + (nlHsApp (nlHsVar interPrintName) rn_expr) + (mkRnSyntaxExpr thenIOName) + noSyntaxExpr + + -- See Note [GHCi Plans] + + it_plans = + -- Plan A + do { stuff@([it_id], _) <- tcGhciStmts [bind_stmt, print_it] + ; it_ty <- liftZonkM $ zonkTcType (idType it_id) + ; when (isUnitTy it_ty) failM + ; return stuff } :| + + -- Plan B; a naked bind statement + [ tcGhciStmts [bind_stmt] + + -- Plan C; check that the let-binding is typeable all by itself. + -- If not, fail; if so, try to print it. + -- The two-step process avoids getting two errors: one from + -- the expression itself, and one from the 'print it' part + -- This two-step story is very clunky, alas + , do { _ <- checkNoErrs (tcGhciStmts [let_stmt]) + --- checkNoErrs defeats the error recovery of let-bindings + ; tcGhciStmts [let_stmt, print_it] } ] + + -- Plans where we don't bind "it" + no_it_plans = + tcGhciStmts [no_it_a] :| + tcGhciStmts [no_it_b] : + tcGhciStmts [no_it_c] : + [] + + ; generate_it <- goptM Opt_NoIt + + -- We disable `-fdefer-type-errors` in GHCi for naked expressions. + -- See Note [Deferred type errors in GHCi] + + -- NB: The flag `-fdefer-type-errors` implies `-fdefer-type-holes` + -- and `-fdefer-out-of-scope-variables`. However the flag + -- `-fno-defer-type-errors` doesn't imply `-fdefer-type-holes` and + -- `-fno-defer-out-of-scope-variables`. Thus the later two flags + -- also need to be unset here. + ; plan <- unsetGOptM Opt_DeferTypeErrors $ + unsetGOptM Opt_DeferTypedHoles $ + unsetGOptM Opt_DeferOutOfScopeVariables $ + runPlans $ if generate_it + then no_it_plans + else it_plans + + ; dumpOptTcRn Opt_D_dump_tc_ast "Typechecker AST" FormatHaskell + (showAstData NoBlankSrcSpan NoBlankEpAnnotations plan) + + ; fix_env <- getFixityEnv + ; return (plan, fix_env) } + +{- Note [Deferred type errors in GHCi] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In GHCi, we ensure that type errors don't get deferred when type checking the +naked expressions. Deferring type errors here is unhelpful because the +expression gets evaluated right away anyway. It also would potentially emit +two redundant type-error warnings, one from each plan. + +#14963 reveals another bug that when deferred type errors is enabled +in GHCi, any reference of imported/loaded variables (directly or indirectly) +in interactively issued naked expressions will cause ghc panic. See more +detailed discussion in #14963. + +The interactively issued declarations, statements, as well as the modules +loaded into GHCi, are not affected. That means, for declaration, you could +have + + Prelude> :set -fdefer-type-errors + Prelude> x :: IO (); x = putStrLn True + :14:26: warning: [-Wdeferred-type-errors] + ? Couldn't match type ‘Bool’ with ‘[Char]’ + Expected type: String + Actual type: Bool + ? In the first argument of ‘putStrLn’, namely ‘True’ + In the expression: putStrLn True + In an equation for ‘x’: x = putStrLn True + +But for naked expressions, you will have + + Prelude> :set -fdefer-type-errors + Prelude> putStrLn True + :2:10: error: + ? Couldn't match type ‘Bool’ with ‘[Char]’ + Expected type: String + Actual type: Bool + ? In the first argument of ‘putStrLn’, namely ‘True’ + In the expression: putStrLn True + In an equation for ‘it’: it = putStrLn True + + Prelude> let x = putStrLn True + :2:18: warning: [-Wdeferred-type-errors] + ? Couldn't match type ‘Bool’ with ‘[Char]’ + Expected type: String + Actual type: Bool + ? In the first argument of ‘putStrLn’, namely ‘True’ + In the expression: putStrLn True + In an equation for ‘x’: x = putStrLn True +-} + +tcUserStmt rdr_stmt@(L loc _) + = do { (([rn_stmt], fix_env), fvs) <- checkNoErrs $ + rnStmts (HsDoStmt GhciStmtCtxt) rnExpr [rdr_stmt] $ \_ -> do + fix_env <- getFixityEnv + return (fix_env, emptyFVs) + -- Don't try to typecheck if the renamer fails! + ; traceRn "tcRnStmt" (vcat [ppr rdr_stmt, ppr rn_stmt, ppr fvs]) + ; rnDump rn_stmt ; + + ; ghciStep <- getGhciStepIO + ; let gi_stmt + | (L loc (BindStmt x pat expr)) <- rn_stmt + = L loc $ BindStmt x pat (nlHsApp ghciStep expr) + | otherwise = rn_stmt + + ; opt_pr_flag <- goptM Opt_PrintBindResult + ; let print_result_plan + | opt_pr_flag -- The flag says "print result" + , [v] <- collectLStmtBinders CollNoDictBinders gi_stmt -- One binder + = Just $ mk_print_result_plan gi_stmt v + | otherwise = Nothing + + -- The plans are: + -- [stmt; print v] if one binder and not v::() + -- [stmt] otherwise + ; plan <- runPlans $ maybe id (NE.<|) print_result_plan $ NE.singleton $ tcGhciStmts [gi_stmt] + ; return (plan, fix_env) } + where + mk_print_result_plan stmt v + = do { stuff@([v_id], _) <- tcGhciStmts [stmt, print_v] + ; v_ty <- liftZonkM $ zonkTcType (idType v_id) + ; when (isUnitTy v_ty || not (isTauTy v_ty)) failM + ; return stuff } + where + print_v = L loc $ BodyStmt noExtField (nlHsApp (nlHsVar printName) + (nlHsVar v)) + (mkRnSyntaxExpr thenIOName) noSyntaxExpr + +{- +Note [GHCi Plans] +~~~~~~~~~~~~~~~~~ +When a user types an expression in the repl we try to print it in three different +ways. Also, depending on whether -fno-it is set, we bind a variable called `it` +which can be used to refer to the result of the expression subsequently in the repl. + +The normal plans are : + A. [it <- e; print e] but not if it::() + B. [it <- e] + C. [let it = e; print it] + +When -fno-it is set, the plans are: + A. [e >>= print] + B. [e] + C. [let it = e in print it] + +The reason for -fno-it is explained in #14336. `it` can lead to the repl +leaking memory as it is repeatedly queried. +-} + +any_lifted :: Type +any_lifted = anyTypeOfKind liftedTypeKind + +-- | Typecheck the statements given and then return the results of the +-- statement in the form 'IO [Any]'. +tcGhciStmts :: [GhciLStmt GhcRn] -> TcM PlanResult +tcGhciStmts stmts + = do { ioTyCon <- tcLookupTyCon ioTyConName + ; ret_id <- tcLookupId returnIOName -- return @ IO + ; let ret_ty = mkListTy any_lifted + io_ret_ty = mkTyConApp ioTyCon [ret_ty] + tc_io_stmts = tcStmtsAndThen (HsDoStmt GhciStmtCtxt) tcDoStmt stmts + (mkCheckExpType io_ret_ty) + names = collectLStmtsBinders CollNoDictBinders stmts + + -- OK, we're ready to typecheck the stmts + ; traceTc "GHC.Tc.Module.tcGhciStmts: tc stmts" empty + ; ((tc_stmts, ids), lie) <- captureTopConstraints $ + tc_io_stmts $ \ _ -> + mapM tcLookupId names + -- Look up the names right in the middle, + -- where they will all be in scope + + -- Simplify the context + ; traceTc "GHC.Tc.Module.tcGhciStmts: simplify ctxt" empty + ; const_binds <- checkNoErrs (simplifyInteractive lie) + -- checkNoErrs ensures that the plan fails if context redn fails + + + ; traceTc "GHC.Tc.Module.tcGhciStmts: done" empty + + -- ret_expr is the expression + -- returnIO @[Any] [unsafeCoerce# @Any x, .., unsafeCoerce# @Any z] + -- + -- Despite the inconvenience of building the type applications etc, + -- this *has* to be done in type-annotated post-typecheck form + -- because we are going to return a list of *polymorphic* values + -- coerced to type Any. If we built a *source* stmt + -- return [coerce x, ..., coerce z] + -- then the type checker would instantiate x..z, and we wouldn't + -- get their *polymorphic* values. (And we'd get ambiguity errs + -- if they were overloaded, since they aren't applied to anything.) + -- + -- We use Any rather than a dummy type such as () because of + -- the rules of unsafeCoerce#; see Unsafe/Coerce.hs for the details. + + ; AnId unsafe_coerce_id <- tcLookupGlobal unsafeCoercePrimName + -- We use unsafeCoerce# here because of (U11) in + -- Note [Implementing unsafeCoerce] in base:Unsafe.Coerce + + ; let ret_expr = nlHsApp (nlHsTyApp ret_id [ret_ty]) $ + noLocA $ ExplicitList any_lifted $ + map mk_item ids + + mk_item id = unsafe_coerce_id `nlHsTyApp` [ getRuntimeRep (idType id) + , getRuntimeRep any_lifted + , idType id, any_lifted] + `nlHsApp` nlHsVar id + stmts = tc_stmts ++ [noLocA (mkLastStmt ret_expr)] + + ; return (ids, mkHsDictLet (EvBinds const_binds) $ + noLocA (HsDo io_ret_ty GhciStmtCtxt (noLocA stmts))) + } + +-- | Generate a typed ghciStepIO expression (ghciStep :: Ty a -> IO a) +getGhciStepIO :: TcM (LHsExpr GhcRn) +getGhciStepIO = do + ghciTy <- getGHCiMonad + a_tv <- newName (mkTyVarOccFS (fsLit "a")) + let ghciM = nlHsAppTy (nlHsTyVar NotPromoted ghciTy) (nlHsTyVar NotPromoted a_tv) + ioM = nlHsAppTy (nlHsTyVar NotPromoted ioTyConName) (nlHsTyVar NotPromoted a_tv) + + step_ty :: LHsSigType GhcRn + step_ty = noLocA $ HsSig + { sig_bndrs = HsOuterImplicit{hso_ximplicit = [a_tv]} + , sig_ext = noExtField + , sig_body = nlHsFunTy ghciM ioM } + + stepTy :: LHsSigWcType GhcRn + stepTy = mkEmptyWildCardBndrs step_ty + + return (noLocA $ ExprWithTySig noExtField (nlHsVar ghciStepIoMName) stepTy) + +isGHCiMonad :: HscEnv -> String -> IO (Messages TcRnMessage, Maybe Name) +isGHCiMonad hsc_env ty + = runTcInteractive hsc_env $ do + rdrEnv <- getGlobalRdrEnv + let occIO = lookupOccEnv rdrEnv (mkOccName tcName ty) + case occIO of + Just [n] -> do + let name = greName n + ghciClass <- tcLookupClass ghciIoClassName + userTyCon <- tcLookupTyCon name + let userTy = mkTyConApp userTyCon [] + _ <- tcLookupInstance ghciClass [userTy] + return name + _ -> failWithTc $ TcRnGhciMonadLookupFail ty occIO + +-- | How should we infer a type? See Note [TcRnExprMode] +data TcRnExprMode = TM_Inst -- ^ Instantiate inferred quantifiers only (:type) + | TM_Default -- ^ Instantiate all quantifiers, + -- and do eager defaulting (:type +d) + +-- | tcRnExpr just finds the type of an expression +-- for :type +tcRnExpr :: HscEnv + -> TcRnExprMode + -> LHsExpr GhcPs + -> IO (Messages TcRnMessage, Maybe Type) +tcRnExpr hsc_env mode rdr_expr + = runTcInteractive hsc_env $ + do { + + (rn_expr, _fvs) <- rnLExpr rdr_expr ; + failIfErrsM ; + + -- Typecheck the expression + ((tclvl, (_tc_expr, res_ty)), lie) + <- captureTopConstraints $ + pushTcLevelM $ + (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 TopLevel tclvl infer_mode + [] {- No sig vars -} + [(fresh_it, res_ty)] + lie ; + + -- Ignore the dictionary bindings + _ <- perhaps_disable_default_warnings $ + simplifyInteractive residual ; + + let { all_expr_ty = mkInfForAllTys qtvs $ + mkPhiTy (map idType dicts) res_ty } ; + ty <- liftZonkM $ zonkTcType all_expr_ty ; + + -- See Note [Normalising the type in :type] + fam_envs <- tcGetFamInstEnvs ; + let { normalised_type = reductionReducedType $ normaliseType fam_envs Nominal ty + -- normaliseType returns a coercion which we discard, so the Role is irrelevant. + ; final_type = if isSigmaTy res_ty then ty else normalised_type } ; + return final_type } + where + -- Optionally instantiate the type of the expression + -- See Note [TcRnExprMode] + (inst, infer_mode, perhaps_disable_default_warnings) = case mode of + TM_Inst -> (False, NoRestrictions, id) + TM_Default -> (True, EagerDefaulting, unsetWOptM Opt_WarnTypeDefaults) + +{- Note [Implementing :type] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider :type const + +We want forall a b. a -> b -> a +and not forall {a}{b}. a -> b -> a + +The latter is what we'd get if we eagerly instantiated and then +re-generalised with Inferred binders. It makes a difference, because +it tells us we where we can use Visible Type Application (VTA). + +And also for :type const @Int +we want forall b. Int -> b -> Int +and not forall {b}. Int -> b -> Int + +Solution: use tcInferSigma, which in turn uses tcInferApp, which +has a special case for application chains. + +Note [Normalising the type in :type] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In :t we usually normalise the type (to simplify type functions) +before displaying the result. Reason (see #10321): otherwise we may show +types like + :: Vec (1+2) Int +rather than the simpler + :: Vec 3 Int +In GHC.Tc.Gen.Bind.mkInferredPolyId we normalise for a very similar reason. + +However this normalisation is less helpful when is just +an identifier, whose user-written type happens to contain type-function +applications. E.g. (#20974) + test :: F [Monad, A, B] m => m () +where F is a type family. If we say `:t test`, we'd prefer to see +the type family un-expanded. + +We adopt the following ad-hoc solution: if the type inferred for +(before generalisation, namely res_ty) is a SigmaType (i.e. is not +fully instantiated) then do not normalise; otherwise normalise. +This is not ideal; for example, suppose x :: F Int. Then + :t x +would be normalised because `F Int` is not a SigmaType. But +anything here is ad-hoc, and it's a user-sought improvement. +-} + +-------------------------- +tcRnImportDecls :: HscEnv + -> [LImportDecl GhcPs] + -> IO (Messages TcRnMessage, Maybe GlobalRdrEnv) +-- Find the new chunk of GlobalRdrEnv created by this list of import +-- 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 + ; 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 + -> Bool -- Normalise the returned type + -> LHsType GhcPs + -> IO (Messages TcRnMessage, Maybe (Type, Kind)) +tcRnType hsc_env flexi normalise rdr_type + = runTcInteractive hsc_env $ + setXOptM LangExt.PolyKinds $ -- See Note [Kind-generalise in tcRnType] + do { (HsWC { hswc_ext = wcs, hswc_body = rn_sig_type@(L _ (HsSig{sig_bndrs = outer_bndrs, sig_body = body })) }, _fvs) + -- we are using 'rnHsSigWcType' to bind the unbound type variables + -- and in combination with 'tcOuterTKBndrs' we are able to + -- implicitly quantify them as if the user wrote 'forall' by + -- hand (see #19217). This allows kind check to work in presence + -- of free type variables : + -- ghci> :k [a] + -- [a] :: * + <- rnHsSigWcType GHCiCtx (mkHsWildCardBndrs $ noLocA (mkHsImplicitSigType rdr_type)) + -- The type can have wild cards, but no implicit + -- generalisation; e.g. :kind (T _) + ; failIfErrsM + + -- We follow Note [Recipe for checking a signature] in GHC.Tc.Gen.HsType here + + -- Now kind-check the type + -- It can have any rank or kind + -- First bring into scope any wildcards + ; traceTc "tcRnType" (vcat [ppr wcs, ppr rn_sig_type]) + ; si <- mkSkolemInfo $ SigTypeSkol (GhciCtxt True) + ; ((_, (ty, kind)), wanted) + <- captureTopConstraints $ + pushTcLevelM_ $ + bindNamedWildCardBinders wcs $ \ wcs' -> + do { mapM_ emitNamedTypeHole wcs' + ; tcOuterTKBndrs si outer_bndrs $ tcInferLHsTypeUnsaturated body } + -- Since all the wanteds are equalities, the returned bindings will be empty + ; empty_binds <- simplifyTop wanted + ; massertPpr (isEmptyBag empty_binds) (ppr empty_binds) + + -- Do kind generalisation; see Note [Kind-generalise in tcRnType] + ; kvs <- kindGeneralizeAll unkSkol kind + + ; ty <- initZonkEnv flexi $ zonkTcTypeToTypeX ty + + -- Do validity checking on type + ; checkValidType (GhciCtxt True) ty + + -- Optionally (:k vs :k!) normalise the type. Does two things: + -- normaliseType: expand type-family applications + -- expandTypeSynonyms: expand type synonyms (#18828) + ; fam_envs <- tcGetFamInstEnvs + ; let ty' | normalise = expandTypeSynonyms $ reductionReducedType $ + normaliseType fam_envs Nominal ty + | otherwise = ty + + ; traceTc "tcRnExpr" (debugPprType ty $$ debugPprType ty') + ; return (ty', mkInfForAllTys kvs (typeKind ty')) } + + +{- Note [TcRnExprMode] +~~~~~~~~~~~~~~~~~~~~~~ +How should we infer a type when a user asks for the type of an expression e +at the GHCi prompt? We offer 2 different possibilities, described below. Each +considers this example, with -fprint-explicit-foralls enabled. See also +https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0179-printing-foralls.rst + +:type / TM_Inst + + In this mode, we report the type obtained by instantiating only the + /inferred/ quantifiers of e's type, solving constraints, and + re-generalising, as discussed in #11376. + + > :type reverse + reverse :: forall a. [a] -> [a] + + -- foo :: forall a f b. (Show a, Num b, Foldable f) => a -> f b -> String + > :type foo @Int + forall f b. (Show Int, Num b, Foldable f) => Int -> f b -> String + + Note that Show Int is still reported, because the solver never got a chance + to see it. + +:type +d / TM_Default + + This mode is for the benefit of users who wish to see instantiations + of generalized types, and in particular to instantiate Foldable and + Traversable. In this mode, all type variables (inferred or + specified) are instantiated. Because GHCi uses + -XExtendedDefaultRules, this means that Foldable and Traversable are + defaulted. + + > :type +d reverse + reverse :: forall {a}. [a] -> [a] + + -- foo :: forall a f b. (Show a, Num b, Foldable f) => a -> f b -> String + > :type +d foo @Int + Int -> [Integer] -> String + + Note that this mode can sometimes lead to a type error, if a type variable is + used with a defaultable class but cannot actually be defaulted: + + bar :: (Num a, Monoid a) => a -> a + > :type +d bar + ** error ** + + The error arises because GHC tries to default a but cannot find a concrete + type in the defaulting list that is both Num and Monoid. (If this list is + modified to include an element that is both Num and Monoid, the defaulting + would succeed, of course.) + + Note that the variables and constraints are reordered here, because this + is possible during regeneralization. Also note that the variables are + reported as Inferred instead of Specified. + +Note [Kind-generalise in tcRnType] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We switch on PolyKinds when kind-checking a user type, so that we will +kind-generalise the type, even when PolyKinds is not otherwise on. +This gives the right default behaviour at the GHCi prompt, where if +you say ":k T", and T has a polymorphic kind, you'd like to see that +polymorphism. Of course. If T isn't kind-polymorphic you won't get +anything unexpected, but the apparent *loss* of polymorphism, for +types that you know are polymorphic, is quite surprising. See Trac +#7688 for a discussion. + +Note that the goal is to generalise the *kind of the type*, not +the type itself! Example: + ghci> data SameKind :: k -> k -> Type + ghci> :k SameKind _ + +We want to get `k -> Type`, not `Any -> Type`, which is what we would +get without kind-generalisation. Note that `:k SameKind` is OK, as +GHC will not instantiate SameKind here, and so we see its full kind +of `forall k. k -> k -> Type`. + +************************************************************************ +* * + tcRnDeclsi +* * +************************************************************************ + +tcRnDeclsi exists to allow class, data, and other declarations in GHCi. +-} + +tcRnDeclsi :: HscEnv + -> [LHsDecl GhcPs] + -> IO (Messages TcRnMessage, Maybe TcGblEnv) +tcRnDeclsi hsc_env local_decls + = runTcInteractive hsc_env $ + tcRnSrcDecls False Nothing local_decls + +externaliseAndTidyId :: Module -> Id -> TcM Id +externaliseAndTidyId this_mod id + = do { name' <- externaliseName this_mod (idName id) + ; return $ globaliseId id + `setIdName` name' + `setIdType` tidyTopType (idType id) } + + +{- +************************************************************************ +* * + More GHCi stuff, to do with browsing and getting info +* * +************************************************************************ +-} + +-- | ASSUMES that the module is either in the 'HomePackageTable' or is +-- a package module with an interface on disk. If neither of these is +-- true, then the result will be an error indicating the interface +-- could not be found. +getModuleInterface :: HscEnv -> Module -> IO (Messages TcRnMessage, Maybe ModIface) +getModuleInterface hsc_env mod + = runTcInteractive hsc_env $ + loadModuleInterface (text "getModuleInterface") mod + +tcRnLookupRdrName :: HscEnv -> LocatedN RdrName + -> IO (Messages TcRnMessage, Maybe [Name]) +-- ^ Find all the Names that this RdrName could mean, in GHCi +tcRnLookupRdrName hsc_env (L loc rdr_name) + = runTcInteractive hsc_env $ + setSrcSpanA loc $ + do { -- If the identifier is a constructor (begins with an + -- upper-case letter), then we need to consider both + -- constructor and type class identifiers. + let rdr_names = dataTcOccs rdr_name + ; names_s <- mapM lookupInfoOccRn rdr_names + ; let names = concat names_s + ; when (null names) (addErrTc $ TcRnNotInScope NotInScope rdr_name) + ; return names } + +tcRnLookupName :: HscEnv -> Name -> IO (Messages TcRnMessage, Maybe TyThing) +tcRnLookupName hsc_env name + = runTcInteractive hsc_env $ + tcRnLookupName' name + +-- To look up a name we have to look in the local environment (tcl_lcl) +-- as well as the global environment, which is what tcLookup does. +-- But we also want a TyThing, so we have to convert: + +tcRnLookupName' :: Name -> TcRn TyThing +tcRnLookupName' name = do + tcthing <- tcLookup name + case tcthing of + AGlobal thing -> return thing + ATcId{tct_id=id} -> return (AnId id) + _ -> panic "tcRnLookupName'" + +tcRnGetInfo :: HscEnv + -> Name + -> IO ( Messages TcRnMessage + , Maybe (TyThing, Fixity, [ClsInst], [FamInst], SDoc)) + +-- Used to implement :info in GHCi +-- +-- Look up a RdrName and return all the TyThings it might be +-- A capitalised RdrName is given to us in the DataName namespace, +-- but we want to treat it as *both* a data constructor +-- *and* as a type or class constructor; +-- hence the call to dataTcOccs, and we return up to two results +tcRnGetInfo hsc_env name + = runTcInteractive hsc_env $ + do { loadUnqualIfaces hsc_env (hsc_IC hsc_env) + -- Load the interface for all unqualified types and classes + -- That way we will find all the instance declarations + -- (Packages have not orphan modules, and we assume that + -- in the home package all relevant modules are loaded.) + + ; thing <- tcRnLookupName' name + ; fixity <- lookupFixityRn name + ; (cls_insts, fam_insts) <- lookupInsts thing + ; let info = lookupKnownNameInfo name + ; return (thing, fixity, cls_insts, fam_insts, info) } + + +-- Lookup all class and family instances for a type constructor. +-- +-- This function filters all instances in the type environment, so there +-- is a lot of duplicated work if it is called many times in the same +-- type environment. If this becomes a problem, the NameEnv computed +-- in GHC.getNameToInstancesIndex could be cached in TcM and both functions +-- could be changed to consult that index. +lookupInsts :: TyThing -> TcM ([ClsInst],[FamInst]) +lookupInsts (ATyCon tc) + = do { InstEnvs { ie_global = pkg_ie, ie_local = home_ie, ie_visible = vis_mods } <- tcGetInstEnvs + ; (pkg_fie, home_fie) <- tcGetFamInstEnvs + -- Load all instances for all classes that are + -- in the type environment (which are all the ones + -- we've seen in any interface file so far) + + -- Return only the instances relevant to the given thing, i.e. + -- the instances whose head contains the thing's name. + ; let cls_insts = + [ ispec -- Search all + | ispec <- instEnvElts home_ie ++ instEnvElts pkg_ie + , instIsVisible vis_mods ispec + , tc_name `elemNameSet` orphNamesOfClsInst ispec ] + ; let fam_insts = + [ fispec + | fispec <- famInstEnvElts home_fie ++ famInstEnvElts pkg_fie + , tc_name `elemNameSet` orphNamesOfFamInst fispec ] + ; return (cls_insts, fam_insts) } + where + tc_name = tyConName tc + +lookupInsts _ = return ([],[]) + +loadUnqualIfaces :: HscEnv -> InteractiveContext -> TcM () +-- Load the interface for everything that is in scope unqualified +-- This is so that we can accurately report the instances for +-- something +loadUnqualIfaces hsc_env ictxt + = initIfaceTcRn $ + mapM_ (loadSysInterface doc) (moduleSetElts (mkModuleSet unqual_mods)) + where + home_unit = hsc_home_unit hsc_env + + unqual_mods = [ nameModule name + | gre <- globalRdrEnvElts (icReaderEnv ictxt) + , let name = greName gre + , nameIsFromExternalPackage home_unit name + , isTcOcc (nameOccName name) -- Types and classes only + , unQualOK gre ] -- In scope unqualified + doc = text "Need interface for module whose export(s) are in scope unqualified" + + + +{- +************************************************************************ +* * + Debugging output + This is what happens when you do -ddump-types +* * +************************************************************************ +-} + +-- | Dump, with a banner, if -ddump-rn +rnDump :: (Outputable a, Data a) => a -> TcRn () +rnDump rn = dumpOptTcRn Opt_D_dump_rn "Renamer" FormatHaskell (ppr rn) + +tcDump :: TcGblEnv -> TcRn () +tcDump env + = do { unit_state <- hsc_units <$> getTopEnv ; + logger <- getLogger ; + + -- Dump short output if -ddump-types or -ddump-tc + when (logHasDumpFlag logger Opt_D_dump_types || logHasDumpFlag logger Opt_D_dump_tc) + (dumpTcRn True Opt_D_dump_types + "" FormatText (pprWithUnitState unit_state short_dump)) ; + + -- Dump bindings if -ddump-tc + dumpOptTcRn Opt_D_dump_tc "Typechecker" FormatHaskell full_dump; + + -- Dump bindings as an hsSyn AST if -ddump-tc-ast + dumpOptTcRn Opt_D_dump_tc_ast "Typechecker AST" FormatHaskell ast_dump + } + where + short_dump = pprTcGblEnv env + full_dump = pprLHsBinds (tcg_binds env) + -- NB: foreign x-d's have undefined's in their types; + -- hence can't show the tc_fords + ast_dump = showAstData NoBlankSrcSpan NoBlankEpAnnotations (tcg_binds env) + +-- It's unpleasant having both pprModGuts and pprModDetails here +pprTcGblEnv :: TcGblEnv -> SDoc +pprTcGblEnv (TcGblEnv { tcg_type_env = type_env, + tcg_insts = insts, + tcg_fam_insts = fam_insts, + tcg_rules = rules, + tcg_imports = imports }) + = getPprDebug $ \debug -> + vcat [ ppr_types debug type_env + , ppr_tycons debug fam_insts type_env + , ppr_datacons debug type_env + , ppr_patsyns type_env + , ppr_insts insts + , ppr_fam_insts fam_insts + , ppr_rules rules + , text "Dependent modules:" <+> + (ppr . sort . installedModuleEnvElts $ imp_direct_dep_mods imports) + , text "Dependent packages:" <+> + ppr (S.toList $ imp_dep_direct_pkgs imports)] + -- The use of sort is just to reduce unnecessary + -- wobbling in testsuite output + +ppr_rules :: [LRuleDecl GhcTc] -> SDoc +ppr_rules rules + = ppUnless (null rules) $ + hang (text "RULES") + 2 (vcat (map ppr rules)) + +ppr_types :: Bool -> TypeEnv -> SDoc +ppr_types debug type_env + = ppr_things "TYPE SIGNATURES" ppr_sig + (sortBy (comparing getOccName) ids) + where + ids = [id | id <- typeEnvIds type_env, want_sig id] + want_sig id + | debug = True + | otherwise = hasTopUserName id + && case idDetails id of + VanillaId -> True + WorkerLikeId {} -> True + RecSelId {} -> True + ClassOpId {} -> True + FCallId {} -> True + _ -> False + -- Data cons (workers and wrappers), pattern synonyms, + -- etc are suppressed (unless -dppr-debug), + -- because they appear elsewhere + + ppr_sig id = hang (pprPrefixOcc id <+> dcolon) 2 (ppr (tidyTopType (idType id))) + +ppr_tycons :: Bool -> [FamInst] -> TypeEnv -> SDoc +ppr_tycons debug fam_insts type_env + = vcat [ ppr_things "TYPE CONSTRUCTORS" ppr_tc tycons + , ppr_things "COERCION AXIOMS" ppr_ax + (typeEnvCoAxioms type_env) ] + where + fi_tycons = famInstsRepTyCons fam_insts + + tycons = sortBy (comparing getOccName) $ + [tycon | tycon <- typeEnvTyCons type_env + , want_tycon tycon] + -- Sort by OccName to reduce unnecessary changes + want_tycon tycon | debug = True + | otherwise = isExternalName (tyConName tycon) && + not (tycon `elem` fi_tycons) + ppr_tc tc + = vcat [ hang (ppr (tyConFlavour tc) <+> pprPrefixOcc (tyConName tc) + <> braces (ppr (tyConArity tc)) <+> dcolon) + 2 (ppr (tidyTopType (tyConKind tc))) + , nest 2 $ + ppWhen show_roles $ + text "roles" <+> (sep (map ppr roles)) ] + where + show_roles = debug || not (all (== boring_role) roles) + roles = tyConRoles tc + boring_role | isClassTyCon tc = Nominal + | otherwise = Representational + -- Matches the choice in GHC.Iface.Syntax, calls to pprRoles + + ppr_ax ax = ppr (coAxiomToIfaceDecl ax) + -- We go via IfaceDecl rather than using pprCoAxiom + -- This way we get the full axiom (both LHS and RHS) with + -- wildcard binders tidied to _1, _2, etc. + +ppr_datacons :: Bool -> TypeEnv -> SDoc +ppr_datacons debug type_env + = ppr_things "DATA CONSTRUCTORS" ppr_dc wanted_dcs + -- The filter gets rid of class data constructors + where + ppr_dc dc = sdocOption sdocLinearTypes (\show_linear_types -> + ppr dc <+> dcolon <+> ppr (dataConDisplayType show_linear_types dc)) + all_dcs = typeEnvDataCons type_env + wanted_dcs | debug = all_dcs + | otherwise = filterOut is_cls_dc all_dcs + is_cls_dc dc = isClassTyCon (dataConTyCon dc) + +ppr_patsyns :: TypeEnv -> SDoc +ppr_patsyns type_env + = ppr_things "PATTERN SYNONYMS" ppr_ps + (typeEnvPatSyns type_env) + where + ppr_ps ps = pprPrefixOcc ps <+> dcolon <+> pprPatSynType ps + +ppr_insts :: [ClsInst] -> SDoc +ppr_insts ispecs + = ppr_things "CLASS INSTANCES" pprInstance ispecs + +ppr_fam_insts :: [FamInst] -> SDoc +ppr_fam_insts fam_insts + = ppr_things "FAMILY INSTANCES" pprFamInst fam_insts + +ppr_things :: String -> (a -> SDoc) -> [a] -> SDoc +ppr_things herald ppr_one things + | null things = empty + | otherwise = text herald $$ nest 2 (vcat (map ppr_one things)) + +hasTopUserName :: NamedThing x => x -> Bool +-- A top-level thing whose name is not "derived" +-- Thus excluding things like $tcX, from Typeable boilerplate +-- and C:Coll from class-dictionary data constructors +hasTopUserName x + = isExternalName name && not (isDerivedOccName (nameOccName name)) + where + name = getName x + +{- +******************************************************************************** + +Type Checker Plugins + +******************************************************************************** +-} + +withTcPlugins :: HscEnv -> TcM a -> TcM a +withTcPlugins hsc_env m = + case catMaybes $ mapPlugins (hsc_plugins hsc_env) tcPlugin of + [] -> m -- Common fast case + plugins -> do + (solvers, rewriters, stops) <- + unzip3 `fmap` mapM start_plugin plugins + let + rewritersUniqFM :: UniqFM TyCon [TcPluginRewriter] + !rewritersUniqFM = sequenceUFMList rewriters + -- The following ensures that tcPluginStop is called even if a type + -- error occurs during compilation (Fix of #10078) + eitherRes <- tryM $ + updGblEnv (\e -> e { tcg_tc_plugin_solvers = solvers + , tcg_tc_plugin_rewriters = rewritersUniqFM }) m + mapM_ runTcPluginM stops + case eitherRes of + Left _ -> failM + Right res -> return res + where + start_plugin (TcPlugin start solve rewrite stop) = + do s <- runTcPluginM start + return (solve s, rewrite s, stop s) + +withDefaultingPlugins :: HscEnv -> TcM a -> TcM a +withDefaultingPlugins hsc_env m = + do case catMaybes $ mapPlugins (hsc_plugins hsc_env) defaultingPlugin of + [] -> m -- Common fast case + plugins -> do (plugins,stops) <- mapAndUnzipM start_plugin plugins + -- This ensures that dePluginStop is called even if a type + -- error occurs during compilation + eitherRes <- tryM $ do + updGblEnv (\e -> e { tcg_defaulting_plugins = plugins }) m + mapM_ runTcPluginM stops + case eitherRes of + Left _ -> failM + Right res -> return res + where + start_plugin (DefaultingPlugin start fill stop) = + do s <- runTcPluginM start + return (fill s, stop s) + +withHoleFitPlugins :: HscEnv -> TcM a -> TcM a +withHoleFitPlugins hsc_env m = + case catMaybes $ mapPlugins (hsc_plugins hsc_env) holeFitPlugin of + [] -> m -- Common fast case + plugins -> do (plugins,stops) <- mapAndUnzipM start_plugin plugins + -- This ensures that hfPluginStop is called even if a type + -- error occurs during compilation. + eitherRes <- tryM $ + updGblEnv (\e -> e { tcg_hf_plugins = plugins }) m + sequence_ stops + case eitherRes of + Left _ -> failM + Right res -> return res + where + start_plugin (HoleFitPluginR init plugin stop) = + do ref <- init + return (plugin ref, stop ref) + + +runRenamerPlugin :: TcGblEnv + -> HsGroup GhcRn + -> TcM (TcGblEnv, HsGroup GhcRn) +runRenamerPlugin gbl_env hs_group = do + hsc_env <- getTopEnv + withPlugins (hsc_plugins hsc_env) + (\p opts (e, g) -> ( mark_plugin_unsafe (hsc_dflags hsc_env) + >> renamedResultAction p opts e g)) + (gbl_env, hs_group) + + +-- XXX: should this really be a Maybe X? Check under which circumstances this +-- can become a Nothing and decide whether this should instead throw an +-- exception/signal an error. +type RenamedStuff = + (Maybe (HsGroup GhcRn, [LImportDecl GhcRn], Maybe [(LIE GhcRn, Avails)], + 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, 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 + hsc_env <- getTopEnv + withPlugins (hsc_plugins hsc_env) + (\p opts env -> mark_plugin_unsafe (hsc_dflags hsc_env) + >> typeCheckResultAction p opts sum env) + gbl_env + +mark_plugin_unsafe :: DynFlags -> TcM () +mark_plugin_unsafe dflags = unless (gopt Opt_PluginTrustworthy dflags) $ + recordUnsafeInfer pluginUnsafe + where + !diag_opts = initDiagOpts dflags + 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/Module.hs-boot b/GHC/Tc/Module.hs-boot --- a/GHC/Tc/Module.hs-boot +++ b/GHC/Tc/Module.hs-boot @@ -1,12 +1,7 @@ module GHC.Tc.Module where -import GHC.Prelude +import GHC.Types.SourceFile(HsBootOrSig) import GHC.Types.TyThing(TyThing) -import GHC.Tc.Errors.Types (TcRnMessage) import GHC.Tc.Types (TcM) -import GHC.Types.Name (Name) -checkBootDeclM :: Bool -- ^ True <=> an hs-boot file (could also be a sig) - -> TyThing -> TyThing -> TcM () -missingBootThing :: Bool -> Name -> String -> TcRnMessage -badReexportedBootThing :: Bool -> Name -> Name -> TcRnMessage +checkBootDeclM :: HsBootOrSig -> TyThing -> TyThing -> TcM () 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, @@ -57,6 +57,7 @@ import qualified GHC.Tc.Solver.Monad as TcS import qualified GHC.Tc.Utils.Env as TcM import qualified GHC.Tc.Utils.TcMType as TcM +import qualified GHC.Tc.Zonk.TcType as TcM import qualified GHC.Tc.Instance.Family as TcM import qualified GHC.Iface.Env as IfaceEnv import qualified GHC.Unit.Finder as Finder @@ -65,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 ) @@ -87,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 @@ -96,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 @@ -105,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 @@ -154,12 +165,12 @@ isTouchableTcPluginM :: TcTyVar -> TcPluginM Bool isTouchableTcPluginM = unsafeTcPluginTcM . TcM.isTouchableTcM --- Confused by zonking? See Note [What is zonking?] in GHC.Tc.Utils.TcMType. +-- | Confused by zonking? See Note [What is zonking?] in "GHC.Tc.Zonk.Type". zonkTcType :: TcType -> TcPluginM TcType -zonkTcType = unsafeTcPluginTcM . TcM.zonkTcType +zonkTcType = unsafeTcPluginTcM . TcM.liftZonkM . TcM.zonkTcType zonkCt :: Ct -> TcPluginM Ct -zonkCt = unsafeTcPluginTcM . TcM.zonkCt +zonkCt = unsafeTcPluginTcM . TcM.liftZonkM . TcM.zonkCt -- | Create a new Wanted constraint with the given 'CtLoc'. newWanted :: CtLoc -> PredType -> TcPluginM CtEvidence @@ -173,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. -- diff --git a/GHC/Tc/Solver.hs b/GHC/Tc/Solver.hs --- a/GHC/Tc/Solver.hs +++ b/GHC/Tc/Solver.hs @@ -1,3403 +1,2247 @@ -{-# LANGUAGE RecursiveDo #-} - -module GHC.Tc.Solver( - 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.Driver.Session -import GHC.Tc.Utils.Instantiate -import GHC.Data.List.SetOps -import GHC.Types.Name -import GHC.Types.Id( idType ) -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.Interact -import GHC.Tc.Solver.Canonical ( 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.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 ( liftedRepTy, liftedDataConTy ) -import GHC.Core.Unify ( tcMatchTyKi ) -import GHC.Utils.Misc -import GHC.Utils.Panic -import GHC.Types.Var -import GHC.Types.Var.Set -import GHC.Types.Basic ( IntWithInf, intGtLimit - , DefaultingStrategy(..), NonStandardDefaultingStrategy(..) ) -import GHC.Types.Error -import qualified GHC.LanguageExtensions as LangExt - -import Control.Monad -import Data.Foldable ( toList ) -import Data.List ( partition ) -import Data.List.NonEmpty ( NonEmpty(..) ) -import GHC.Data.Maybe ( mapMaybe, isJust ) - -{- -********************************************************************************* -* * -* 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 (isEmptyCts 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 = 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.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 - | insolubleEqCt 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 - ; try_tyvar_defaulting dflags wc_first_go } - 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 - --- | 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.Interact.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.Interact.doTopReactDict` -- 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 $ solveWanteds wanteds - -- NB: no defaulting! See Note [No defaulting in the ambiguity check] - - ; traceTc "End simplifyAmbiguityCheck }" empty - - -- Normally report all errors; but with -XAllowAmbiguousTypes - -- report only insoluble ones, since they represent genuinely - -- inaccessible code - ; allow_ambiguous <- xoptM LangExt.AllowAmbiguousTypes - ; traceTc "reportUnsolved(ambig) {" empty - ; unless (allow_ambiguous && not (insolubleWC final_wc)) - (discardResult (reportUnsolved final_wc)) - ; traceTc "reportUnsolved(ambig) }" empty - - ; return () } - ------------------- -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) 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.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.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. - --------------------- -ctsPreds :: Cts -> [PredType] -ctsPreds cts = [ ctEvPred ev | ct <- bagToList cts - , let ev = ctEvidence ct ] - -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) 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: decideMonoTyVars. - 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 not quantify over these. - -* Step 2: defaultTyVarsAndSimplify. - Default any non-mono 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 - decideMonoTyVars. 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 [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 general, we don't. -Doing so may simply postpone a type error from the function definition site to -its call site. (At worst, imagine (Int ~ Bool)). - -However, consider this - forall a. (F [a] ~ Int) => blah -Should we quantify over the (F [a] ~ Int). Perhaps yes, because at the call -site we will know 'a', and perhaps we have instance F [Bool] = Int. -So we *do* quantify over a type-family equality where the arguments mention -the quantified variables. - -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 constraint 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. - -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 (Z [Char]) beta -We definitely do 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]. - -The question here: do we want to quantify over the constraint? Definitely not. -Since we're not quantifying over beta, GHC has no choice but to zap beta -to Any, and then we infer a type involving (Zork a (Z [Char]) Any => ...). No no no. - -The no_fixed_dependencies check in pickQuantifiablePreds eliminates this -candidate from the pool. Because there are no Zork instances in scope, this -program is rejected. - --} - -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 - ; (mono_tvs, candidates, co_vars) <- decideMonoTyVars 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 mono_tvs 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 <- TcM.zonkTcTypes candidates - ; psig_theta <- TcM.zonkTcTypes (concatMap sig_inst_theta psigs) - ; let min_theta = mkMinimalBySCs id $ -- See Note [Minimize by Superclasses] - pickQuantifiablePreds (mkVarSet qtvs) candidates - - min_psig_theta = mkMinimalBySCs id psig_theta - - -- Add psig_theta back in here, even though it's already - -- part of candidates, because we always want to quantify over - -- psig_theta, and pickQuantifiableCandidates might have - -- dropped some e.g. CallStack constraints. c.f #14658 - -- equalities (a ~ Bool) - -- It's helpful to use the same "find difference" algorithm here as - -- we use in GHC.Tc.Gen.Bind.chooseInferredQuantifiers (#20921) - -- See Note [Constraints in partial type signatures] - ; theta <- if null psig_theta - then return min_theta -- Fast path for the non-partial-sig case - else 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 "mono_tvs:" <+> ppr mono_tvs - , text "co_vars:" <+> ppr co_vars - , text "qtvs:" <+> ppr qtvs - , text "theta:" <+> ppr theta ]) - ; return (qtvs, theta, co_vars) } - -{- Note [Constraints in partial type signatures] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose we have a partial type signature - f :: (Eq a, C a, _) => blah - -We will ultimately quantify f over (Eq a, C a, ), where - - * is the result of - findInferredDiff (Eq a, C a) - in GHC.Tc.Gen.Bind.chooseInferredQuantifiers - - * is the theta returned right here, - by decideQuantification - -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. --} - -decideMonoTyVars :: InferMode - -> [(Name,TcType)] - -> [TcIdSigInst] - -> [PredType] - -> TcM (TcTyCoVarSet, [PredType], CoVarSet) --- Decide which tyvars and covars cannot be generalised: --- (a) Free in the environment --- (b) Mentioned in a constraint we can't generalise --- (c) Connected by an equality or fundep to (a) or (b) --- 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 -decideMonoTyVars infer_mode name_taus psigs candidates - = do { (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 <- 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 - - ; tc_lvl <- TcM.getTcLevel - ; let psig_tys = mkTyVarTys psig_qtvs ++ psig_theta - - co_vars = coVarsOfTypes (psig_tys ++ taus ++ candidates) - co_var_tvs = closeOverKinds co_vars - -- 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 - - 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. But 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 - - ; traceTc "decideMonoTyVars" $ vcat - [ text "infer_mode =" <+> ppr infer_mode - , 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 (mono_tvs, maybe_quant, co_vars) } - where - pick :: InferMode -> [PredType] -> TcM ([PredType], [PredType]) - -- Split the candidates into ones we definitely - -- won't quantify, and ones that we might - pick NoRestrictions cand = return ([], cand) - pick ApplyMR cand = return (cand, []) - pick EagerDefaulting cand = do { os <- xoptM LangExt.OverloadedStrings - ; return (partition (is_int_ct os) cand) } - - -- For EagerDefaulting, do not quantify over - -- over any interactive class constraint - is_int_ct ovl_strings pred - | Just (cls, _) <- getClassPredTys_maybe pred - = isInteractiveClass ovl_strings cls - | otherwise - = False - -------------------- -defaultTyVarsAndSimplify :: TcLevel - -> TyCoVarSet -- Promote these mono-tyvars - -> [PredType] -- Assumed zonked - -> TcM [PredType] -- Guaranteed zonked --- Promote the known-monomorphic tyvars; --- Default any tyvar free in the constraints; --- and re-simplify in case the defaulting allows further simplification -defaultTyVarsAndSimplify rhs_tclvl mono_tvs candidates - = do { -- Promote any tyvars that we cannot generalise - -- See Note [Promote monomorphic tyvars] - ; traceTc "decideMonoTyVars: promotion:" (ppr mono_tvs) - ; _ <- promoteTyVarSet mono_tvs - - -- Default any kind/levity vars - ; DV {dv_kvs = cand_kvs, dv_tvs = cand_tvs} - <- candidateQTyVarsOfTypes candidates - -- any covars should already be handled by - -- the logic in decideMonoTyVars, which looks at - -- the constraints generated - - ; poly_kinds <- xoptM LangExt.PolyKinds - ; mapM_ (default_one poly_kinds True) (dVarSetElems cand_kvs) - ; mapM_ (default_one poly_kinds False) (dVarSetElems (cand_tvs `minusDVarSet` cand_kvs)) - - ; simplify_cand candidates - } - where - default_one poly_kinds is_kind_var tv - | not (isMetaTyVar tv) - = return () - | tv `elemVarSet` mono_tvs - = return () - | otherwise - = void $ defaultTyVar - (if not poly_kinds && is_kind_var - then DefaultKindVars - else NonStandardDefaulting DefaultNonStandardTyVars) - -- NB: only pass 'DefaultKindVars' when we know we're dealing with a kind variable. - tv - - -- this common case (no inferred constraints) should be fast - simplify_cand [] = return [] - -- see Note [Unconditionally resimplify constraints when quantifying] - 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 <- 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 - - ; 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? --- Generally true of classes; generally false of equality constraints. --- Equality constraints that mention quantified type variables and --- implicit variables complicate the story. See Notes --- [Inheriting implicit parameters] and [Quantifying over equality constraints] -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 - = let flex_ctxt = True in -- Quantify over non-tyvar constraints, even without - -- -XFlexibleContexts: see #10608, #10351 - -- flex_ctxt <- xoptM Opt_FlexibleContexts - mapMaybe (pick_me flex_ctxt) theta - where - pick_me flex_ctxt pred - = 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] - - | pick_cls_pred flex_ctxt cls tys - -> Just pred - - EqPred eq_rel ty1 ty2 - | quantify_equality eq_rel ty1 ty2 - , Just (cls, tys) <- boxEqPred eq_rel ty1 ty2 - -- boxEqPred: See Note [Lift equality constraints when quantifying] - , pick_cls_pred flex_ctxt cls tys - -> Just (mkClassPred cls tys) - - IrredPred ty - | tyCoVarsOfType ty `intersectsVarSet` qtvs - -> Just pred - - _ -> Nothing - - - pick_cls_pred flex_ctxt cls tys - = tyCoVarsOfTypes tys `intersectsVarSet` qtvs - && (checkValidClsArgs flex_ctxt cls tys) - -- Only quantify over predicates that checkValidType - -- will pass! See #10351. - && (no_fixed_dependencies cls tys) - - -- See Note [Do not quantify over constraints that determine a variable] - no_fixed_dependencies cls tys - = and [ qtvs `intersectsVarSet` tyCoVarsOfTypes fd_lhs_tys - | fd <- cls_fds - , let (fd_lhs_tys, _) = instFD fd cls_tvs tys ] - where - (cls_tvs, cls_fds) = classTvsFds cls - - -- 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 [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.decideMonoTyVars. 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 decideMonoTyVars. 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.zonkWC result - ; 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 "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 - ; 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. --} - -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 <- getTcSInerts - ; 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 = isJust . userTypeError_maybe . idType - - 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_is_given = is_given }) - | is_given = ev_var `elemVarSet` needed - | otherwise = True -- Keep all wanted bindings - - add_wanted :: EvBind -> VarSet -> VarSet - add_wanted (EvBind { eb_is_given = is_given, eb_rhs = rhs }) needs - | is_given = needs -- Add the rhs vars of the Wanted bindings only - | otherwise = evVarsOfTerm rhs `unionVarSet` needs - -------------------------------------------------- -simplifyDelayedErrors :: Bag DelayedError -> TcS (Bag DelayedError) -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 - ; 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.Interact. - - 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. - - - 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 - -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. - --} - --- | 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 -> WantedConstraints -> Cts --- Second return value is the depleted wc --- Third return value is YesFDsCombined <=> multiple constraints for the same fundep floated --- Postcondition: Wanted Cts --- See Note [ApproximateWC] --- See Note [floatKindEqualities vs approximateWC] -approximateWC float_past_equalities wc - = float_wc emptyVarSet wc - where - float_wc :: TcTyCoVarSet -> WantedConstraints -> Cts - float_wc trapping_tvs (WC { wc_simple = simples, wc_impl = implics }) - = filterBag (is_floatable trapping_tvs) simples `unionBags` - concatMapBag (float_implic trapping_tvs) implics - float_implic :: TcTyCoVarSet -> Implication -> Cts - float_implic trapping_tvs imp - | float_past_equalities || ic_given_eqs imp /= MaybeGivenEqs - = float_wc new_trapping_tvs (ic_wanted imp) - | otherwise -- Take care with equalities - = emptyCts -- See (1) under Note [ApproximateWC] - where - new_trapping_tvs = trapping_tvs `extendVarSetList` ic_skols imp - - is_floatable skol_tvs ct - | isGivenCt ct = False - | insolubleEqCt ct = False - | otherwise = tyCoVarsOfCt ct `disjointVarSet` skol_tvs - -{- 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. - -There is one caveat: - -1. When inferring most-general types (in simplifyInfer), we do *not* - float anything out 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.) - - HOWEVER (#12797) in findDefaultableGroups we are not worried about - the most-general type; and we /do/ want to float out of equalities. - 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) 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). +{-# LANGUAGE MultiWayIf, RecursiveDo, TupleSections #-} + +module GHC.Tc.Solver( + InferMode(..), simplifyInfer, findInferredDiff, + growThetaTyVars, + simplifyAmbiguityCheck, + 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/Canonical.hs b/GHC/Tc/Solver/Canonical.hs deleted file mode 100644 --- a/GHC/Tc/Solver/Canonical.hs +++ /dev/null @@ -1,3421 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE MultiWayIf #-} -{-# LANGUAGE RecursiveDo #-} - -module GHC.Tc.Solver.Canonical( - canonicalize, - unifyWanted, - makeSuperClasses, - StopOrContinue(..), stopWith, continueWith, andWhenContinue, - rewriteEqEvidence, - solveCallStack -- For GHC.Tc.Solver - ) where - -import GHC.Prelude - -import GHC.Tc.Types.Constraint -import GHC.Core.Predicate -import GHC.Tc.Types.Origin -import GHC.Tc.Utils.Unify -import GHC.Tc.Utils.TcType -import GHC.Core.Type -import GHC.Tc.Solver.Rewrite -import GHC.Tc.Solver.Monad -import GHC.Tc.Solver.InertSet -import GHC.Tc.Types.Evidence -import GHC.Tc.Types.EvTerm -import GHC.Core.Class -import GHC.Core.DataCon ( dataConName ) -import GHC.Core.TyCon -import GHC.Core.Multiplicity -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 -import GHC.Types.Id( mkTemplateLocals ) -import GHC.Core.FamInstEnv ( FamInstEnvs ) -import GHC.Tc.Instance.Family ( tcTopNormaliseNewTypeTF_maybe ) -import GHC.Types.Var -import GHC.Types.Var.Env( mkInScopeSet ) -import GHC.Types.Var.Set( delVarSetList, anyVarSet ) -import GHC.Utils.Outputable -import GHC.Utils.Panic -import GHC.Utils.Panic.Plain -import GHC.Builtin.Types ( anyTypeOfKind ) -import GHC.Types.Name.Set -import GHC.Types.Name.Reader -import GHC.Hs.Type( HsIPName(..) ) -import GHC.Types.Unique ( hasKey ) -import GHC.Builtin.Names ( coercibleTyConKey ) - -import GHC.Data.Pair -import GHC.Utils.Misc -import GHC.Data.Bag -import GHC.Utils.Monad -import GHC.Utils.Constants( debugIsOn ) -import Control.Monad -import Data.Maybe ( isJust, isNothing ) -import Data.List ( zip4 ) -import GHC.Types.Basic - -import qualified Data.Semigroup as S -import Data.Bifunctor ( bimap ) - -{- -************************************************************************ -* * -* The Canonicaliser * -* * -************************************************************************ - -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. - --} - --- Top-level canonicalization --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -canonicalize :: Ct -> TcS (StopOrContinue Ct) -canonicalize (CNonCanonical { cc_ev = ev }) - = {-# SCC "canNC" #-} - canNC ev - -canonicalize (CQuantCan (QCI { qci_ev = ev, qci_pend_sc = pend_sc })) - = canForAll ev pend_sc - -canonicalize (CIrredCan { cc_ev = ev }) - = canNC 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 - -canonicalize (CDictCan { cc_ev = ev, cc_class = cls - , cc_tyargs = xis, cc_pend_sc = pend_sc }) - = {-# SCC "canClass" #-} - canClass ev cls xis pend_sc - -canonicalize (CEqCan { cc_ev = ev - , cc_lhs = lhs - , cc_rhs = rhs - , cc_eq_rel = eq_rel }) - = {-# SCC "canEqLeafTyVarEq" #-} - canEqNC ev eq_rel (canEqLHSType lhs) rhs - -canNC :: CtEvidence -> TcS (StopOrContinue Ct) -canNC ev = - case classifyPredType pred of - ClassPred cls tys -> do traceTcS "canEvNC:cls" (ppr cls <+> ppr tys) - canClassNC ev cls tys - EqPred eq_rel ty1 ty2 -> do traceTcS "canEvNC:eq" (ppr ty1 $$ ppr ty2) - canEqNC ev eq_rel ty1 ty2 - IrredPred {} -> do traceTcS "canEvNC:irred" (ppr pred) - canIrred ev - ForAllPred tvs th p -> do traceTcS "canEvNC:forall" (ppr pred) - canForAllNC ev tvs th p - - where - pred = ctEvPred ev - -{- -************************************************************************ -* * -* Class Canonicalization -* * -************************************************************************ --} - -canClassNC :: CtEvidence -> Class -> [Type] -> TcS (StopOrContinue Ct) --- "NC" means "non-canonical"; that is, we have got here --- from a NonCanonical constraint, not from a CDictCan --- Precondition: EvVar is class evidence -canClassNC ev cls tys - | isGiven ev -- See Note [Eagerly expand given superclasses] - = do { sc_cts <- mkStrictSuperClasses ev [] [] cls tys - ; emitWork sc_cts - ; canClass ev cls tys False } - - | CtWanted { ctev_rewriters = rewriters } <- ev - , Just ip_name <- isCallStackPred cls tys - , isPushCallStackOrigin 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 - = 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 - - -- 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) - ; solveCallStack ev ev_cs - - ; canClass new_ev cls tys False -- No superclasses - } - - | otherwise - = canClass ev cls tys (has_scs cls) - - where - has_scs cls = not (null (classSCTheta cls)) - loc = ctEvLoc ev - orig = ctLocOrigin loc - pred = ctEvPred ev - -solveCallStack :: CtEvidence -> EvCallStack -> TcS () --- Also called from GHC.Tc.Solver when defaulting call stacks -solveCallStack ev ev_cs = do - -- 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] - cs_tm <- evCallStack ev_cs - let ev_tm = mkEvCast cs_tm (wrapIP (ctEvPred ev)) - setEvBindIfWanted ev ev_tm - -canClass :: CtEvidence - -> Class -> [Type] - -> Bool -- True <=> un-explored superclasses - -> TcS (StopOrContinue Ct) --- Precondition: EvVar is class evidence - -canClass ev cls tys pend_sc - = -- all classes do *nominal* matching - assertPpr (ctEvRole ev == Nominal) (ppr ev $$ ppr cls $$ ppr tys) $ - do { (redns@(Reductions _ xis), rewriters) <- rewriteArgsNom ev cls_tc tys - ; let redn@(Reduction _ xi) = mkClassPredRedn cls redns - mk_ct new_ev = CDictCan { cc_ev = new_ev - , cc_tyargs = xis - , cc_class = cls - , cc_pend_sc = pend_sc } - ; mb <- rewriteEvidence rewriters ev redn - ; traceTcS "canClass" (vcat [ ppr ev - , ppr xi, ppr mb ]) - ; return (fmap mk_ct mb) } - where - cls_tc = classTyCon cls - -{- Note [The superclass story] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We need to add superclass constraints for two reasons: - -* For givens [G], they give us a route to proof. E.g. - f :: Ord a => a -> Bool - f x = x == x - We get a Wanted (Eq a), which can only be solved from the superclass - of the Given (Ord a). - -* For wanteds [W], they may give useful - functional dependencies. E.g. - class C a b | a -> b where ... - class C a b => D a b where ... - Now a [W] constraint (D Int beta) has (C Int beta) as a superclass - and that might tell us about beta, via C's fundeps. We can get this - by generating a [W] (C Int beta) constraint. We won't use the evidence, - but it may lead to unification. - -See Note [Why adding superclasses can help]. - -For these reasons we want to generate superclass constraints for both -Givens and Wanteds. But: - -* (Minor) they are often not needed, so generating them aggressively - is a waste of time. - -* (Major) if we want recursive superclasses, there would be an infinite - number of them. Here is a real-life example (#10318); - - class (Frac (Frac a) ~ Frac a, - Fractional (Frac a), - IntegralDomain (Frac a)) - => IntegralDomain a where - type Frac a :: * - - Notice that IntegralDomain has an associated type Frac, and one - of IntegralDomain's superclasses is another IntegralDomain constraint. - -So here's the plan: - -1. Eagerly generate superclasses for given (but not wanted) - constraints; see Note [Eagerly expand given superclasses]. - This is done using mkStrictSuperClasses in canClassNC, when - we take a non-canonical Given constraint and cannonicalise it. - - However stop if you encounter the same class twice. That is, - mkStrictSuperClasses expands eagerly, but has a conservative - termination condition: see Note [Expanding superclasses] in GHC.Tc.Utils.TcType. - -2. Solve the wanteds as usual, but do no further expansion of - superclasses for canonical CDictCans in solveSimpleGivens or - 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 - 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]. - -3. If we have any remaining unsolved wanteds - (see Note [When superclasses help] in GHC.Tc.Types.Constraint) - try harder: take both the Givens and Wanteds, and expand - superclasses again. See the calls to expandSuperClasses in - GHC.Tc.Solver.simpl_loop and solveWanteds. - - This may succeed in generating (a finite number of) extra Givens, - and extra Wanteds. Both may help the proof. - -3a An important wrinkle: only expand Givens from the current level. - Two reasons: - - We only want to expand it once, and that is best done at - the level it is bound, rather than repeatedly at the leaves - of the implication tree - - We may be inside a type where we can't create term-level - evidence anyway, so we can't superclass-expand, say, - (a ~ b) to get (a ~# b). This happened in #15290. - -4. Go round to (2) again. This loop (2,3,4) is implemented - in GHC.Tc.Solver.simpl_loop. - -The cc_pend_sc flag in a CDictCan records whether the superclasses of -this constraint have been expanded. Specifically, in Step 3 we only -expand superclasses for constraints with cc_pend_sc set to true (i.e. -isPendingScDict holds). - -Why do we do this? Two reasons: - -* To avoid repeated work, by repeatedly expanding the superclasses of - same constraint, - -* To terminate the above loop, at least in the -XNoUndecidableSuperClasses - case. If there are recursive superclasses we could, in principle, - expand forever, always encountering new constraints. - -When we take a CNonCanonical or CIrredCan, but end up classifying it -as a CDictCan, we set the cc_pend_sc flag to False. - -Note [Superclass loops] -~~~~~~~~~~~~~~~~~~~~~~~ -Suppose we have - class C a => D a - class D a => C a - -Then, when we expand superclasses, we'll get back to the self-same -predicate, so we have reached a fixpoint in expansion and there is no -point in fruitlessly expanding further. This case just falls out from -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 -G] d2: D a, [G] d3: C a (psc). (The "psc" means it has its sc_pend flag set.) -When processing d3 we find a match with d1 in the inert set, and we always -keep the inert item (d1) if possible: see Note [Replacement vs keeping] in -GHC.Tc.Solver.Interact. So d3 dies a quick, happy death. - -Note [Eagerly expand given superclasses] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In step (1) of Note [The superclass story], why do we eagerly expand -Given superclasses by one layer? (By "one layer" we mean expand transitively -until you meet the same class again -- the conservative criterion embodied -in expandSuperClasses. So a "layer" might be a whole stack of superclasses.) -We do this eagerly for Givens mainly because of some very obscure -cases like this: - - instance Bad a => Eq (T a) - - f :: (Ord (T a)) => blah - f x = ....needs Eq (T a), Ord (T a).... - -Here if we can't satisfy (Eq (T a)) from the givens we'll use the -instance declaration; but then we are stuck with (Bad a). Sigh. -This is really a case of non-confluent proofs, but to stop our users -complaining we expand one layer in advance. - -Note [Instance and Given overlap] in GHC.Tc.Solver.Interact. - -We also want to do this if we have - - f :: F (T a) => blah - -where - type instance F (T a) = Ord (T a) - -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. - -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. - -Note [Why adding superclasses can help] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Examples of how adding superclasses can help: - - --- Example 1 - class C a b | a -> b - Suppose we want to solve - [G] C a b - [W] C a beta - Then adding [W] beta~b will let us solve it. - - -- Example 2 (similar but using a type-equality superclass) - class (F a ~ b) => C a b - And try to sllve: - [G] C a b - [W] C a beta - Follow the superclass rules to add - [G] F a ~ b - [W] F a ~ beta - Now we get [W] beta ~ b, and can solve that. - - -- Example (tcfail138) - class L a b | a -> b - class (G a, L a b) => C a b - - instance C a b' => G (Maybe a) - instance C a b => C (Maybe a) a - instance L (Maybe a) a - - When solving the superclasses of the (C (Maybe a) a) instance, we get - [G] C a b, and hence by superclasses, [G] G a, [G] L a b - [W] G (Maybe a) - Use the instance decl to get - [W] C a beta - Generate its superclass - [W] L a beta. Now using fundeps, combine with [G] L a b to get - [W] beta ~ b - which is what we want. - -Note [Danger of adding superclasses during solving] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Here's a serious, but now out-dated example, from #4497: - - class Num (RealOf t) => Normed t - type family RealOf x - -Assume the generated wanted constraint is: - [W] RealOf e ~ e - [W] Normed e - -If we were to be adding the superclasses during simplification we'd get: - [W] RealOf e ~ e - [W] Normed e - [W] RealOf e ~ fuv - [W] Num fuv -==> - e := fuv, Num fuv, Normed fuv, RealOf fuv ~ fuv - -While looks exactly like our original constraint. If we add the -superclass of (Normed fuv) again we'd loop. By adding superclasses -definitely only once, during canonicalisation, this situation can't -happen. - -Note [Nested quantified constraint superclasses] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider (typecheck/should_compile/T17202) - - class C1 a - class (forall c. C1 c) => C2 a - class (forall b. (b ~ F a) => C2 a) => C3 a - -Elsewhere in the code, we get a [G] g1 :: C3 a. We expand its superclass -to get [G] g2 :: (forall b. (b ~ F a) => C2 a). This constraint has a -superclass, as well. But we now must be careful: we cannot just add -(forall c. C1 c) as a Given, because we need to remember g2's context. -That new constraint is Given only when forall b. (b ~ F a) is true. - -It's tempting to make the new Given be (forall b. (b ~ F a) => forall c. C1 c), -but that's problematic, because it's nested, and ForAllPred is not capable -of representing a nested quantified constraint. (We could change ForAllPred -to allow this, but the solution in this Note is much more local and simpler.) - -So, we swizzle it around to get (forall b c. (b ~ F a) => C1 c). - -More generally, if we are expanding the superclasses of - g0 :: forall tvs. theta => cls tys -and find a superclass 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 -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. - sel_id tys (g0 tvs theta_ids) sc_tvs sc_theta_ids - -Actually, we cheat a bit by eta-reducing: note that sc_theta_ids are both the -last bound variables and the last arguments. This avoids the need to produce -the sc_theta_ids at all. So our final construction is - - g_sc = /\ tvs. /\ sc_tvs. \ theta_ids. - sel_id tys (g0 tvs theta_ids) sc_tvs - - -} - -makeSuperClasses :: [Ct] -> TcS [Ct] --- Returns strict superclasses, transitively, see Note [The superclass story] --- See Note [The superclass story] --- The loop-breaking here follows Note [Expanding superclasses] in GHC.Tc.Utils.TcType --- Specifically, for an incoming (C t) constraint, we return all of (C t)'s --- superclasses, up to /and including/ the first repetition of C --- --- Example: class D a => C a --- class C [a] => D a --- makeSuperClasses (C x) will return (D x, C [x]) --- --- NB: the incoming constraints have had their cc_pend_sc flag already --- flipped to False, by isPendingScDict, so we are /obliged/ to at --- least produce the immediate superclasses -makeSuperClasses cts = concatMapM go cts - where - go (CDictCan { cc_ev = ev, cc_class = cls, cc_tyargs = tys }) - = mkStrictSuperClasses ev [] [] cls tys - go (CQuantCan (QCI { qci_pred = pred, qci_ev = ev })) - = assertPpr (isClassPred pred) (ppr pred) $ -- The cts should all have - -- class pred heads - mkStrictSuperClasses ev tvs theta cls tys - where - (tvs, theta, cls, tys) = tcSplitDFunTy (ctEvPred ev) - go ct = pprPanic "makeSuperClasses" (ppr ct) - -mkStrictSuperClasses - :: CtEvidence - -> [TyVar] -> ThetaType -- These two args are non-empty only when taking - -- superclasses of a /quantified/ constraint - -> Class -> [Type] -> TcS [Ct] --- Return constraints for the strict superclasses of --- ev :: forall as. theta => cls tys -mkStrictSuperClasses ev tvs theta cls tys - = mk_strict_superclasses (unitNameSet (className cls)) - ev tvs theta cls tys - -mk_strict_superclasses :: NameSet -> CtEvidence - -> [TyVar] -> ThetaType - -> Class -> [Type] -> TcS [Ct] --- Always return the immediate superclasses of (cls tys); --- and expand their superclasses, provided none of them are in rec_clss --- nor are repeated -mk_strict_superclasses rec_clss (CtGiven { ctev_evar = evar, ctev_loc = loc }) - tvs theta cls tys - = concatMapM do_one_given $ - classSCSelIds cls - where - dict_ids = mkTemplateLocals theta - this_size = pSizeClassPred cls tys - - do_one_given sel_id - | isUnliftedType sc_pred - -- NB: class superclasses are never representation-polymorphic, - -- so isUnliftedType is OK here. - , not (null tvs && null theta) - = -- See Note [Equality superclasses in quantified constraints] - return [] - | otherwise - = do { given_ev <- newGivenEvVar sc_loc $ - mk_given_desc sel_id sc_pred - ; mk_superclasses rec_clss 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) - where - (sc_tvs, sc_rho) = splitForAllTyCoVars sc_pred - (sc_theta, sc_inner_pred) = splitFunTys sc_rho - - all_tvs = tvs `chkAppend` sc_tvs - all_theta = theta `chkAppend` (map scaledThing sc_theta) - swizzled_pred = mkInfSigmaTy all_tvs all_theta sc_inner_pred - - -- evar :: forall tvs. theta => cls tys - -- sel_id :: forall cls_tvs. cls cls_tvs - -- -> 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 - - sc_loc | isCTupleClass cls - = loc -- For tuple predicates, just take them apart, without - -- adding their (large) size into the chain. When we - -- get down to a base predicate, we'll include its size. - -- #10335 - - | isEqPredClass cls || cls `hasKey` coercibleTyConKey - = loc -- The only superclasses of ~, ~~, and Coercible are primitive - -- equalities, and they don't use the GivenSCOrigin mechanism - -- detailed in Note [Solving superclass constraints] in - -- GHC.Tc.TyCl.Instance. Skip for a tiny performance win. - - | otherwise - = loc { ctl_origin = mk_sc_origin (ctLocOrigin loc) } - - -- See Note [Solving superclass constraints] in GHC.Tc.TyCl.Instance - -- for explanation of GivenSCOrigin and Note [Replacement vs keeping] in - -- GHC.Tc.Solver.Interact for why we need depths - mk_sc_origin :: CtOrigin -> CtOrigin - mk_sc_origin (GivenSCOrigin skol_info sc_depth already_blocked) - = GivenSCOrigin skol_info (sc_depth + 1) - (already_blocked || newly_blocked skol_info) - - mk_sc_origin (GivenOrigin skol_info) - = -- These cases do not already have a superclass constraint: depth starts at 1 - GivenSCOrigin skol_info 1 (newly_blocked skol_info) - - mk_sc_origin other_orig = pprPanic "Given constraint without given origin" $ - ppr evar $$ ppr other_orig - - newly_blocked (InstSkol _ head_size) = isJust (this_size `ltPatersonSize` head_size) - newly_blocked _ = False - -mk_strict_superclasses rec_clss ev tvs theta cls tys - | all noFreeVarsOfType tys - = return [] -- Wanteds with no variables yield no superclass constraints. - -- See Note [Improvement from Ground Wanteds] - - | otherwise -- Wanted case, just add Wanted superclasses - -- that can lead to improvement. - = assertPpr (null tvs && null theta) (ppr tvs $$ ppr theta) $ - concatMapM do_one (immSuperClasses cls tys) - where - loc = ctEvLoc ev `updateCtLocOrigin` WantedSuperclassOrigin (ctEvPred ev) - - 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 rec_clss sc_ev [] [] sc_pred } - -{- Note [Improvement from Ground Wanteds] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose class C b a => D a b -and consider - [W] D Int Bool -Is there any point in emitting [W] C Bool Int? No! The only point of -emitting superclass constraints for W constraints is to get -improvement, extra unifications that result from functional -dependencies. See Note [Why adding superclasses can help] above. - -But no variables means no improvement; case closed. --} - -mk_superclasses :: NameSet -> CtEvidence - -> [TyVar] -> ThetaType -> PredType -> TcS [Ct] --- Return this constraint, plus its superclasses, if any -mk_superclasses rec_clss ev tvs theta pred - | ClassPred cls tys <- classifyPredType pred - = mk_superclasses_of rec_clss ev tvs theta cls tys - - | otherwise -- Superclass is not a class predicate - = return [mkNonCanonical ev] - -mk_superclasses_of :: NameSet -> CtEvidence - -> [TyVar] -> ThetaType -> Class -> [Type] - -> TcS [Ct] --- Always return this class constraint, --- and expand its superclasses -mk_superclasses_of rec_clss ev tvs theta cls tys - | loop_found = do { traceTcS "mk_superclasses_of: loop" (ppr cls <+> ppr tys) - ; return [this_ct] } -- cc_pend_sc of this_ct = True - | otherwise = do { traceTcS "mk_superclasses_of" (vcat [ ppr cls <+> ppr tys - , ppr (isCTupleClass cls) - , ppr rec_clss - ]) - ; sc_cts <- mk_strict_superclasses rec_clss' ev tvs theta cls tys - ; return (this_ct : sc_cts) } - -- cc_pend_sc of this_ct = False - where - cls_nm = className cls - loop_found = not (isCTupleClass cls) && cls_nm `elemNameSet` rec_clss - -- Tuples never contribute to recursion, and can be nested - rec_clss' = rec_clss `extendNameSet` cls_nm - - this_ct | null tvs, null theta - = CDictCan { cc_ev = ev, cc_class = cls, cc_tyargs = tys - , cc_pend_sc = loop_found } - -- NB: If there is a loop, we cut off, so we have not - -- added the superclasses, hence cc_pend_sc = True - | otherwise - = CQuantCan (QCI { qci_tvs = tvs, qci_pred = mkClassPred cls tys - , qci_ev = ev - , qci_pend_sc = loop_found }) - - -{- Note [Equality superclasses in quantified constraints] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider (#15359, #15593, #15625) - f :: (forall a. theta => a ~ b) => stuff - -It's a bit odd to have a local, quantified constraint for `(a~b)`, -but some people want such a thing (see the tickets). And for -Coercible it is definitely useful - f :: forall m. (forall p q. Coercible p q => Coercible (m p) (m q))) - => stuff - -Moreover it's not hard to arrange; we just need to look up /equality/ -constraints in the quantified-constraint environment, which we do in -GHC.Tc.Solver.Interact.doTopReactOther. - -There is a wrinkle though, in the case where 'theta' is empty, so -we have - f :: (forall a. a~b) => stuff - -Now, potentially, the superclass machinery kicks in, in -makeSuperClasses, giving us a a second quantified constraint - (forall a. a ~# b) -BUT this is an unboxed value! And nothing has prepared us for -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. - -So for now we simply decline to take superclasses in the quantified -case. Instead we have a special case in GHC.Tc.Solver.Interact.doTopReactOther, -which looks for primitive equalities specially in the quantified -constraints. - -See also Note [Evidence for quantified constraints] in GHC.Core.Predicate. - - -************************************************************************ -* * -* Irreducibles canonicalization -* * -************************************************************************ --} - -canIrred :: CtEvidence -> TcS (StopOrContinue Ct) --- Precondition: ty not a tuple and no other evidence form -canIrred ev - = do { let pred = ctEvPred ev - ; traceTcS "can_pred" (text "IrredPred = " <+> ppr pred) - ; (redn, rewriters) <- rewrite ev pred - ; rewriteEvidence rewriters ev redn `andWhenContinue` \ new_ev -> - - do { -- Re-classify, in case rewriting has improved its shape - -- Code is like the canNC, except - -- that the IrredPred branch stops work - ; case classifyPredType (ctEvPred new_ev) of - ClassPred cls tys -> canClassNC new_ev cls tys - EqPred eq_rel ty1 ty2 -> -- IrredPreds have kind Constraint, so - -- cannot become EqPreds - pprPanic "canIrred: EqPred" - (ppr ev $$ ppr eq_rel $$ ppr ty1 $$ ppr ty2) - ForAllPred tvs th p -> -- this is highly suspect; Quick Look - -- should never leave a meta-var filled - -- in with a polytype. This is #18987. - do traceTcS "canEvNC:forall" (ppr pred) - canForAllNC ev tvs th p - IrredPred {} -> continueWith $ - mkIrredCt IrredShapeReason new_ev } } - -{- ********************************************************************* -* * -* Quantified predicates -* * -********************************************************************* -} - -{- 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.Interact.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.) - - * GHC.Tc.Solver.Canonical.canForAll 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. - --} - -canForAllNC :: CtEvidence -> [TyVar] -> TcThetaType -> TcPredType - -> TcS (StopOrContinue Ct) -canForAllNC ev tvs theta pred - | isGiven ev -- See Note [Eagerly expand given superclasses] - , Just (cls, tys) <- cls_pred_tys_maybe - = do { sc_cts <- mkStrictSuperClasses ev tvs theta cls tys - ; emitWork sc_cts - ; canForAll ev False } - - | otherwise - = canForAll ev (isJust cls_pred_tys_maybe) - - where - cls_pred_tys_maybe = getClassPredTys_maybe pred - -canForAll :: CtEvidence -> Bool -> TcS (StopOrContinue Ct) --- We have a constraint (forall as. blah => C tys) -canForAll ev pend_sc - = do { -- First rewrite it to apply the current substitution - let pred = ctEvPred ev - ; (redn, rewriters) <- rewrite ev pred - ; rewriteEvidence rewriters ev redn `andWhenContinue` \ new_ev -> - - do { -- Now decompose into its pieces and solve it - -- (It takes a lot less code to rewrite before decomposing.) - ; case classifyPredType (ctEvPred new_ev) of - ForAllPred tvs theta pred - -> solveForAll new_ev tvs theta pred pend_sc - _ -> pprPanic "canForAll" (ppr new_ev) - } } - -solveForAll :: CtEvidence -> [TyVar] -> TcThetaType -> PredType -> Bool - -> TcS (StopOrContinue Ct) -solveForAll ev@(CtWanted { ctev_dest = dest, ctev_rewriters = rewriters, ctev_loc = loc }) - tvs theta pred _pend_sc - = -- See Note [Solving a Wanted forall-constraint] - setLclEnv (ctLocEnv loc) $ - -- This setLclEnv 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 (getSkolemInfo skol_info) skol_tvs - given_ev_vars wanteds - - ; setWantedEvTerm dest $ - 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 pend_sc - = do { addInertForAll qci - ; stopWith ev "Given forall-constraint" } - where - qci = QCI { qci_ev = ev, qci_tvs = tvs - , qci_pred = pred, qci_pend_sc = pend_sc } - -{- 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. - -************************************************************************ -* * -* 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! --} - -canEqNC :: CtEvidence -> EqRel -> Type -> Type -> TcS (StopOrContinue Ct) -canEqNC ev eq_rel ty1 ty2 - = do { result <- zonk_eq_types ty1 ty2 - ; case result of - Right ty -> canEqReflexive ev eq_rel ty - Left (Pair ty1' ty2') -> can_eq_nc False ev' eq_rel ty1' ty1' ty2' ty2' - where - ev' | debugIsOn = setCtEvPredType ev $ - mkPrimEqPredRole (eqRelRole eq_rel) ty1' ty2' - | otherwise = ev - -- ev': satisfy the precondition of can_eq_nc - } - -can_eq_nc - :: Bool -- True => both types are rewritten - -> CtEvidence - -> EqRel - -> Type -> Type -- LHS, after and before type-synonym expansion, resp - -> Type -> Type -- RHS, after and before type-synonym expansion, resp - -> TcS (StopOrContinue Ct) --- 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 - -can_eq_nc rewritten ev eq_rel ty1 ps_ty1 ty2 ps_ty2 - = do { traceTcS "can_eq_nc" $ - vcat [ ppr rewritten, ppr ev, ppr eq_rel, ppr ty1, ppr ps_ty1, ppr ty2, ppr ps_ty2 ] - ; rdr_env <- getGlobalRdrEnvTcS - ; fam_insts <- getFamInstEnvs - ; can_eq_nc' rewritten rdr_env fam_insts ev eq_rel ty1 ps_ty1 ty2 ps_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 Ct) - --- 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 ev NotSwapped ty1 stuff1 ty2 ps_ty2 - - | ReprEq <- eq_rel - , Just stuff2 <- tcTopNormaliseNewTypeTF_maybe envs rdr_env ty2 - = can_eq_newtype_nc 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 (3) in Note [Equalities with incompatible kinds] - = canEqCast rewritten 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 (3) in Note [Equalities with incompatible kinds] - = canEqCast rewritten 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 (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 - -- we want to catch e.g. Maybe Int ~ (Int -> Int) here for better - -- error messages rather than decomposing into AppTys; - -- hence no direct match on TyConApp - , not (isTypeFamilyTyCon tc1) - , not (isTypeFamilyTyCon tc2) - = canTyConApp ev eq_rel tc1 tys1 tc2 tys2 - -can_eq_nc' _rewritten _rdr_env _envs ev eq_rel - s1@(ForAllTy (Bndr _ vis1) _) _ - s2@(ForAllTy (Bndr _ vis2) _) _ - | vis1 `eqForAllVis` vis2 -- Note [ForAllTy and type equality] - = 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 - ; can_eq_nc' True rdr_env envs new_ev eq_rel xi1 xi1 xi2 xi2 } - ----------------------------- --- Look for a canonical LHS. See Note [Canonical LHS]. --- Only rewritten types end up below here. ----------------------------- - --- NB: pattern match on 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 - = canEqCanLHS ev eq_rel NotSwapped can_eq_lhs1 ps_ty1 ty2 ps_ty2 - - | Just can_eq_lhs2 <- canEqLHS_maybe 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 -> continueWith (mkIrredCt ReprEqReason ev) - NomEq -> continueWith (mkIrredCt ShapeMismatchReason ev) } - -- No need to call canEqFailure/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 Ct) --- (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 - ; if not (equalLength bndrs1 bndrs2) - then do { traceTcS "Forall failure" $ - vcat [ ppr s1, ppr s2, ppr bndrs1, ppr bndrs2 - , ppr (binderFlags bndrs1) - , ppr (binderFlags bndrs2) ] - ; 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)) } - ---------------------------------- --- | 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. -zonk_eq_types :: TcType -> TcType -> TcS (Either (Pair TcType) TcType) -zonk_eq_types = go - where - 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) - -{- 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 :: CtEvidence -- ^ :: ty1 ~ ty2 - -> SwapFlag - -> TcType -- ^ ty1 - -> ((Bag GlobalRdrElt, TcCoercion), TcType) -- ^ :: ty1 ~ ty1' - -> TcType -- ^ ty2 - -> TcType -- ^ ty2, with type synonyms - -> TcS (StopOrContinue Ct) -can_eq_newtype_nc 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 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 Ct) - --- 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, ctev_rewriters = rewriters } <- ev - = do { co_s <- unifyWanted rewriters loc Nominal s1 s2 - ; let arg_loc - | isNextArgVisible s1 = loc - | otherwise = updateCtLocOrigin loc toInvisibleOrigin - ; co_t <- unifyWanted rewriters arg_loc Nominal t1 t2 - ; let co = 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] - ; canEqNC evar_s NomEq s1 s2 } - - 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? - -> CtEvidence - -> EqRel - -> SwapFlag - -> TcType -> Coercion -- LHS (res. RHS), ty1 |> co1 - -> TcType -> TcType -- RHS (res. LHS), ty2 both normal and pretty - -> TcS (StopOrContinue Ct) -canEqCast rewritten 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 new_ev eq_rel ty1 ty1 ty2 ps_ty2 } - where - role = eqRelRole eq_rel - ------------------------- -canTyConApp :: CtEvidence -> EqRel - -> TyCon -> [TcType] - -> TyCon -> [TcType] - -> TcS (StopOrContinue Ct) --- See Note [Decomposing TyConApp equalities] --- See Note [Decomposing Dependent TyCons and Processing Wanted Equalities] --- Neither tc1 nor tc2 is a saturated funTyCon, nor a type family --- But they can be data families. -canTyConApp ev eq_rel tc1 tys1 tc2 tys2 - | tc1 == tc2 - , tys1 `equalLength` tys2 - = do { inerts <- getTcSInerts - ; if can_decompose inerts - then canDecomposableTyConAppOK ev eq_rel tc1 tys1 tys2 - else canEqFailure 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) - ; continueWith (mkIrredCt AbstractTyConReason ev) } - - -- Fail straight away for better error messages - -- See Note [Use canEqFailure in canDecomposableTyConApp] - | eq_rel == ReprEq && not (isGenerativeTyCon tc1 Representational && - isGenerativeTyCon tc2 Representational) - = canEqFailure ev eq_rel ty1 ty2 - - | otherwise - = canEqHardFailure ev 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 [Use canEqFailure in canDecomposableTyConApp] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We must use canEqFailure, not canEqHardFailure here, because there is -the possibility of success if working with a representational equality. -Here is one case: - - type family TF a where TF Char = Bool - data family DF a - newtype instance DF Bool = MkDF Int - -Suppose we are canonicalising (Int ~R DF (TF a)), where we don't yet -know `a`. This is *not* a hard failure, because we might soon learn -that `a` is, in fact, Char, and then the equality succeeds. - -Here is another case: - - [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! - -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 canEqFailure 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 unifyWanted etc to short-cut that work. -See also Note [Decomposing Dependent TyCons and Processing Wanted Equalities] - -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 [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.Interact. - - 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 Ct) --- 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, ctev_rewriters = rewriters } - -- new_locs and tc_roles are both infinite, so - -- we are guaranteed that cos has the same lengthm - -- as tys1 and tys2 - -- See Note [Fast path when decomposing TyConApps] - -- Caution: unifyWanteds is order sensitive - -- See Note [Decomposing Dependent TyCons and Processing Wanted Equalities] - -> do { cos <- unifyWanteds rewriters new_locs tc_roles tys1 tys2 - ; setWantedEq dest (mkTyConAppCo role tc cos) } - - CtGiven { ctev_evar = evar } - -> do { let ev_co = mkCoVarCo evar - ; given_evs <- newGivenEvVars loc $ - [ ( mkPrimEqPredRole r ty1 ty2 - , evCoercion $ mkSelCo (SelTyCon i r) ev_co ) - | (r, ty1, ty2, i) <- zip4 tc_roles tys1 tys2 [0..] - , r /= Phantom - , not (isCoercionTy ty1) && not (isCoercionTy ty2) ] - ; emitWorkNC given_evs } - - ; stopWith ev "Decomposed TyConApp" } - - where - loc = ctEvLoc ev - role = eqRelRole eq_rel - - -- 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 = [ new_loc - | bndr <- tyConBinders tc - , let new_loc0 | isNamedTyConBinder bndr = toKindLoc loc - | otherwise = loc - new_loc | isInvisibleTyConBinder bndr - = updateCtLocOrigin new_loc0 toInvisibleOrigin - | otherwise - = new_loc0 ] - ++ repeat loc - -canDecomposableFunTy :: CtEvidence -> EqRel -> FunTyFlag - -> (Type,Type,Type) -- (multiplicity,arg,res) - -> (Type,Type,Type) -- (multiplicity,arg,res) - -> TcS (StopOrContinue Ct) -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, ctev_rewriters = rewriters } - -> do { mult <- unifyWanted rewriters mult_loc (funRole role SelMult) m1 m2 - ; arg <- unifyWanted rewriters loc (funRole role SelArg) a1 a2 - ; res <- unifyWanted rewriters loc (funRole role SelRes) r1 r2 - ; setWantedEq dest (mkNakedFunCo1 role af mult arg res) } - - CtGiven { ctev_evar = evar } - -> do { let ev_co = mkCoVarCo evar - ; given_evs <- newGivenEvVars loc $ - [ ( mkPrimEqPredRole role' ty1 ty2 - , evCoercion $ mkSelCo (SelFun fs) ev_co ) - | (fs, ty1, ty2) <- [(SelMult, m1, m2) - ,(SelArg, a1, a2) - ,(SelRes, r1, r2)] - , let role' = funRole role fs ] - ; emitWorkNC given_evs } - - ; stopWith ev "Decomposed TyConApp" } - - where - loc = ctEvLoc ev - role = eqRelRole eq_rel - mult_loc = updateCtLocOrigin loc toInvisibleOrigin - --- | Call when canonicalizing an equality fails, but if the equality is --- representational, there is some hope for the future. --- Examples in Note [Use canEqFailure in canDecomposableTyConApp] -canEqFailure :: CtEvidence -> EqRel - -> TcType -> TcType -> TcS (StopOrContinue Ct) -canEqFailure ev NomEq ty1 ty2 - = canEqHardFailure ev ty1 ty2 -canEqFailure 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 "canEqFailure with ReprEq" $ - vcat [ ppr ev, ppr redn1, ppr redn2 ] - ; new_ev <- rewriteEqEvidence (rewriters1 S.<> rewriters2) ev NotSwapped redn1 redn2 - ; continueWith (mkIrredCt ReprEqReason new_ev) } - --- | Call when canonicalizing an equality fails with utterly no hope. -canEqHardFailure :: CtEvidence - -> TcType -> TcType -> TcS (StopOrContinue Ct) --- 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 - ; continueWith (mkIrredCt 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 Ct) -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 k1 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 GHC.Tc.Solver.Interact. - -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) - -> EqRel -> SwapFlag - -> CanEqLHS -- xi1 - -> TcKind -- ki1 - -> TcType -- xi2 - -> TcKind -- ki2 - -> TcS (StopOrContinue Ct) -canEqCanLHSHetero ev eq_rel swapped lhs1 ki1 xi2 ki2 - -- See Note [Equalities with incompatible kinds] - -- See Note [Kind Equality Orientation] - -- NB: preserve left-to-right orientation!! - -- See Note [Fundeps with instances, and equality orientation] - -- wrinkle (W2) in GHC.Tc.Solver.Interact - = do { (kind_ev, kind_co) <- mk_kind_eq -- :: ki1 ~N ki2 - - ; let -- kind_co :: (ki1 :: *) ~N (ki2 :: *) (whether swapped or not) - lhs_redn = mkReflRedn role xi1 - rhs_redn = mkGReflRightRedn role xi2 (mkSymCo kind_co) - - -- See Note [Equalities with incompatible kinds], Wrinkle (1) - -- This will be ignored in rewriteEqEvidence if the work item is a Given - rewriters = rewriterSetFromCo kind_co - - ; traceTcS "Hetero equality gives rise to kind equality" - (ppr kind_co <+> dcolon <+> sep [ ppr ki1, text "~#", ppr ki2 ]) - ; type_ev <- rewriteEqEvidence rewriters ev swapped lhs_redn rhs_redn - - ; emitWorkNC [type_ev] -- delay the type equality until after we've finished - -- the kind equality, which may unlock things - -- See Note [Equalities with incompatible kinds] - - ; canEqNC kind_ev NomEq ki1 ki2 } - where - mk_kind_eq :: TcS (CtEvidence, CoercionN) - mk_kind_eq = case ev of - CtGiven { ctev_evar = evar } - -> do { let kind_co = maybe_sym $ mkKindCo (mkCoVarCo evar) -- :: k1 ~ k2 - ; kind_ev <- newGivenEvVar kind_loc (kind_pty, evCoercion kind_co) - ; return (kind_ev, ctEvCoercion kind_ev) } - - CtWanted { ctev_rewriters = rewriters } - -> newWantedEq kind_loc rewriters Nominal ki1 ki2 - - xi1 = canEqLHSType lhs1 - loc = ctev_loc ev - role = eqRelRole eq_rel - kind_loc = mkKindLoc xi1 xi2 loc - kind_pty = mkHeteroPrimEqPred liftedTypeKind liftedTypeKind ki1 ki2 - - maybe_sym = case swapped of - IsSwapped -> mkSymCo -- if the input is swapped, then we - -- will have k2 ~ k1, so flip it to k1 ~ k2 - NotSwapped -> id - --- guaranteed that typeKind lhs == typeKind rhs -canEqCanLHSHomo :: CtEvidence - -> EqRel -> SwapFlag - -> CanEqLHS -- lhs (or, if swapped, rhs) - -> TcType -- pretty lhs - -> TcType -> TcType -- rhs, pretty rhs - -> TcS (StopOrContinue Ct) -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 Ct) -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 (canEqLHSType lhs1) - - | TyVarLHS tv1 <- lhs1 - , TyVarLHS tv2 <- lhs2 - , swapOverTyVars (isGiven ev) tv1 tv2 - = do { traceTcS "canEqLHS2 swapOver" (ppr tv1 $$ ppr tv2 $$ ppr swapped) - ; new_ev <- do_swap - ; canEqCanLHSFinish new_ev eq_rel IsSwapped (TyVarLHS tv2) - (ps_xi1 `mkCastTyMCo` sym_mco) } - - | TyVarLHS tv1 <- lhs1 - , TyFamLHS fun_tc2 fun_args2 <- lhs2 - = canEqTyVarFunEq ev eq_rel swapped tv1 ps_xi1 fun_tc2 fun_args2 ps_xi2 mco - - | TyFamLHS fun_tc1 fun_args1 <- lhs1 - , TyVarLHS tv2 <- lhs2 - = do { new_ev <- do_swap - ; canEqTyVarFunEq new_ev eq_rel IsSwapped tv2 ps_xi2 - fun_tc1 fun_args1 ps_xi1 sym_mco } - - | 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) - - -- emit wanted equalities for injective type families - ; let inj_eqns :: [TypeEqn] -- TypeEqn = Pair Type - inj_eqns - | ReprEq <- eq_rel = [] -- injectivity applies only for nom. eqs. - | fun_tc1 /= fun_tc2 = [] -- if the families don't match, stop. - - | Injective inj <- tyConInjectivityInfo fun_tc1 - = [ Pair arg1 arg2 - | (arg1, arg2, 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. - | Just ops <- isBuiltInSynFamTyCon_maybe fun_tc1 - = let ki1 = canEqLHSKind lhs1 - ki2 | MRefl <- mco - = ki1 -- just a small optimisation - | otherwise - = canEqLHSKind lhs2 - - fake_rhs1 = anyTypeOfKind ki1 - fake_rhs2 = anyTypeOfKind ki2 - in - sfInteractInert ops fun_args1 fake_rhs1 fun_args2 fake_rhs2 - - | otherwise -- ordinary, non-injective type family - = [] - - ; case ev of - CtWanted { ctev_rewriters = rewriters } -> - mapM_ (\ (Pair t1 t2) -> unifyWanted rewriters (ctEvLoc ev) Nominal t1 t2) inj_eqns - CtGiven {} -> return () - -- See Note [No Given/Given fundeps] in GHC.Tc.Solver.Interact - - ; tclvl <- getTcLevel - ; let tvs1 = tyCoVarsOfTypes fun_args1 - tvs2 = tyCoVarsOfTypes fun_args2 - - swap_for_rewriting = anyVarSet (isTouchableMetaTyVar tclvl) tvs2 && - -- swap 'em: Note [Put touchable variables on the left] - not (anyVarSet (isTouchableMetaTyVar tclvl) tvs1) - -- this check is just to avoid unfruitful swapping - - -- If we have F a ~ F (F a), we want to swap. - swap_for_occurs - | cterHasNoProblem $ checkTyFamEq fun_tc2 fun_args2 - (mkTyConApp fun_tc1 fun_args1) - , cterHasOccursCheck $ checkTyFamEq fun_tc1 fun_args1 - (mkTyConApp fun_tc2 fun_args2) - = True - - | otherwise - = False - - ; if swap_for_rewriting || swap_for_occurs - then do { new_ev <- do_swap - ; canEqCanLHSFinish new_ev eq_rel IsSwapped lhs2 (ps_xi1 `mkCastTyMCo` sym_mco) } - else finish_without_swapping } - - -- that's all the special cases. Now we just figure out which non-special case - -- to continue to. - | otherwise - = finish_without_swapping - - where - sym_mco = mkSymMCo mco - - do_swap = rewriteCastedEquality ev eq_rel swapped (canEqLHSType lhs1) (canEqLHSType lhs2) mco - finish_without_swapping = canEqCanLHSFinish ev eq_rel swapped lhs1 (ps_xi2 `mkCastTyMCo` mco) - - --- This function handles the case where one side is a tyvar and the other is --- a type family application. Which to put on the left? --- If the tyvar is a touchable meta-tyvar, put it on the left, as this may --- be our only shot to unify. --- Otherwise, put the function on the left, because it's generally better to --- rewrite away function calls. This makes types smaller. And it seems necessary: --- [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 -canEqTyVarFunEq :: CtEvidence -- :: lhs ~ (rhs |> mco) - -- or (rhs |> mco) ~ lhs if swapped - -> EqRel -> SwapFlag - -> TyVar -> TcType -- lhs (or if swapped rhs), pretty lhs - -> TyCon -> [Xi] -> TcType -- rhs (or if swapped lhs) fun and args, pretty rhs - -> MCoercion -- :: kind(rhs) ~N kind(lhs) - -> TcS (StopOrContinue Ct) -canEqTyVarFunEq ev eq_rel swapped tv1 ps_xi1 fun_tc2 fun_args2 ps_xi2 mco - = do { (is_touchable, rhs) <- touchabilityTest (ctEvFlavour ev) tv1 rhs - ; if | case is_touchable of { Untouchable -> False; _ -> True } - , cterHasNoProblem $ - checkTyVarEq tv1 rhs `cterRemoveProblem` cteTypeFamily - -> canEqCanLHSFinish ev eq_rel swapped (TyVarLHS tv1) rhs - - | otherwise - -> do { new_ev <- rewriteCastedEquality ev eq_rel swapped - (mkTyVarTy tv1) (mkTyConApp fun_tc2 fun_args2) - mco - ; canEqCanLHSFinish new_ev eq_rel IsSwapped - (TyFamLHS fun_tc2 fun_args2) - (ps_xi1 `mkCastTyMCo` sym_mco) } } - where - sym_mco = mkSymMCo mco - rhs = ps_xi2 `mkCastTyMCo` mco - --- 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 :: CtEvidence - -> EqRel -> SwapFlag - -> CanEqLHS -- lhs (or, if swapped, rhs) - -> TcType -- rhs (or, if swapped, lhs) - -> TcS (StopOrContinue Ct) -canEqCanLHSFinish ev eq_rel swapped lhs rhs --- RHS is fully rewritten, but with type synonyms --- preserved as much as possible --- guaranteed that tyVarKind lhs == typeKind rhs, for (TyEq:K) --- (TyEq:N) is checked in can_eq_nc', and (TyEq:TV) is handled in canEqCanLHS2 - - = do { - -- this performs the swap if necessary - new_ev <- rewriteEqEvidence emptyRewriterSet ev swapped - (mkReflRedn role lhs_ty) - (mkReflRedn role rhs) - - -- by now, (TyEq:K) is already satisfied - ; massert (canEqLHSKind lhs `eqType` typeKind rhs) - - -- by now, (TyEq:N) is already satisfied (if applicable) - ; assertPprM ty_eq_N_OK $ - vcat [ text "CanEqCanLHSFinish: (TyEq:N) not satisfied" - , text "rhs:" <+> ppr rhs - ] - - -- guarantees (TyEq:OC), (TyEq:F) - -- Must do the occurs check even on tyvar/tyvar - -- equalities, in case have x ~ (y :: ..x...); this is #12593. - ; let result0 = checkTypeEq lhs rhs `cterRemoveProblem` cteTypeFamily - -- type families are OK here - -- NB: no occCheckExpand here; see Note [Rewriting synonyms] in GHC.Tc.Solver.Rewrite - - -- a ~R# b a is soluble if b later turns out to be Identity - result = case eq_rel of - NomEq -> result0 - ReprEq -> cterSetOccursCheckSoluble result0 - - reason = NonCanonicalReason result - - ; if cterHasNoProblem result - then do { traceTcS "CEqCan" (ppr lhs $$ ppr rhs) - ; continueWith (CEqCan { cc_ev = new_ev, cc_lhs = lhs - , cc_rhs = rhs, cc_eq_rel = eq_rel }) } - - else do { m_stuff <- breakTyEqCycle_maybe ev result lhs rhs - -- See Note [Type equality cycles]; - -- returning Nothing is the vastly common case - ; case m_stuff of - { Nothing -> - do { traceTcS "canEqCanLHSFinish can't make a canonical" - (ppr lhs $$ ppr rhs) - ; continueWith (mkIrredCt reason new_ev) } - ; Just rhs_redn@(Reduction _ new_rhs) -> - do { traceTcS "canEqCanLHSFinish breaking a cycle" $ - ppr lhs $$ ppr rhs - ; traceTcS "new RHS:" (ppr new_rhs) - - -- This check is Detail (1) in the Note - ; if cterHasOccursCheck (checkTypeEq lhs new_rhs) - - then do { traceTcS "Note [Type equality cycles] Detail (1)" - (ppr new_rhs) - ; continueWith (mkIrredCt reason new_ev) } - - else do { -- See Detail (6) of Note [Type equality cycles] - new_new_ev <- rewriteEqEvidence emptyRewriterSet - new_ev NotSwapped - (mkReflRedn Nominal lhs_ty) - rhs_redn - - ; continueWith (CEqCan { cc_ev = new_new_ev - , cc_lhs = lhs - , cc_rhs = new_rhs - , cc_eq_rel = eq_rel }) }}}}} - where - role = eqRelRole eq_rel - - lhs_ty = canEqLHSType lhs - - -- 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 - --- | Solve a reflexive equality constraint -canEqReflexive :: CtEvidence -- ty ~ ty - -> EqRel - -> TcType -- ty - -> TcS (StopOrContinue Ct) -- always Stop -canEqReflexive ev eq_rel ty - = do { setEvBindIfWanted ev (evCoercion $ - mkReflCo (eqRelRole eq_rel) ty) - ; stopWith ev "Solved by reflexivity" } - -rewriteCastedEquality :: CtEvidence -- :: lhs ~ (rhs |> mco), or (rhs |> mco) ~ lhs - -> EqRel -> SwapFlag - -> TcType -- lhs - -> TcType -- rhs - -> MCoercion -- mco - -> TcS CtEvidence -- :: (lhs |> sym mco) ~ rhs - -- result is independent of SwapFlag -rewriteCastedEquality ev eq_rel swapped lhs rhs mco - = rewriteEqEvidence emptyRewriterSet ev swapped lhs_redn rhs_redn - where - lhs_redn = mkGReflRightMRedn role lhs sym_mco - rhs_redn = mkGReflLeftMRedn role rhs mco - - sym_mco = mkSymMCo mco - role = eqRelRole eq_rel - -{- 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) - -We carry on with the *kind equality*, not the type equality, because -solving the former may unlock the latter. This choice is made in -canEqCanLHSHetero. It is important: otherwise, T13135 loops. - -Wrinkles: - - (1) 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. - - (2) If we have [W] w :: alpha ~ (rhs |> sym co_hole), should we unify alpha? No. - The problem is that the wanted w is effectively rewritten by another wanted, - and unifying alpha effectively promotes this wanted to a given. Doing so - means we lose track of the rewriter set associated with the wanted. - - On the other hand, w is perfectly suitable for rewriting, because of the - way we carefully track rewriter sets. - - We thus allow w to be a CEqCan, but we prevent unification. See - Note [Unification preconditions] in GHC.Tc.Utils.Unify. - - The only tricky part is that we must later indeed unify if/when the kind-level - wanted 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. - - (3) 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 in breakTyEqCycle_maybe. - -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. Note its orientation: The type family ends up on the left; see -commentary on canEqTyVarFunEq, which decides how to orient such cases. 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 breakTyEqCycle_maybe. - -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 cycle-breakers! -* 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 ------- -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. Why TauTvs? See [Why TauTvs] below. - -Critically, we emit the two new constraints (the last two above) -directly instead of calling unifyWanted. (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 -- which must be the next step after breaking the cycles -- -happens in the course of normal behavior of top-level -interactions, later in the solver pipeline. We know this unification will -indeed happen because breakTyEqCycle_maybe, which decides whether to apply -this logic, checks to ensure unification will succeed in its final_check. -(In particular, the LHS must be a touchable tyvar, never a type family. We don't -yet have an example of where this logic is needed with a type family, and it's -unclear how to handle this case, so we're skipping for now.) 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. - -In all cases ------------- - -We detect this scenario by the following characteristics: - - a constraint with a soluble occurs-check failure - (as indicated by the cteSolubleOccurs bit set in a CheckTyEqResult - from checkTypeEq) - - and a nominal equality - - and either - - a Given flavour (but see also Detail (7) below) - - a Wanted flavour, with a touchable metavariable on the left - -We don't use this trick 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. - -Details: - - (1) We don't look under foralls, at all, when substituting away type family - applications, because doing so can never be fruitful. Recall that we - are in a case like [G] lhs ~ forall b. ... lhs .... Until we have a type - family that can pull the body out from a forall (e.g. type instance F (forall b. ty) = ty), - this will always be - insoluble. Note also that the forall cannot be in an argument to a - type family, or that outer type family application would already have - been substituted away. - - However, we still must check to make sure that breakTyEqCycle_maybe actually - succeeds in getting rid of all occurrences of the offending lhs. If - one is hidden under a forall, this won't be true. A similar problem can - happen if the variable appears only in a kind - (e.g. k ~ ... (a :: k) ...). So we perform an additional check after - performing the substitution. It is tiresome to re-run all of checkTypeEq - here, but reimplementing just the occurs-check is even more tiresome. - - Skipping this check causes typecheck/should_fail/GivenForallLoop and - polykinds/T18451 to loop. - - (2) 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 is another reason - we need to re-check that we've gotten rid of all occurrences of the - offending variable.) - - (3) As we're substituting 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 approach here is inefficient because it replaces every (outermost) - type family application with a type variable, regardless of whether that - particular appplication is implicated in the occurs check. An alternative - would be to replce only type-family applications that mention the offending LHS. - For instance, we could choose to - affect only type family applications that mention the offending LHS: - e.g. in a ~ (F b, G a), we need to replace only G a, not F b. Furthermore, - we could try to detect cases like a ~ (F a, F a) and use the same - tyvar to replace F a. (Cf. - Note [Flattening type-family applications when matching instances] - in GHC.Core.Unify, which - goes to this extra effort.) There may be other opportunities for - improvement. 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. - - (8) We really want to do this all only when there is a soluble occurs-check - failure, not when other problems arise (such as an impredicative - equality like alpha ~ forall a. a -> a). That is why breakTyEqCycle_maybe - uses cterHasOnlyProblem when looking at the result of checkTypeEq, which - checks for many of the invariants on a CEqCan. --} - -{- -************************************************************************ -* * - Evidence transformation -* * -************************************************************************ --} - -data StopOrContinue a - = ContinueWith a -- The constraint was not solved, although it may have - -- been rewritten - - | 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 <+> ppr ev - ppr (ContinueWith w) = text "ContinueWith" <+> ppr w - -continueWith :: a -> TcS (StopOrContinue a) -continueWith = return . ContinueWith - -stopWith :: CtEvidence -> String -> TcS (StopOrContinue a) -stopWith ev s = return (Stop ev (text s)) - -andWhenContinue :: TcS (StopOrContinue a) - -> (a -> TcS (StopOrContinue b)) - -> TcS (StopOrContinue b) -andWhenContinue tcs1 tcs2 - = do { r <- tcs1 - ; case r of - Stop ev s -> return (Stop ev s) - ContinueWith ct -> tcs2 ct } -infixr 0 `andWhenContinue` -- allow chaining with ($) - -rewriteEvidence :: RewriterSet -- ^ See Note [Wanteds rewrite Wanteds] - -- in GHC.Tc.Types.Constraint - -> CtEvidence -- ^ old evidence - -> Reduction -- ^ new predicate + coercion, of type ~ new predicate - -> TcS (StopOrContinue CtEvidence) --- Returns Just new_ev iff either (i) 'co' is reflexivity --- or (ii) 'co' is not reflexivity, and 'new_pred' not cached --- In either case, there is nothing new to do with new_ev -{- - rewriteEvidence old_ev new_pred co -Main purpose: create new evidence for new_pred; - unless new_pred is cached already -* Returns a 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 -* Returns Nothing if new_ev is already cached - - Old evidence New predicate is Return new evidence - flavour of same flavor - ------------------------------------------------------------------- - Wanted Already solved or in inert Nothing - Not Just new_evidence - - Given Already in inert Nothing - Not Just new_evidence - -Note [Rewriting with Refl] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -If the coercion is just reflexivity then you may re-use the same -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 rewriters old_ev (Reduction co new_pred) - | isReflCo co -- See Note [Rewriting with Refl] - = assert (isEmptyRewriterSet rewriters) $ - continueWith (setCtEvPredType old_ev new_pred) - -rewriteEvidence rewriters ev@(CtGiven { ctev_evar = old_evar, ctev_loc = loc }) - (Reduction co new_pred) - = 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) - -rewriteEvidence new_rewriters - ev@(CtWanted { ctev_dest = dest - , ctev_loc = loc - , ctev_rewriters = rewriters }) - (Reduction co new_pred) - = do { mb_new_ev <- newWanted loc rewriters' new_pred - ; massert (coercionRole co == ctEvRole ev) - ; setWantedEvTerm dest - (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 - - -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 - -{- -************************************************************************ -* * - Unification -* * -************************************************************************ - -Note [unifyWanted] -~~~~~~~~~~~~~~~~~~ -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), unifyWanted traverses the common structure, and -bales out when it finds a difference by creating a new Wanted constraint. -But where it succeeds in finding common structure, it just builds a coercion -to reflect it. --} - -unifyWanted :: RewriterSet -> CtLoc - -> Role -> TcType -> TcType -> TcS Coercion --- Return coercion witnessing the equality of the two types, --- emitting new work equalities where necessary to achieve that --- Very good short-cut when the two types are equal, or nearly so --- See Note [unifyWanted] --- The returned coercion's role matches the input parameter -unifyWanted rewriters loc Phantom ty1 ty2 - = do { kind_co <- unifyWanted rewriters loc Nominal (typeKind ty1) (typeKind ty2) - ; return (mkPhantomCo kind_co ty1 ty2) } - -unifyWanted rewriters loc role orig_ty1 orig_ty2 - = go orig_ty1 orig_ty2 - where - go ty1 ty2 | Just ty1' <- coreView ty1 = go ty1' ty2 - go ty1 ty2 | Just ty2' <- coreView ty2 = go ty1 ty2' - - go (FunTy af1 w1 s1 t1) (FunTy af2 w2 s2 t2) - | af1 == af2 -- Important! See #21530 - = do { co_s <- unifyWanted rewriters loc role s1 s2 - ; co_t <- unifyWanted rewriters loc role t1 t2 - ; co_w <- unifyWanted rewriters loc Nominal w1 w2 - ; return (mkNakedFunCo1 role af1 co_w co_s co_t) } - - go (TyConApp tc1 tys1) (TyConApp tc2 tys2) - | tc1 == tc2, tys1 `equalLength` tys2 - , isInjectiveTyCon tc1 role -- don't look under newtypes at Rep equality - = do { cos <- zipWith3M (unifyWanted rewriters loc) - (tyConRoleListX role tc1) tys1 tys2 - ; return (mkTyConAppCo role tc1 cos) } - - go ty1@(TyVarTy tv) ty2 - = do { mb_ty <- isFilledMetaTyVar_maybe tv - ; case mb_ty of - Just ty1' -> go ty1' ty2 - Nothing -> bale_out ty1 ty2} - go ty1 ty2@(TyVarTy tv) - = do { mb_ty <- isFilledMetaTyVar_maybe tv - ; case mb_ty of - Just ty2' -> go ty1 ty2' - Nothing -> bale_out ty1 ty2 } - - go ty1@(CoercionTy {}) (CoercionTy {}) - = return (mkReflCo role ty1) -- we just don't care about coercions! - - go ty1 ty2 = bale_out ty1 ty2 - - bale_out ty1 ty2 - | ty1 `tcEqType` ty2 = return (mkReflCo role ty1) - -- Check for equality; e.g. a ~ a, or (m a) ~ (m a) - | otherwise = emitNewWantedEq loc rewriters role orig_ty1 orig_ty2 - - -{- -Note [Decomposing Dependent TyCons and Processing Wanted Equalities] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When we decompose a dependent tycon we obtain a list of -mixed wanted type and kind equalities. Ideally we want -all the kind equalities to get solved first so that we avoid -generating duplicate kind equalities - -For example, consider decomposing a TyCon equality - - (0) [W] T k_fresh (t1::k_fresh) ~ T k1 (t2::k_fresh) - -This gives rise to 2 equalities in the solver worklist - - (1) [W] k_fresh ~ k1 - (2) [W] t1::k_fresh ~ t2::k1 - -The solver worklist is processed in LIFO order: -see GHC.Tc.Solver.InertSet.selectWorkItem. -i.e. (2) is processed _before_ (1). Now, while solving (2) -we would call `canEqCanLHSHetero` and that would emit a -wanted kind equality - - (3) [W] k_fresh ~ k1 - -But (3) is exactly the same as (1)! - -To avoid such duplicate wanted constraints from being added to the worklist, -we ensure that (2) is processed before (1). Since we are processing -the worklist in a LIFO ordering, we do it by emitting (1) before (2). -This is exactly what we do in `unifyWanteds`. - -NB: This ordering is not needed when we decompose FunTyCons as they are not dependently typed --} - --- NB: Length of [CtLoc] and [Roles] may be infinite --- but list of RHS [TcType] and LHS [TcType] is finite and both are of equal length -unifyWanteds :: RewriterSet -> [CtLoc] -> [Role] - -> [TcType] -- List of RHS types - -> [TcType] -- List of LHS types - -> TcS [Coercion] -unifyWanteds rewriters ctlocs roles rhss lhss = unify_wanteds rewriters $ zip4 ctlocs roles rhss lhss - where - -- Order is important here - -- See Note [Decomposing Dependent TyCons and Processing Wanted Equalities] - unify_wanteds _ [] = return [] - unify_wanteds rewriters ((new_loc, tc_role, ty1, ty2) : rest) - = do { cos <- unify_wanteds rewriters rest - ; co <- unifyWanted rewriters new_loc tc_role ty1 ty2 - ; return (co:cos) } 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 new file mode 100644 --- /dev/null +++ b/GHC/Tc/Solver/Dict.hs @@ -0,0 +1,2231 @@ +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE MultiWayIf #-} + +-- | Solving Class constraints CDictCan +module GHC.Tc.Solver.Dict ( + solveDict, solveDictNC, solveCallStack, + checkInstanceOK, + matchLocalInst, chooseInstance, + makeSuperClasses, mkStrictSuperClasses, + ) 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( matchEqualityInst ) +import GHC.Tc.Types.Evidence +import GHC.Tc.Types.Constraint +import GHC.Tc.Types.CtLoc +import GHC.Tc.Types.Origin +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, mightEqualLater ) + +import GHC.Hs.Type( HsIPName(..) ) + +import GHC.Core +import GHC.Core.Make +import GHC.Core.Type +import GHC.Core.InstEnv ( DFunInstType, ClsInst(..) ) +import GHC.Core.Class +import GHC.Core.Predicate +import GHC.Core.Multiplicity ( scaledThing ) +import GHC.Core.Unify ( ruleMatchTyKiX ) + +import GHC.Types.TyThing( lookupDataCon, lookupId ) +import GHC.Types.Name +import GHC.Types.Name.Set +import GHC.Types.Var +import GHC.Types.Id( mkTemplateLocals ) +import GHC.Types.Var.Set +import GHC.Types.Var.Env +import GHC.Types.SrcLoc + +import GHC.Builtin.Names( srcLocDataConName, pushCallStackName, emptyCallStackName ) + +import GHC.Utils.Monad ( concatMapM, foldlM ) +import GHC.Utils.Outputable +import GHC.Utils.Panic +import GHC.Utils.Misc + +import GHC.Unit.Module + +import GHC.Data.Bag + +import GHC.Driver.DynFlags + +import qualified GHC.LanguageExtensions as LangExt + +import Data.Maybe ( listToMaybe, mapMaybe, isJust ) +import Data.Void( Void ) + +import Control.Monad + +{- ********************************************************************* +* * +* Class Canonicalization +* * +********************************************************************* -} + +solveDictNC :: CtEvidence -> Class -> [Type] -> SolverStage Void +-- NC: this comes from CNonCanonical or CIrredCan +-- Precondition: already rewritten by inert set +solveDictNC ev cls tys + = do { simpleStage $ traceTcS "solveDictNC" (ppr (mkClassPred cls tys) $$ ppr ev) + ; dict_ct <- canDictCt ev cls tys + ; solveDict dict_ct } + +solveDict :: DictCt -> SolverStage Void +-- Preconditions: `tys` are already rewritten by the inert set +solveDict dict_ct@(DictCt { di_ev = ev, di_cls = cls, di_tys = tys }) + | isEqualityClass cls + = solveEqualityDict ev cls tys + + | otherwise + = assertPpr (ctEvRewriteRole ev == Nominal) (ppr ev $$ ppr cls $$ ppr tys) $ + do { simpleStage $ traceTcS "solveDict" (ppr dict_ct) + + ; tryInertDicts dict_ct + ; tryInstances dict_ct + + -- Try fundeps /after/ tryInstances: + -- see (DFL2) in Note [Do fundeps last] + ; doLocalFunDepImprovement dict_ct + -- doLocalFunDepImprovement does StartAgain if there + -- are any fundeps: see (DFL1) in Note [Do fundeps last] + + ; doTopFunDepImprovement dict_ct + + ; simpleStage (updInertDicts dict_ct) + ; stopWithStage (dictCtEvidence dict_ct) "Kept inert DictCt" } + +canDictCt :: CtEvidence -> Class -> [Type] -> SolverStage DictCt +-- Once-only processing of Dict constraints: +-- * expand superclasses +-- * deal with CallStack +canDictCt ev cls tys + | isGiven ev -- See Note [Eagerly expand given superclasses] + = Stage $ + do { dflags <- getDynFlags + ; sc_cts <- mkStrictSuperClasses (givensFuel dflags) ev [] [] cls tys + -- givensFuel dflags: See Note [Expanding Recursive Superclasses and ExpansionFuel] + ; emitWork (listToBag sc_cts) + + ; continueWith (DictCt { di_ev = ev, di_cls = cls + , di_tys = tys, di_pend_sc = doNotExpand }) } + -- doNotExpand: We have already expanded superclasses for /this/ dict + -- so set the fuel to doNotExpand to avoid repeating expansion + + | CtWanted (WantedCt { ctev_rewriters = rws }) <- ev + , Just ip_name <- isCallStackPred cls tys + , 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] + = 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 <- 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 fun_fs (ctLocSpan loc) (ctEvExpr new_ev) + ; solveCallStack ev ev_cs + + ; continueWith (DictCt { di_ev = new_ev, di_cls = cls + , di_tys = tys, di_pend_sc = doNotExpand }) } + -- doNotExpand: No superclasses for class CallStack + -- See invariants in CDictCan.cc_pend_sc + + | otherwise + = Stage $ + do { dflags <- getDynFlags + ; let fuel | classHasSCs cls = wantedsFuel dflags + | otherwise = doNotExpand + -- 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 { 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) + ] + + ; 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: + +* 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 + existing [G] (?x :: ty'), regardless of ty'. + +* Wrinkle (SIP1): we must be careful of superclasses. Consider + f,g :: (?x::Int, C a) => a -> a + f v = let ?x = 4 in g v + + The call to 'g' gives rise to a Wanted constraint (?x::Int, C a). + We must /not/ solve this from the Given (?x::Int, C a), because of + the intervening binding for (?x::Int). #14218. + + We deal with this by arranging that when we add [G] (?x::ty) we delete + * from the inert_cans, and + * from the inert_solved_dicts + any existing [G] (?x::ty) /and/ any [G] D tys, where (D tys) has a superclass + with (?x::ty). See Note [Local implicit parameters] in GHC.Core.Predicate. + + An important special case is constraint tuples like [G] (% ?x::ty, Eq a %). + But it could happen for `class xx => D xx where ...` and the constraint D + (?x :: int). This corner (constraint-kinded variables instantiated with + implicit parameter constraints) is not well explored. + + Example in #14218, and #23761 + + The code that accounts for (SIP1) is in updInertDicts; in particular the call to + GHC.Core.Predicate.mentionsIP. + +* Wrinkle (SIP2): we must apply this update semantics for `inert_solved_dicts` + as well as `inert_cans`. + You might think that wouldn't be necessary, because an element of + `inert_solved_dicts` is never an implicit parameter (see + Note [Solved dictionaries] in GHC.Tc.Solver.InertSet). + While that is true, dictionaries in `inert_solved_dicts` may still have + implicit parameters as a /superclass/! For example: + + class c => C c where ... + f :: C (?x::Int) => blah + + Now (C (?x::Int)) has a superclass (?x::Int). This may look exotic, but it + happens particularly for constraint tuples, like `(% ?x::Int, Eq a %)`. + +Example 1: + +Suppose we have (typecheck/should_compile/ImplicitParamFDs) + flub :: (?x :: Int) => (Int, Integer) + flub = (?x, let ?x = 5 in ?x) +When we are checking the last ?x occurrence, we guess its type to be a fresh +unification variable alpha and emit an (IP "x" alpha) constraint. But the given +(?x :: Int) has been translated to an IP "x" Int constraint, which has a +functional dependency from the name to the type. So if that (?x::Int) is still +in the inert set, we'd get a fundep interaction that tells us that alpha ~ Int, +and we get a type error. This is bad. The "replacement" semantics stops this +happening. + +Example 2: + +f :: (?x :: Char) => Char +f = let ?x = 'a' in ?x + +The "let ?x = ..." generates an implication constraint of the form: + +?x :: Char => ?x :: Char + +Furthermore, the signature for `f` also generates an implication +constraint, so we end up with the following nested implication: + +?x :: Char => (?x :: Char => ?x :: Char) + +Note that the wanted (?x :: Char) constraint may be solved in two incompatible +ways: either by using the parameter from the signature, or by using the local +definition. Our intention is that the local definition should "shadow" the +parameter of the signature. The "replacement" semantics for implicit parameters +does this. + +Example 3: + +Similarly, consider + f :: (?x::a) => Bool -> a + + g v = let ?x::Int = 3 + in (f v, let ?x::Bool = True in f v) + +This should probably be well typed, with + g :: Bool -> (Int, Bool) + +So the inner binding for ?x::Bool *overrides* the outer one. + +See ticket #17104 for a rather tricky example of this overriding +behaviour. + +All this works for the normal cases but it has an odd side effect in +some pathological programs like this: + + -- This is accepted, the second parameter shadows + f1 :: (?x :: Int, ?x :: Char) => Char + f1 = ?x + + -- This is rejected, the second parameter shadows + f2 :: (?x :: Int, ?x :: Char) => Int + f2 = ?x + +Both of these are actually wrong: when we try to use either one, +we'll get two incompatible wanted constraints (?x :: Int, ?x :: Char), +which would lead to an error. + +I can think of two ways to fix this: + + 1. Simply disallow multiple constraints for the same implicit + parameter---this is never useful, and it can be detected completely + syntactically. + + 2. Move the shadowing machinery to the location where we nest + implications, and add some code here that will produce an + error if we get multiple givens for the same implicit parameter. +-} + + +{- ****************************************************************************** +* * + solveEqualityDict +* * +****************************************************************************** -} + +{- Note [Solving equality classes] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider (~), which behaves as if it was defined like this: + class a ~# b => a ~ b + instance a ~# b => a ~ b +There are two more similar "equality classes" like this. The full list is + * (~) eqTyCon + * (~~) heqTyCon + * Coercible coercibleTyCon +(See Note [The equality types story] in GHC.Builtin.Types.Prim.) + +(EQC1) For Givens, when expanding the superclasses of a equality class, + we can /replace/ the constraint with its superclasses (which, remember, are + equally powerful) rather than /adding/ them. This can make a huge difference. + Consider T17836, which has a constraint like + forall b,c. a ~ (b,c) => + forall d,e. c ~ (d,e) => + ...etc... + If we just /add/ the superclasses of [G] g1:a ~ (b,c), we'll put + [G] g1:(a~(b,c)) in the inert set and emit [G] g2:a ~# (b,c). That will + kick out g1, and it'll be re-inserted as [G] g1':(b,c)~(b,c) which does + no good to anyone. When the implication is deeply nested, this has + quadratic cost, and no benefit. Just replace! + + (This can have a /big/ effect: test T17836 involves deeply-nested GADT + 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 + so the reduction of the [W] constraint does not risk losing any solutions. + + On the other hand, it can be fatal to /fail/ to reduce such equalities + on the grounds of Note [Instance and Given overlap], because many good + things flow from [W] t1 ~# t2. + +Conclusion: we have a special solver pipeline for equality-class constraints, +`solveEqualityDict`. It aggressively decomposes the boxed equality constraint +into an unboxed coercion, both for Givens and Wanteds, and /replaces/ the +boxed equality constraint with the unboxed one, so that the inert set never +contains the boxed one. + +Note [Solving tuple constraints] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +I tried treating tuple constraints, such as (% Eq a, Show a %), rather like +equality-class constraints (see Note [Solving equality classes]). That is, by +eagerly decomposing tuple-constraints into their component (Eq a) and (Show a). + +But discarding the tuple Given (which "replacing" does) means that we may +have to reconstruct it for a recursive call. For example + f :: (% Eq a, Show a %) => blah + f x = ....(f x').... +If we decomposed eagerly we'd get + f = \(d : (% Eq a, Show a %)). + let de = fst d + ds = snd d + in ....(f (% de, ds %))... +and the optimiser may not be clever enough to transform (f (% de, ds %)) into +(f d). See #10359 and its test case, and #23398. (This issue is less pressing for +equality classes because they have to be unpacked strictly, so CSE-ing away +the reconstruction works fine. + +So at the moment we don't decompose tuple constraints eagerly; instead we mostly +just treat them like other constraints. +* Given tuples are decomposed via their superclasses, in `canDictCt`. So + [G] (% Eq a, Show a %) + has superclasses + [G] Eq a, [G] Show a + +* Wanted tuples are decomposed via a built-in "instance". See + `GHC.Tc.Instance.Class.matchCTuple` + +There is a bit of special treatment: search for isCTupleClass. +-} + +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 (WantedCt { ctev_dest = dest }) <- ev + = Stage $ + do { let (role, t1, t2) = matchEqualityInst cls tys + -- Unify t1~t2, putting anything that can't be solved + -- immediately into the work list + ; (co, _, _) <- wrapUnifierTcS ev role $ \uenv -> + uType uenv t1 t2 + -- Set d :: (t1~t2) = Eq# co + ; setWantedEvTerm dest EvCanonical $ + evDictApp cls tys [Coercion co] + ; stopWith ev "Solved wanted lifted equality" } + + | CtGiven (GivenCt { ctev_evar = ev_id }) <- ev + , [sel_id] <- classSCSelIds cls -- Equality classes have just one superclass + = Stage $ + 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 $ CtGiven given_ev) } + | otherwise + = pprPanic "solveEqualityDict" (ppr cls) + +{- ****************************************************************************** +* * + interactDict +* * +********************************************************************************* + +Note [Shortcut solving] +~~~~~~~~~~~~~~~~~~~~~~~ +When we interact a [W] constraint with a [G] constraint that solves it, there is +a possibility that we could produce better code if instead we solved from a +top-level instance declaration (See #12791, #5835). For example: + + class M a b where m :: a -> b + + type C a b = (Num a, M a b) + + f :: C Int b => b -> Int -> Int + f _ x = x + 1 + +The body of `f` requires a [W] `Num Int` instance. We could solve this +constraint from the givens because we have `C Int b` and that provides us a +solution for `Num Int`. This would let us produce core like the following +(with -O2): + + f :: forall b. C Int b => b -> Int -> Int + f = \ (@ b) ($d(%,%) :: C Int b) _ (eta1 :: Int) -> + + @ Int + (GHC.Classes.$p1(%,%) @ (Num Int) @ (M Int b) $d(%,%)) + eta1 + A.f1 + +This is bad! We could do /much/ better if we solved [W] `Num Int` directly +from the instance that we have in scope: + + f :: forall b. C Int b => b -> Int -> Int + f = \ (@ b) _ _ (x :: Int) -> + 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. + +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). + +----------------------------------- +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: + + class Eq a => C a b | b -> a where + m :: b -> a + + f :: C [Int] b => b -> Bool + f x = m x == [] + +We solve for `Eq [Int]`, which requires `Eq Int`, which we also have. This +produces the following core: + + f :: forall b. C [Int] b => b -> Bool + f = \ (@ b) ($dC :: C [Int] b) (x :: b) -> + GHC.Classes.$fEq[]_$s$c== + (m @ [Int] @ b $dC x) (GHC.Types.[] @ Int) + +An example that fails: + + class Eq a => C a b | b -> a where + m :: b -> a + + f :: C [a] b => b -> Bool + f x = m x == [] + +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) -> + == + @ [a] + (A.$p1C @ [a] @ b $dC) + (m @ [a] @ b $dC eta) + (GHC.Types.[] @ a) + +The moving parts are relatively simple: + +* To attempt to solve the constraint completely, we just recursively + call the constraint solver. See the use of `tryShortCutTcS` in + `tcShortCutSolver`. + +* 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 +cannot assume coherence because of IncoherentInstances then this optimization +can change the behavior of the user's code. + +The following four modules produce a program whose output would change depending +on whether we apply this optimization when IncoherentInstances is in effect: + +========= + {-# LANGUAGE MultiParamTypeClasses #-} + module A where + + class A a where + int :: a -> Int + + class A a => C a b where + m :: b -> a -> a + +========= + {-# LANGUAGE FlexibleInstances #-} + {-# LANGUAGE MultiParamTypeClasses #-} + module B where + + import A + + instance A a where + int _ = 1 + + instance C a [b] where + m _ = id + +========= + {-# LANGUAGE FlexibleContexts #-} + {-# LANGUAGE FlexibleInstances #-} + {-# LANGUAGE IncoherentInstances #-} + {-# LANGUAGE MultiParamTypeClasses #-} + module C where + + import A + + instance A Int where + int _ = 2 + + instance C Int [Int] where + m _ = id + + intC :: C Int a => a -> Int -> Int + intC _ x = int x + +========= + module Main where + + import A + import B + import C + + main :: IO () + main = print (intC [] (0::Int)) + +The output of `main` if we avoid the optimization under the effect of +IncoherentInstances is `1`. If we were to do the optimization, the output of +`main` would be `2`. + + +Note [No Given/Given fundeps] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We do not create constraints from: +* Given/Given interactions via functional dependencies or type family + injectivity annotations. +* Given/instance fundep interactions via functional dependencies or + type family injectivity annotations. + +In this Note, all these interactions are called just "fundeps". + +We ingore such fundeps for several reasons: + +1. These fundeps will never serve a purpose in accepting more + programs: Given constraints do not contain metavariables that could + be unified via exploring fundeps. They *could* be useful in + discovering inaccessible code. However, the constraints will be + Wanteds, and as such will cause errors (not just warnings) if they + go unsolved. Maybe there is a clever way to get the right + inaccessible code warnings, but the path forward is far from + clear. #12466 has further commentary. + +2. Furthermore, here is a case where a Given/instance interaction is actively + harmful (from dependent/should_compile/RaeJobTalk): + + type family a == b :: Bool + type family Not a = r | r -> a where + Not False = True + Not True = False + + [G] Not (a == b) ~ True + + Reacting this Given with the equations for Not produces + + [W] a == b ~ False + + This is indeed a true consequence, and would make sense as a fresh Given. + But we don't have a way to produce evidence for fundeps, as a Wanted it + is /harmful/: we can't prove it, and so we'll report an error and reject + the program. (Previously fundeps gave rise to Deriveds, which + carried no evidence, so it didn't matter that they could not be proved.) + +3. #20922 showed a subtle different problem with Given/instance fundeps. + type family ZipCons (as :: [k]) (bssx :: [[k]]) = (r :: [[k]]) | r -> as bssx where + ZipCons (a ': as) (bs ': bss) = (a ': bs) ': ZipCons as bss + ... + + tclevel = 4 + [G] ZipCons is1 iss ~ (i : is2) : jss + + (The tclevel=4 means that this Given is at level 4.) The fundep tells us that + 'iss' must be of form (is2 : beta[4]) where beta[4] is a fresh unification + variable; we don't know what type it stands for. So we would emit + [W] iss ~ is2 : beta + + Again we can't prove that equality; and worse we'll rewrite iss to + (is2:beta) in deeply nested constraints inside this implication, + where beta is untouchable (under other equality constraints), leading + to other insoluble constraints. + +The bottom line: since we have no evidence for them, we should ignore Given/Given +and Given/instance fundeps entirely. +-} + +tryInertDicts :: DictCt -> SolverStage () +tryInertDicts dict_ct + = Stage $ do { inerts <- getInertCans + ; try_inert_dicts inerts dict_ct } + +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 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 { -- For a Wanted, first to try to solve it /completely/ from top level instances + -- See Note [Shortcut solving] + ; short_cut_worked <- tryShortCutSolver (isGiven ev_i) dict_w + + ; 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] +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 + | otherwise + = do { dflags <- getDynFlags + ; if | CtWanted (WantedCt { ctev_pred = pred_w }) <- ev_w + + , not (couldBeIPLike pred_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 + + -> tryShortCutTcS $ -- tryTcS tries to completely solve some contraints + do { residual <- solveSimpleWanteds (unitBag (CDictCan dict_w)) + ; return (isEmptyWC residual) } + + | otherwise + -> return False } + + +{- ******************************************************************* +* * + Top-level reaction for class constraints (CDictCan) +* * +**********************************************************************-} + +tryInstances :: DictCt -> SolverStage () +tryInstances dict_ct + = Stage $ do { inerts <- getInertSet + ; try_instances inerts dict_ct } + +try_instances :: InertSet -> DictCt -> TcS (StopOrContinue ()) +-- Try to use type-class instance declarations to simplify the constraint +try_instances inerts work_item@(DictCt { di_ev = ev, di_cls = cls + , di_tys = xis }) + | isGiven ev -- Never use instances for Given constraints + = continueWith () + -- See Note [No Given/Given fundeps] + + | 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 + = do { dflags <- getDynFlags + ; lkup_res <- matchClassInst dflags inerts cls xis dict_loc + ; case lkup_res of + OneInst { cir_what = what } + -> 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 + +chooseInstance :: CtEvidence -> ClsInstResult -> TcS (StopOrContinue a) +chooseInstance work_item + (OneInst { cir_new_theta = theta + , cir_what = what + , cir_mk_ev = mk_ev + , cir_canonical = canonical }) + = do { traceTcS "doTopReact/found instance for" $ ppr work_item + ; deeper_loc <- checkInstanceOK loc what pred + ; checkReductionDepth deeper_loc pred + ; assertPprM (getTcEvBindsVar >>= return . not . isCoEvBindsVar) + (ppr work_item) + ; evc_vars <- mapM (newWanted deeper_loc (ctEvRewriters work_item)) theta + ; setEvBindIfWanted work_item canonical (mk_ev (map getEvExpr evc_vars)) + ; emitWorkNC (map CtWanted $ freshGoals evc_vars) + ; stopWith work_item "Dict/Top (solved wanted)" } + where + pred = ctEvPred work_item + loc = ctEvLoc work_item + +chooseInstance work_item lookup_res + = pprPanic "chooseInstance" (ppr work_item $$ ppr lookup_res) + +checkInstanceOK :: CtLoc -> InstanceWhat -> TcPredType -> TcS CtLoc +-- Check that it's OK to use this instance: +-- (a) the use is well staged in the Template Haskell sense +-- Returns the CtLoc to used for sub-goals +-- Probably also want to call checkReductionDepth +checkInstanceOK loc what pred + = do { checkWellLevelledDFun loc what pred + ; return deeper_loc } + where + deeper_loc = zap_origin (bumpCtLocDepth loc) + origin = ctLocOrigin loc + + zap_origin loc -- After applying an instance we can set ScOrigin to + -- NotNakedSc, so that prohibitedSuperClassSolve never fires + -- See Note [Solving superclass constraints] in + -- GHC.Tc.TyCl.Instance, (sc1). + | ScOrigin what _ <- origin + = setCtLocOrigin loc (ScOrigin what NotNakedSc) + | otherwise + = loc + +matchClassInst :: DynFlags -> InertSet + -> Class -> [Type] + -> CtLoc -> TcS ClsInstResult +matchClassInst dflags inerts clas tys loc +-- 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] 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 + -- And if we don't do so, we may never solve it at all + -- See Note [Solving tuple constraints] + , not (noMatchableGivenDicts inerts loc clas tys) + = do { traceTcS "Delaying instance application" $ + vcat [ text "Work item:" <+> pprClassPred clas tys ] + ; return NotSure } + + | otherwise + = do { traceTcS "matchClassInst" $ text "pred =" <+> ppr pred <+> char '{' + ; local_res <- matchLocalInst pred loc + ; case local_res of + OneInst {} -> -- See Note [Local instances and incoherence] + do { traceTcS "} matchClassInst local match" $ ppr local_res + ; return local_res } + + NotSure -> -- In the NotSure case for local instances + -- we don't want to try global instances + do { traceTcS "} matchClassInst local not sure" empty + ; return local_res } + + NoInstance -- No local instances, so try global ones + -> 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: + instance P x => Q [x] + instance (x ~ y) => R y [x] + + wob :: forall a b. (Q [b], R b a) => a -> Int + + g :: forall a. Q [a] => [a] -> Int + g x = wob x + +From 'g' we get the implication constraint: + forall a. Q [a] => (Q [beta], R beta [a]) +If we react (Q [beta]) with its top-level axiom, we end up with a +(P beta), which we have no way of discharging. On the other hand, +if we react R beta [a] with the top-level we get (beta ~ a), which +is solvable and can help us rewrite (Q [beta]) to (Q [a]) which is +now solvable by the given Q [a]. + +The partial solution is that: + In matchClassInst (and thus in topReact), we return a matching + instance only when there is no Given in the inerts which is + unifiable to this particular dictionary. + + We treat any meta-tyvar as "unifiable" for this purpose, + *including* untouchable ones. But not skolems like 'a' in + the implication constraint above. + +The end effect is that, much as we do for overlapping instances, we +delay choosing a class instance if there is a possibility of another +instance OR a given to match our constraint later on. This fixes +tickets #4981 and #5002. + +Other notes: + +* The check is done *first*, so that it also covers classes + with built-in instance solving, such as + - constraint tuples + - natural numbers + - Typeable + +* 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 + constraints, but it is possible. I've added a test case in + typecheck/should-compile/GivenOverlapping.hs + +* Another "live" example is #10195; another is #10177. + +* We ignore the overlap problem if -XIncoherentInstances is in force: + see #6002 for a worked-out example where this makes a + difference. + +* Moreover notice that our goals here are different than the goals of + the top-level overlapping checks. There we are interested in + validating the following principle: + + If we inline a function f at a site where the same global + instance environment is available as the instance environment at + the definition site of f then we should get the same behaviour. + + But for the Given Overlap check our goal is just related to completeness of + constraint solving. + +* The solution is only a partial one. Consider the above example with + g :: forall a. Q [a] => [a] -> Int + g x = let v = wob x + in v + and suppose we have -XNoMonoLocalBinds, so that we attempt to find the most + general type for 'v'. When generalising v's type we'll simplify its + Q [alpha] constraint, but we don't have Q [a] in the 'givens', so we + will use the instance declaration after all. #11948 was a case + in point. + +All of this is disgustingly delicate, so to discourage people from writing +simplifiable class givens, we warn about signatures that contain them; +see GHC.Tc.Validity Note [Simplifiable given constraints]. + + +Note [Local instances and incoherence] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + f :: forall b c. (Eq b, forall a. Eq a => Eq (c a)) + => c b -> Bool + f x = x==x + +We get [W] Eq (c b), and we must use the local instance to solve it. + +BUT that wanted also unifies with the top-level Eq [a] instance, +and Eq (Maybe a) etc. We want the local instance to "win", otherwise +we can't solve the wanted at all. So we mark it as Incohherent. +According to Note [Rules for instance lookup] in GHC.Core.InstEnv, that'll +make it win even if there are other instances that unify. + +Moreover this is not a hack! The evidence for this local instance +will be constructed by GHC at a call site... from the very instances +that unify with it here. It is not like an incoherent user-written +instance which might have utterly different behaviour. + +Consider f :: Eq a => blah. If we have [W] Eq a, we certainly +get it from the Eq a context, without worrying that there are +lots of top-level instances that unify with [W] Eq a! We'll use +those instances to build evidence to pass to f. That's just the +nullary case of what's happening here. +-} + +matchLocalInst :: TcPredType -> CtLoc -> TcS ClsInstResult +-- Look up the predicate in Given quantified constraints, +-- which are effectively just local instance declarations. +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 = EvCanonical + , cir_what = LocalInstance } + ; traceTcS "Best local instance found:" $ + vcat [ text "body_pred:" <+> ppr body_pred + , text "result:" <+> ppr result + , text "matches:" <+> ppr matches + , text "unifs:" <+> ppr unifs ] + ; return result } + + ; mb_best -> + do { traceTcS "Multiple local instances; not committing to any" + $ vcat [ text "body_pred:" <+> ppr body_pred + , text "matches:" <+> ppr matches + , text "unifs:" <+> ppr unifs + , text "best_match:" <+> ppr mb_best ] + ; return NotSure }}}}} + where + body_pred_tv_set = tyCoVarsOfType body_pred + + mk_instDFun :: (CtEvidence, [DFunInstType]) -> TcS InstDFun + mk_instDFun (ev, tys) = + let dfun_id = ctEvEvId ev + in do { (tys, theta) <- instDFunType (ctEvEvId ev) tys + ; return (dfun_id, tys, theta) } + + -- Compute matching and unifying local instances + match_local_inst :: InertSet + -> [QCInst] + -> ( [(CtEvidence, [DFunInstType])] + , [(CtEvidence, [DFunInstType])] ) + match_local_inst _inerts [] + = ([], []) + match_local_inst inerts (qci@(QCI { qci_tvs = qtvs + , qci_body = qbody + , qci_ev = qev }) + : 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 qbody body_pred + , let match = (qev, map (lookupVarEnv tv_subst) qtvs) + = (match:matches, unifs) + + | otherwise + = 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) + where + qloc = ctEvLoc qev + qtv_set = mkVarSet qtvs + (matches, unifs) = match_local_inst inerts qcis + this_unif + | Just subst <- mightEqualLater inerts qbody qloc body_pred loc + = Just (qev, map (lookupTyVar subst) qtvs) + | otherwise + = Nothing + + combine Nothing us = us + combine (Just u) us = u : us + +-- | Instance dictionary function and type. +type InstDFun = (DFunId, [TcType], TcThetaType) + +-- | Try to find a local quantified instance that dominates all others, +-- i.e. which has a weaker instance context than all the others. +-- +-- See Note [Use only the best matching quantified constraint]. +dominatingMatch :: [InstDFun] -> Maybe InstDFun +dominatingMatch matches = + listToMaybe $ mapMaybe (uncurry go) (holes matches) + -- listToMaybe: arbitrarily pick any one context that is weaker than + -- all others, e.g. so that we can handle [Eq a, Num a] vs [Num a, Eq a] + -- (see test case T22223). + + where + go :: InstDFun -> [InstDFun] -> Maybe InstDFun + go this [] = Just this + go this@(_,_,this_theta) ((_,_,other_theta):others) + | this_theta `impliedBySCs` other_theta + = go this others + | otherwise + = Nothing + +-- | Whether a collection of constraints is implied by another collection, +-- according to a simple superclass check. +-- +-- See Note [When does a quantified instance dominate another?]. +impliedBySCs :: TcThetaType -> TcThetaType -> Bool +impliedBySCs c1 c2 = all in_c2 c1 + where + in_c2 :: TcPredType -> Bool + in_c2 pred = any (pred `tcEqType`) c2_expanded + + c2_expanded :: [TcPredType] -- Includes all superclasses + c2_expanded = [ q | p <- c2, q <- p : transSuperClasses p ] + + +{- Note [When does a quantified instance dominate another?] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When matching local quantified instances, it's useful to be able to pick +the one with the weakest precondition, e.g. if one has both + + [G] d1: forall a b. ( Eq a, Num b, C a b ) => D a b + [G] d2: forall a . C a Int => D a Int + [W] {w}: D a Int + +Then it makes sense to use d2 to solve w, as doing so we end up with a strictly +weaker proof obligation of `C a Int`, compared to `(Eq a, Num Int, C a Int)` +were we to use d1. + +In theory, to compute whether one context implies another, we would need to +recursively invoke the constraint solver. This is expensive, so we instead do +a simple check using superclasses, implemented in impliedBySCs. + +Examples: + + - [Eq a] is implied by [Ord a] + - [Ord a] is not implied by [Eq a], + - any context is implied by itself, + - the empty context is implied by any context. + +Note [Use only the best matching quantified constraint] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider (#20582) the ambiguity check for + (forall a. Ord (m a), forall a. Semigroup a => Eq (m a)) => m Int + +Because of eager expansion of given superclasses, we get + [G] d1: forall a. Ord (m a) + [G] d2: forall a. Eq (m a) + [G] d3: forall a. Semigroup a => Eq (m a) + + [W] {w1}: forall a. Ord (m a) + [W] {w2}: forall a. Semigroup a => Eq (m a) + +The first wanted is solved straightforwardly. But the second wanted +matches *two* local instances: d2 and d3. Our general rule around multiple local +instances is that we refuse to commit to any of them. However, that +means that our type fails the ambiguity check. That's bad: the type +is perfectly fine. (This actually came up in the wild, in the streamly +library.) + +The solution is to prefer local instances which are easier to prove, meaning +that they have a weaker precondition. In this case, the empty context +of d2 is a weaker constraint than the "Semigroup a" context of d3, so we prefer +using it when proving w2. This allows us to pass the ambiguity check here. + +Our criterion for solving a Wanted by matching local quantified instances is +thus as follows: + + - There is a matching local quantified instance that dominates all others + matches, in the sense of [When does a quantified instance dominate another?]. + Any such match do, we pick it arbitrarily (the T22223 example below says why). + - This local quantified instance also dominates all the unifiers, as we + wouldn't want to commit to a single match when we might have multiple, + genuinely different matches after further unification takes place. + +Some other examples: + + + #15244: + + f :: (C g, D g) => .... + class S g => C g where ... + class S g => D g where ... + class (forall a. Eq a => Eq (g a)) => S g where ... + + Here, in f's RHS, there are two identical quantified constraints + available, one via the superclasses of C and one via the superclasses + of D. Given that each implies the other, we pick one arbitrarily. + + + #22216: + + class Eq a + class Eq a => Ord a + class (forall b. Eq b => Eq (f b)) => Eq1 f + class (Eq1 f, forall b. Ord b => Ord (f b)) => Ord1 f + + Suppose we have + + [G] d1: Ord1 f + [G] d2: Eq a + [W] {w}: Eq (f a) + + Superclass expansion of d1 gives us: + + [G] d3 : Eq1 f + [G] d4 : forall b. Ord b => Ord (f b) + + expanding d4 and d5 gives us, respectively: + + [G] d5 : forall b. Eq b => Eq (f b) + [G] d6 : forall b. Ord b => Eq (f b) + + Now we have two matching local instances that we could use when solving the + Wanted. However, it's obviously silly to use d6, given that d5 provides us with + as much information, with a strictly weaker precondition. So we pick d5 to solve + w. If we chose d6, we would get [W] Ord a, which in this case we can't solve. + + + #22223: + + [G] forall a b. (Eq a, Ord b) => C a b + [G] forall a b. (Ord b, Eq a) => C a b + [W] C x y + + Here we should be free to pick either quantified constraint, as they are + equivalent up to re-ordering of the constraints in the context. + See also Note [Do not add duplicate quantified instances] + in GHC.Tc.Solver.Monad. + +Test cases: + typecheck/should_compile/T20582 + quantified-constraints/T15244 + quantified-constraints/T22216{a,b,c,d,e} + quantified-constraints/T22223 + +Historical note: a previous solution was to instead pick the local instance +with the least superclass depth (see Note [Replacement vs keeping]), +but that doesn't work for the example from #22216. +-} + +{- ********************************************************************* +* * +* Functional dependencies, instantiation of equations +* * +************************************************************************ + +When we spot an equality arising from a functional dependency, +we now use that equality (a "wanted") to rewrite the work-item +constraint right away. This avoids two dangers + + Danger 1: If we send the original constraint on down the pipeline + it may react with an instance declaration, and in delicate + situations (when a Given overlaps with an instance) that + may produce new insoluble goals: see #4952 + + Danger 2: If we don't rewrite the constraint, it may re-react + with the same thing later, and produce the same equality + again --> termination worries. + +To achieve this required some refactoring of GHC.Tc.Instance.FunDeps (nicer +now!). + +Note [FunDep and implicit parameter reactions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Currently, our story of interacting two dictionaries (or a dictionary +and top-level instances) for functional dependencies, and implicit +parameters, is that we simply produce new Wanted equalities. So for example + + class D a b | a -> b where ... + Inert: + [G] d1 : D Int Bool + WorkItem: + [W] d2 : D Int alpha + + We generate the extra work item + [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: + [W] d2' : D Int Bool + d2 := d2' |> D Int cv + Now d2' can be discharged from d1 + +We could be more aggressive and try to *immediately* solve the dictionary +using those extra equalities. + +If that were the case with the same inert set and work item we might discard +d2 directly: + + [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: + [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: + [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 +"aggressive" approach would be much easier to implement. + +Note [Fundeps with instances, and equality orientation] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +This Note describes a delicate interaction that constrains the orientation of +equalities. This one is about fundeps, but the /exact/ same thing arises for +type-family injectivity constraints: see Note [Improvement orientation]. + +doTopFunDepImprovement compares the constraint with all the instance +declarations, to see if we can produce any equalities. E.g + class C2 a b | a -> b + instance C Int Bool +Then the constraint (C Int ty) generates the equality [W] ty ~ Bool. + +There is a nasty corner in #19415 which led to the typechecker looping: + class C s t b | s -> t + instance ... => C (T kx x) (T ky y) Int + T :: forall k. k -> Type + + work_item: dwrk :: C (T @ka (a::ka)) (T @kb0 (b0::kb0)) Char + where kb0, b0 are unification vars + + ==> {doTopFunDepImprovement: compare work_item with instance, + generate /fresh/ unification variables kfresh0, yfresh0, + emit a new Wanted, and add dwrk to inert set} + + Suppose we emit this new Wanted from the fundep: + [W] T kb0 (b0::kb0) ~ T kfresh0 (yfresh0::kfresh0) + + ==> {solve that equality kb0 := kfresh0, b0 := yfresh0} + Now kick out dwrk, since it mentions kb0 + But now we are back to the start! Loop! + +NB1: This example relies on an instance that does not satisfy the + coverage condition (although it may satisfy the weak coverage + condition), and hence whose fundeps generate fresh unification + variables. Not satisfying the coverage condition is known to + lead to termination trouble, but in this case it's plain silly. + +NB2: In this example, the third parameter to C ensures that the + instance doesn't actually match the Wanted, so we can't use it to + solve the Wanted + +We solve the problem by (#21703): + + carefully orienting the new Wanted so that all the + freshly-generated unification variables are on the LHS. + + Thus we call unifyWanteds on + T kfresh0 (yfresh0::kfresh0) ~ T kb0 (b0::kb0) + and /NOT/ + T kb0 (b0::kb0) ~ T kfresh0 (yfresh0::kfresh0) + +Now we'll unify kfresh0:=kb0, yfresh0:=b0, and all is well. The general idea +is that we want to preferentially eliminate those freshly-generated +unification variables, rather than unifying older variables, which causes +kick-out etc. + +Keeping younger variables on the left also gives very minor improvement in +the compiler performance by having less kick-outs and allocations (-0.1% on +average). Indeed Historical Note [Eliminate younger unification variables] +in GHC.Tc.Utils.Unify describes an earlier attempt to do so systematically, +apparently now in abeyance. + +But this is is a delicate solution. We must take care to /preserve/ +orientation during solving. Wrinkles: + +(W1) We start with + [W] T kfresh0 (yfresh0::kfresh0) ~ T kb0 (b0::kb0) + Decompose to + [W] kfresh0 ~ kb0 + [W] (yfresh0::kfresh0) ~ (b0::kb0) + 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 + well as a now-homogeneous type equality + [W] kco : kfresh0 ~ kb0 + [W] (yfresh0::kfresh0) ~ (b0::kb0) |> (sym kco) + Preserve orientation in canEqCanLHSHetero!! (Failing to + preserve orientation here was the immediate cause of #21703.) + +(W3) There is a potential interaction with the swapping done by + GHC.Tc.Utils.Unify.swapOverTyVars. We think it's fine, but it's + a slight worry. See especially Note [TyVar/TyVar orientation] in + that module. + +The trouble is that "preserving orientation" is a rather global invariant, +and sometimes we definitely do want to swap (e.g. Int ~ alpha), so we don't +even have a precise statement of what the invariant is. The advantage +of the preserve-orientation plan is that it is extremely cheap to implement, +and apparently works beautifully. + +--- Alternative plan (1) --- +Rather than have an ill-defined invariant, another possiblity is to +elminate those fresh unification variables at birth, when generating +the new fundep-inspired equalities. + +The key idea is to call `instFlexiX` in `emitFunDepWanteds` on only those +type variables that are guaranteed to give us some progress. This means we +have to locally (without calling emitWanteds) identify the type variables +that do not give us any progress. In the above example, we _know_ that +emitting the two wanteds `kco` and `co` is fruitless. + + Q: How do we identify such no-ops? + + 1. Generate a matching substitution from LHS to RHS + ɸ = [kb0 :-> k0, b0 :-> y0] + 2. Call `instFlexiX` on only those type variables that do not appear in the domain of ɸ + ɸ' = instFlexiX ɸ (tvs - domain ɸ) + 3. Apply ɸ' on LHS and then call emitWanteds + unifyWanteds ... (subst ɸ' LHS) RHS + +Why will this work? The matching substitution ɸ will be a best effort +substitution that gives us all the easy solutions. It can be generated with +modified version of `Core/Unify.unify_tys` where we run it in a matching mode +and never generate `SurelyApart` and always return a `MaybeApart Subst` +instead. + +The same alternative plan would work for type-family injectivity constraints: +see Note [Improvement orientation] in GHC.Tc.Solver.Equality. +--- End of Alternative plan (1) --- + +--- Alternative plan (2) --- +We could have a new flavour of TcTyVar (like `TauTv`, `TyVarTv` etc; see GHC.Tc.Utils.TcType.MetaInfo) +for the fresh unification variables introduced by functional dependencies. Say `FunDepTv`. Then in +GHC.Tc.Utils.Unify.swapOverTyVars we could arrange to keep a `FunDepTv` on the left if possible. +Looks possible, but it's one more complication. +--- End of Alternative plan (2) --- + + +--- Historical note: Failed Alternative Plan (3) --- +Previously we used a flag `cc_fundeps` in `CDictCan`. It would flip to False +once we used a fun dep to hint the solver to break and to stop emitting more +wanteds. This solution was not complete, and caused a failures while trying +to solve for transitive functional dependencies (test case: T21703) +-- End of Historical note: Failed Alternative Plan (3) -- + +Note [Do fundeps last] +~~~~~~~~~~~~~~~~~~~~~~ +Consider T4254b: + class FD a b | a -> b where { op :: a -> b } + + instance FD Int Bool + + foo :: forall a b. (a~Int,FD a b) => a -> Bool + foo = op + +(DFL1) Try local fundeps first. + From the ambiguity check on the type signature we get + [G] FD Int b + [W] FD Int beta + Interacting these gives beta:=b; then we start again and solve without + trying fundeps between the new [W] FD Int b and the top-level instance. + If we did, we'd generate [W] b ~ Bool, which fails. + +(DFL2) Try solving from top-level instances before fundeps + From the definition `foo = op` we get + [G] FD Int b + [W] FD Int Bool + We solve this from the top level instance before even trying fundeps. + If we did try fundeps, we'd generate [W] b ~ Bool, which fails. + + +Note [Weird fundeps] +~~~~~~~~~~~~~~~~~~~~ +Consider class Het a b | a -> b where + het :: m (f c) -> a -> m b + + class GHet (a :: * -> *) (b :: * -> *) | a -> b + instance GHet (K a) (K [a]) + instance Het a b => GHet (K a) (K b) + +The two instances don't actually conflict on their fundeps, +although it's pretty strange. So they are both accepted. Now +try [W] GHet (K Int) (K Bool) +This triggers fundeps from both instance decls; + [W] K Bool ~ K [a] + [W] K Bool ~ K beta +And there's a risk of complaining about Bool ~ [a]. But in fact +the Wanted matches the second instance, so we never get as far +as the fundeps. + +#7875 is a case in point. +-} + +doLocalFunDepImprovement :: DictCt -> SolverStage () +-- Add wanted constraints from type-class functional dependencies. +doLocalFunDepImprovement dict_ct@(DictCt { di_ev = work_ev, di_cls = cls }) + = Stage $ + do { inerts <- getInertCans + ; imp <- foldlM add_fds False (findDictsByClass (inert_dicts inerts) cls) + ; if imp then startAgainWith (CDictCan dict_ct) + else continueWith () } + where + work_pred = ctEvPred work_ev + work_loc = ctEvLoc work_ev + + add_fds :: Bool -> DictCt -> TcS Bool + add_fds so_far (DictCt { di_ev = inert_ev }) + | isGiven work_ev && isGiven inert_ev + -- Do not create FDs from Given/Given interactions: See Note [No Given/Given fundeps] + = return so_far + | otherwise + = do { traceTcS "doLocalFunDepImprovement" (vcat + [ ppr work_ev + , pprCtLoc work_loc, ppr (isGivenLoc work_loc) + , pprCtLoc inert_loc, ppr (isGivenLoc inert_loc) + , pprCtLoc derived_loc, ppr (isGivenLoc derived_loc) ]) + + ; unifs <- emitFunDepWanteds work_ev $ + improveFromAnother (derived_loc, inert_rewriters) + inert_pred work_pred + ; return (so_far || unifs) + } + where + inert_pred = ctEvPred inert_ev + inert_loc = ctEvLoc inert_ev + inert_rewriters = ctEvRewriters inert_ev + derived_loc = work_loc { ctl_depth = ctl_depth work_loc `maxSubGoalDepth` + ctl_depth inert_loc + , ctl_origin = FunDepOrigin1 work_pred + (ctLocOrigin work_loc) + (ctLocSpan work_loc) + inert_pred + (ctLocOrigin inert_loc) + (ctLocSpan inert_loc) } + +doTopFunDepImprovement :: DictCt -> SolverStage () +-- Try to functional-dependency improvement between the constraint +-- and the top-level instance declarations +-- See Note [Fundeps with instances, and equality orientation] +-- See also Note [Weird fundeps] +doTopFunDepImprovement dict_ct@(DictCt { di_ev = ev, di_cls = cls, di_tys = xis }) + | isGiven ev -- No improvement for Givens + = Stage $ continueWith () + | otherwise + = Stage $ + do { traceTcS "try_fundeps" (ppr dict_ct) + ; instEnvs <- getInstEnvs + ; let fundep_eqns = improveFromInstEnv instEnvs mk_ct_loc cls xis + ; imp <- emitFunDepWanteds ev fundep_eqns + ; if imp then startAgainWith (CDictCan dict_ct) + else continueWith () } + where + dict_pred = mkClassPred cls xis + dict_loc = ctEvLoc ev + dict_origin = ctLocOrigin dict_loc + + mk_ct_loc :: ClsInst -- The instance decl + -> (CtLoc, RewriterSet) + 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) + + +{- ********************************************************************* +* * +* Superclasses +* * +********************************************************************* -} + +{- Note [The superclass story] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We need to add superclass constraints for two reasons: + +* For givens [G], they give us a route to proof. E.g. + f :: Ord a => a -> Bool + f x = x == x + We get a Wanted (Eq a), which can only be solved from the superclass + of the Given (Ord a). + +* For wanteds [W], they may give useful + functional dependencies. E.g. + class C a b | a -> b where ... + class C a b => D a b where ... + Now a [W] constraint (D Int beta) has (C Int beta) as a superclass + and that might tell us about beta, via C's fundeps. We can get this + by generating a [W] (C Int beta) constraint. We won't use the evidence, + but it may lead to unification. + +See Note [Why adding superclasses can help]. + +For these reasons we want to generate superclass constraints for both +Givens and Wanteds. But: + +* (Minor) they are often not needed, so generating them aggressively + is a waste of time. + +* (Major) if we want recursive superclasses, there would be an infinite + number of them. Here is a real-life example (#10318); + + class (Frac (Frac a) ~ Frac a, + Fractional (Frac a), + IntegralDomain (Frac a)) + => IntegralDomain a where + type Frac a :: * + + Notice that IntegralDomain has an associated type Frac, and one + of IntegralDomain's superclasses is another IntegralDomain constraint. + +So here's the plan: + +1. Eagerly generate superclasses for given (but not wanted) + constraints; see Note [Eagerly expand given superclasses]. + 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, + mkStrictSuperClasses expands eagerly, but has a conservative + termination condition: see Note [Expanding superclasses] in GHC.Tc.Utils.TcType. + +2. Solve the wanteds as usual, but do no further expansion of + superclasses for canonical CDictCans in solveSimpleGivens or + solveSimpleWanteds; Note [Danger of adding superclasses during solving] + + However, /do/ continue to eagerly expand superclasses for new /given/ + /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]. + +3. If we have any remaining unsolved wanteds + (see Note [When superclasses help] in GHC.Tc.Types.Constraint) + try harder: take both the Givens and Wanteds, and expand + superclasses again. See the calls to expandSuperClasses in + GHC.Tc.Solver.simpl_loop and solveWanteds. + + This may succeed in generating (a finite number of) extra Givens, + and extra Wanteds. Both may help the proof. + +3a An important wrinkle: only expand Givens from the current level. + Two reasons: + - We only want to expand it once, and that is best done at + the level it is bound, rather than repeatedly at the leaves + of the implication tree + - We may be inside a type where we can't create term-level + evidence anyway, so we can't superclass-expand, say, + (a ~ b) to get (a ~# b). This happened in #15290. + +4. Go round to (2) again. This loop (2,3,4) is implemented + in GHC.Tc.Solver.simpl_loop. + +The cc_pend_sc field in a CDictCan records whether the superclasses of +this constraint have been expanded. Specifically, in Step 3 we only +expand superclasses for constraints with cc_pend_sc > 0 +(i.e. isPendingScDict holds). +See Note [Expanding Recursive Superclasses and ExpansionFuel] + +Why do we do this? Two reasons: + +* To avoid repeated work, by repeatedly expanding the superclasses of + same constraint, + +* To terminate the above loop, at least in the -XNoUndecidableSuperClasses + case. If there are recursive superclasses we could, in principle, + expand forever, always encountering new constraints. + +When we take a CNonCanonical or CIrredCan, but end up classifying it +as a CDictCan, we set the cc_pend_sc flag to False. + +Note [Superclass loops] +~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we have + class C a => D a + class D a => C a + +Then, when we expand superclasses, we'll get back to the self-same +predicate, so we have reached a fixpoint in expansion and there is no +point in fruitlessly expanding further. This case just falls out from +our strategy. Consider + f :: C a => a -> Bool + f x = x==x +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 +keep the inert item (d1) if possible: see Note [Replacement vs keeping] in +GHC.Tc.Solver.InertSet. So d3 dies a quick, happy death. + +Note [Eagerly expand given superclasses] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In step (1) of Note [The superclass story], why do we eagerly expand +Given superclasses by one layer? (By "one layer" we mean expand transitively +until you meet the same class again -- the conservative criterion embodied +in expandSuperClasses. So a "layer" might be a whole stack of superclasses.) +We do this eagerly for Givens mainly because of some very obscure +cases like this: + + instance Bad a => Eq (T a) + + f :: (Ord (T a)) => blah + f x = ....needs Eq (T a), Ord (T a).... + +Here if we can't satisfy (Eq (T a)) from the givens we'll use the +instance declaration; but then we are stuck with (Bad a). Sigh. +This is really a case of non-confluent proofs, but to stop our users +complaining we expand one layer in advance. + +See Note [Instance and Given overlap]. + +We also want to do this if we have + + f :: F (T a) => blah + +where + type instance F (T a) = Ord (T a) + +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 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 canDictCt. + +Note [Why adding superclasses can help] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Examples of how adding superclasses can help: + + --- Example 1 + class C a b | a -> b + Suppose we want to solve + [G] C a b + [W] C a beta + Then adding [W] beta~b will let us solve it. + + -- Example 2 (similar but using a type-equality superclass) + class (F a ~ b) => C a b + And try to sllve: + [G] C a b + [W] C a beta + Follow the superclass rules to add + [G] F a ~ b + [W] F a ~ beta + Now we get [W] beta ~ b, and can solve that. + + -- Example (tcfail138) + class L a b | a -> b + class (G a, L a b) => C a b + + instance C a b' => G (Maybe a) + instance C a b => C (Maybe a) a + instance L (Maybe a) a + + When solving the superclasses of the (C (Maybe a) a) instance, we get + [G] C a b, and hence by superclasses, [G] G a, [G] L a b + [W] G (Maybe a) + Use the instance decl to get + [W] C a beta + Generate its superclass + [W] L a beta. Now using fundeps, combine with [G] L a b to get + [W] beta ~ b + which is what we want. + +Note [Danger of adding superclasses during solving] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Here's a serious, but now out-dated example, from #4497: + + class Num (RealOf t) => Normed t + type family RealOf x + +Assume the generated wanted constraint is: + [W] RealOf e ~ e + [W] Normed e + +If we were to be adding the superclasses during simplification we'd get: + [W] RealOf e ~ e + [W] Normed e + [W] RealOf e ~ fuv + [W] Num fuv +==> + e := fuv, Num fuv, Normed fuv, RealOf fuv ~ fuv + +While looks exactly like our original constraint. If we add the +superclass of (Normed fuv) again we'd loop. By adding superclasses +definitely only once, during canonicalisation, this situation can't +happen. + +Note [Nested quantified constraint superclasses] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider (typecheck/should_compile/T17202) + + class C1 a + class (forall c. C1 c) => C2 a + class (forall b. (b ~ F a) => C2 a) => C3 a + +Elsewhere in the code, we get a [G] g1 :: C3 a. We expand its superclass +to get [G] g2 :: (forall b. (b ~ F a) => C2 a). This constraint has a +superclass, as well. But we now must be careful: we cannot just add +(forall c. C1 c) as a Given, because we need to remember g2's context. +That new constraint is Given only when forall b. (b ~ F a) is true. + +It's tempting to make the new Given be (forall b. (b ~ F a) => forall c. C1 c), +but that's problematic, because it's nested, and ForAllPred is not capable +of representing a nested quantified constraint. (We could change ForAllPred +to allow this, but the solution in this Note is much more local and simpler.) + +So, we swizzle it around to get (forall b c. (b ~ F a) => C1 c). + +More generally, if we are expanding the superclasses of + g0 :: forall tvs. theta => cls tys +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 +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. + sel_id tys (g0 tvs theta_ids) sc_tvs sc_theta_ids + +Actually, we cheat a bit by eta-reducing: note that sc_theta_ids are both the +last bound variables and the last arguments. This avoids the need to produce +the sc_theta_ids at all. So our final construction is + + 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] +-- The loop-breaking here follows Note [Expanding superclasses] in GHC.Tc.Utils.TcType +-- Specifically, for an incoming (C t) constraint, we return all of (C t)'s +-- superclasses, up to /and including/ the first repetition of C +-- +-- Example: class D a => C a +-- class C [a] => D a +-- makeSuperClasses (C x) will return (D x, C [x]) +-- +-- NB: the incoming constraint's superclass will consume a unit of fuel +-- Preconditions on `cts`: 1. They are either `CDictCan` or `CQuantCan` +-- 2. Their fuel (stored in cc_pend_sc or qci_pend_sc) is > 0 +makeSuperClasses cts = concatMapM go cts + where + 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_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) + go ct = pprPanic "makeSuperClasses" (ppr ct) + +mkStrictSuperClasses + :: ExpansionFuel -> CtEvidence + -> [TyVar] -> ThetaType -- These two args are non-empty only when taking + -- superclasses of a /quantified/ constraint + -> Class -> [Type] -> TcS [Ct] +-- Return constraints for the strict superclasses of +-- ev :: forall as. theta => cls tys +-- Precondition: fuel > 0 +-- Postcondition: fuel for recursive superclass ct is one unit less than cls fuel +mkStrictSuperClasses fuel ev tvs theta cls tys + = mk_strict_superclasses (consumeFuel fuel) (unitNameSet (className cls)) + ev tvs theta cls tys + +mk_strict_superclasses :: ExpansionFuel -> NameSet -> CtEvidence + -> [TyVar] -> ThetaType + -> Class -> [Type] -> TcS [Ct] +-- Always return the immediate superclasses of (cls tys); +-- and expand their superclasses, provided none of them are in rec_clss +-- nor are repeated +-- The caller of this function is supposed to perform fuel book keeping +-- Precondition: fuel >= 0 +mk_strict_superclasses _ _ _ _ _ cls _ + | isEqualityClass cls -- See (EQC1) in Note [Solving equality classes] + = return [] + +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 + + do_one_given sel_id + | isUnliftedType sc_pred + -- NB: class superclasses are never representation-polymorphic, + -- so isUnliftedType is OK here. + , not (null tvs && null theta) + = -- See Note [Equality superclasses in quantified constraints] + return [] + | otherwise + = do { given_ev <- newGivenEvVar sc_loc $ + mk_given_desc sel_id sc_pred + ; assertFuelPrecondition fuel $ + 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, EvExpr swizzled_evterm) + where + (sc_tvs, sc_rho) = splitForAllTyCoVars sc_pred + (sc_theta, sc_inner_pred) = splitFunTys sc_rho + + all_tvs = tvs `chkAppend` sc_tvs + all_theta = theta `chkAppend` (map scaledThing sc_theta) + swizzled_pred = mkInfSigmaTy all_tvs all_theta sc_inner_pred + + -- evar :: forall tvs. theta => cls tys + -- sel_id :: forall cls_tvs. cls cls_tvs + -- => forall sc_tvs. sc_theta => sc_inner_pred + -- swizzled_evterm :: forall tvs sc_tvs. theta => sc_theta => sc_inner_pred + 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) } + -- isCTupleClass: we don't want tuples to mess up the size calculations + -- of Note [Solving superclass constraints]. For tuple predicates, this + -- matters, because their size can be large, and we don't want to add a + -- big class to the size of the dictionaries in the chain. When we get + -- down to a base predicate, we'll include its size. See #10335. + -- See Note [Solving tuple constraints] + + -- See Note [Solving superclass constraints] in GHC.Tc.TyCl.Instance + -- for explanation of GivenSCOrigin and Note [Replacement vs keeping] in + -- GHC.Tc.Solver.InertSet for why we need depths + mk_sc_origin :: CtOrigin -> CtOrigin + mk_sc_origin (GivenSCOrigin skol_info sc_depth already_blocked) + = GivenSCOrigin skol_info (sc_depth + 1) + (already_blocked || newly_blocked skol_info) + + mk_sc_origin (GivenOrigin skol_info) + = -- These cases do not already have a superclass constraint: depth starts at 1 + GivenSCOrigin skol_info 1 (newly_blocked skol_info) + + mk_sc_origin other_orig = pprPanic "Given constraint without given origin" $ + ppr evar $$ ppr other_orig + + newly_blocked (InstSkol _ head_size) = isJust (this_size `ltPatersonSize` head_size) + newly_blocked _ = False + +-- Wanted case +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] + + | otherwise -- Wanted case, just add Wanted superclasses + -- that can lead to improvement. + = assertPpr (null tvs && null theta) (ppr tvs $$ ppr theta) $ + concatMapM do_one (immSuperClasses cls tys) + where + 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 rws sc_pred + ; mk_superclasses fuel rec_clss (CtWanted sc_ev) [] [] sc_pred } + +{- Note [Improvement from Ground Wanteds] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose class C b a => D a b +and consider + [W] D Int Bool +Is there any point in emitting [W] C Bool Int? No! The only point of +emitting superclass constraints for W constraints is to get +improvement, extra unifications that result from functional +dependencies. See Note [Why adding superclasses can help] above. + +But no variables means no improvement; case closed. +-} + +mk_superclasses :: ExpansionFuel -> NameSet -> CtEvidence + -> [TyVar] -> ThetaType -> PredType -> TcS [Ct] +-- Return this constraint, plus its superclasses, if any +-- Precondition: fuel >= 0 +mk_superclasses fuel rec_clss ev tvs theta pred + | ClassPred cls tys <- classifyPredType pred + = assertFuelPrecondition fuel $ + mk_superclasses_of fuel rec_clss ev tvs theta cls tys + + | otherwise -- Superclass is not a class predicate + = return [mkNonCanonical ev] + +mk_superclasses_of :: ExpansionFuel -> NameSet -> CtEvidence + -> [TyVar] -> ThetaType -> Class -> [Type] + -> TcS [Ct] +-- Always return this class constraint, +-- and expand its superclasses +-- Precondition: fuel >= 0 +mk_superclasses_of fuel rec_clss ev tvs theta cls tys + | loop_found = do { traceTcS "mk_superclasses_of: loop" (ppr cls <+> ppr tys) + ; assertFuelPrecondition fuel $ return [mk_this_ct fuel] } + -- cc_pend_sc of returning ct = fuel + | otherwise = do { traceTcS "mk_superclasses_of" (vcat [ ppr cls <+> ppr tys + , ppr (isCTupleClass cls) + , ppr rec_clss + ]) + ; sc_cts <- assertFuelPrecondition fuel $ + mk_strict_superclasses fuel rec_clss' ev tvs theta cls tys + ; return (mk_this_ct doNotExpand : sc_cts) } + -- doNotExpand: we have expanded this cls's superclasses, so + -- exhaust the associated constraint's fuel, + -- to avoid duplicate work + where + cls_nm = className cls + loop_found = not (isCTupleClass cls) && cls_nm `elemNameSet` rec_clss + -- Tuples never contribute to recursion, and can be nested + rec_clss' = rec_clss `extendNameSet` cls_nm + + mk_this_ct :: ExpansionFuel -> Ct + -- We can't use CNonCanonical here because we need to tradk the fuel + mk_this_ct fuel | null tvs, null theta + = CDictCan (DictCt { di_ev = ev, di_cls = cls + , di_tys = tys, di_pend_sc = fuel }) + -- 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_theta = theta + , qci_body = mkClassPred cls tys + , qci_ev = ev, qci_pend_sc = fuel }) + + +{- Note [Equality superclasses in quantified constraints] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider (#15359, #15593, #15625) + f :: (forall a. theta => a ~ b) => stuff + +It's a bit odd to have a local, quantified constraint for `(a~b)`, +but some people want such a thing (see the tickets). And for +Coercible it is definitely useful + f :: forall m. (forall p q. Coercible p q => Coercible (m p) (m q))) + => stuff + +Moreover it's not hard to arrange; we just need to look up /equality/ +constraints in the quantified-constraint environment, which we do in +GHC.Tc.Solver.Equality.tryQCsEqCt. + +There is a wrinkle though, in the case where 'theta' is empty, so +we have + f :: (forall a. a~b) => stuff + +Now, potentially, the superclass machinery kicks in, in +makeSuperClasses, giving us a a second quantified constraint + (forall a. a ~# b) +BUT this is an unboxed value! And nothing has prepared us for +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. + +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 +which looks for primitive equalities specially in the quantified +constraints. + +See also Note [Evidence for quantified constraints] in GHC.Core.Predicate. +-} diff --git a/GHC/Tc/Solver/Equality.hs b/GHC/Tc/Solver/Equality.hs new file mode 100644 --- /dev/null +++ b/GHC/Tc/Solver/Equality.hs @@ -0,0 +1,3467 @@ +{-# LANGUAGE CPP #-} +{-# 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 + inert_loc = ctEvLoc inert_ev + inert_rewriters = ctEvRewriters inert_ev + loc = eqn_loc { ctl_depth = ctl_depth inert_loc `maxSubGoalDepth` + ctl_depth work_loc } + +{- Note [Type inference for type families with injectivity] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we have a type family with an injectivity annotation: + type family F a b = r | r -> b + +Then if we have an equality like F s1 t1 ~ F s2 t2, +we can use the injectivity to get a new Wanted constraint on +the injective argument + [W] t1 ~ t2 + +That in turn can help GHC solve constraints that would otherwise require +guessing. For example, consider the ambiguity check for + f :: F Int b -> Int +We get the constraint + [W] F Int b ~ F Int beta +where beta is a unification variable. Injectivity lets us pick beta ~ b. + +Injectivity information is also used at the call sites. For example: + g = f True +gives rise to + [W] F Int b ~ Bool +from which we can derive b. This requires looking at the defining equations of +a type family, ie. finding equation with a matching RHS (Bool in this example) +and inferring values of type variables (b in this example) from the LHS patterns +of the matching equation. For closed type families we have to perform +additional apartness check for the selected equation to check that the selected +is guaranteed to fire for given LHS arguments. + +These new constraints are Wanted constraints, but we will not use the evidence. +We could go further and offer evidence from decomposing injective type-function +applications, but that would require new evidence forms, and an extension to +FC, so we don't do that right now (Dec 14). + +We generate these Wanteds in three places, depending on how we notice the +injectivity. + +1. When we have a [W] F tys1 ~ F tys2. This is handled in canEqCanLHS2, and +described in Note [Decomposing type family applications] in GHC.Tc.Solver.Equality + +2. When we have [W] F tys1 ~ T and [W] F tys2 ~ T. Note that neither of these +constraints rewrites the other, as they have different LHSs. This is done +in improveLocalFunEqs, called during the interactWithInertsStage. + +3. When we have [W] F tys ~ T and an equation for F that looks like F tys' = T. +This is done in improve_top_fun_eqs, called from the top-level reactions stage. + +See also Note [Injective type families] in GHC.Core.TyCon + +Note [Cache-caused loops] +~~~~~~~~~~~~~~~~~~~~~~~~~ +It is very dangerous to cache a rewritten wanted family equation as 'solved' in our +solved cache (which is the default behaviour or xCtEvidence), because the interaction +may not be contributing towards a solution. Here is an example: + +Initial inert set: + [W] g1 : F a ~ beta1 +Work item: + [W] g2 : F a ~ beta2 +The work item will react with the inert yielding the _same_ inert set plus: + (i) Will set g2 := g1 `cast` g3 + (ii) Will add to our solved cache that [S] g2 : F a ~ beta2 + (iii) Will emit [W] g3 : beta1 ~ beta2 +Now, the g3 work item will be spontaneously solved to [G] g3 : beta1 ~ beta2 +and then it will react the item in the inert ([W] g1 : F a ~ beta1). So it +will set + g1 := g ; sym g3 +and what is g? Well it would ideally be a new goal of type (F a ~ beta2) but +remember that we have this in our solved cache, and it is ... g2! In short we +created the evidence loop: + + g2 := g1 ; g3 + g3 := refl + g1 := g2 ; sym g3 + +To avoid this situation we do not cache as solved any workitems (or inert) +which did not really made a 'step' towards proving some goal. Solved's are +just an optimization so we don't lose anything in terms of completeness of +solving. +-} 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,1839 +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, extendWorkListEq, - appendWorkList, extendWorkListImplic, - workListSize, - selectWorkItem, - - -- * The inert set - InertSet(..), - InertCans(..), - InertEqs, - emptyInert, - addInertItem, - - noMatchableGivenDicts, - noGivenNewtypeReprEqs, - mightEqualLater, - prohibitedSuperClassSolve, - - -- * Inert equalities - foldTyEqs, delEq, findEq, - partitionInertEqs, partitionFunEqs, - - -- * Kick-out - kickOutRewritableLHS, - - -- * Cycle breaker vars - CycleBreakerVarStack, - pushCycleBreakerVarStack, - insertCycleBreakerBinding, - forAllCycleBreakerBindings_ - - ) 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.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.Unify - -import GHC.Data.Bag -import GHC.Utils.Misc ( partitionWith ) -import GHC.Utils.Outputable -import GHC.Utils.Panic - -import Data.List ( partition ) -import Data.List.NonEmpty ( NonEmpty(..), (<|) ) -import qualified Data.List.NonEmpty as NE -import GHC.Utils.Panic.Plain -import GHC.Data.Maybe -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 /first/: - -* (Efficiency) The general reason to do so is that if we process a - class constraint first, we may end up putting it into the inert set - and then kicking it out later. That's extra work compared to just - doing the equality first. - -* (Avoiding fundep iteration) As #14723 showed, it's possible to - get non-termination if we - - Emit the 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. - -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_rest :: [Ct] - - , wl_implics :: Bag Implication -- See Note [Residual implications] - } - -appendWorkList :: WorkList -> WorkList -> WorkList -appendWorkList - (WL { wl_eqs = eqs1, wl_rest = rest1 - , wl_implics = implics1 }) - (WL { wl_eqs = eqs2, wl_rest = rest2 - , wl_implics = implics2 }) - = WL { wl_eqs = eqs1 ++ eqs2 - , wl_rest = rest1 ++ rest2 - , wl_implics = implics1 `unionBags` implics2 } - -workListSize :: WorkList -> Int -workListSize (WL { wl_eqs = eqs, wl_rest = rest }) - = length eqs + length rest - -extendWorkListEq :: Ct -> WorkList -> WorkList -extendWorkListEq ct wl = wl { wl_eqs = ct : wl_eqs wl } - -extendWorkListNonEq :: Ct -> WorkList -> WorkList --- Extension by non equality -extendWorkListNonEq ct wl = wl { wl_rest = ct : wl_rest wl } - -extendWorkListImplic :: Implication -> WorkList -> WorkList -extendWorkListImplic implic wl = wl { wl_implics = implic `consBag` wl_implics wl } - -extendWorkListCt :: Ct -> WorkList -> WorkList --- Agnostic -extendWorkListCt ct wl - = case classifyPredType (ctPred ct) of - EqPred {} - -> extendWorkListEq ct wl - - ClassPred cls _ -- See Note [Prioritise class equalities] - | isEqPredClass cls - -> extendWorkListEq ct wl - - _ -> extendWorkListNonEq ct wl - -extendWorkListCts :: [Ct] -> WorkList -> WorkList --- Agnostic -extendWorkListCts cts wl = foldr extendWorkListCt wl cts - -isEmptyWorkList :: WorkList -> Bool -isEmptyWorkList (WL { wl_eqs = eqs, wl_rest = rest, wl_implics = implics }) - = null eqs && null rest && isEmptyBag implics - -emptyWorkList :: WorkList -emptyWorkList = WL { wl_eqs = [], wl_rest = [], wl_implics = emptyBag } - -selectWorkItem :: WorkList -> Maybe (Ct, WorkList) --- See Note [Prioritise equalities] -selectWorkItem wl@(WL { wl_eqs = eqs, wl_rest = rest }) - | ct:cts <- eqs = Just (ct, wl { wl_eqs = cts }) - | ct:cts <- rest = Just (ct, wl { wl_rest = cts }) - | otherwise = Nothing - --- Pretty printing -instance Outputable WorkList where - ppr (WL { wl_eqs = eqs, wl_rest = rest, wl_implics = implics }) - = text "WL" <+> (braces $ - vcat [ ppUnless (null eqs) $ - text "Eqs =" <+> vcat (map ppr eqs) - , ppUnless (null rest) $ - text "Non-eqs =" <+> vcat (map ppr rest) - , ppUnless (isEmptyBag implics) $ - ifPprDebug (text "Implics =" <+> vcat (map ppr (bagToList implics))) - (text "(Implics omitted)") - ]) - -{- ********************************************************************* -* * - InertSet: the inert set -* * -* * -********************************************************************* -} - -type CycleBreakerVarStack = NonEmpty [(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.Canonical - -- Why store the outer implications? For the use in mightEqualLater (only) - -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 CtEvidence - -- All Wanteds, of form ev :: C t1 .. tn - -- See Note [Solved dictionaries] - -- and Note [Do not add superclasses of solved dictionaries] - } - -instance Outputable InertSet where - ppr (IS { inert_cans = ics - , inert_solved_dicts = solved_dicts }) - = vcat [ ppr ics - , ppUnless (null dicts) $ - text "Solved dicts =" <+> vcat (map ppr dicts) ] - where - dicts = bagToList (dictsToBag solved_dicts) - -emptyInertCans :: InertCans -emptyInertCans - = IC { inert_eqs = emptyDVarEnv - , inert_given_eq_lvl = topTcLevel - , inert_given_eqs = False - , inert_dicts = emptyDictMap - , inert_safehask = emptyDictMap - , inert_funeqs = emptyFunEqs - , inert_insts = [] - , inert_irreds = emptyCts } - -emptyInert :: InertSet -emptyInert - = IS { inert_cans = emptyInertCans - , inert_cycle_breakers = [] :| [] - , inert_famapp_cache = emptyFunEqs - , inert_solved_dicts = emptyDictMap } - - -{- Note [Solved dictionaries] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When we apply a top-level instance declaration, we add the "solved" -dictionary to the inert_solved_dicts. In general, we use it to avoid -creating a new EvVar when we have a new goal that we have solved in -the past. - -But in particular, we can use it to create *recursive* dictionaries. -The simplest, degenerate case is - instance C [a] => C [a] where ... -If we have - [W] d1 :: C [x] -then we can apply the instance to get - d1 = $dfCList d - [W] d2 :: C [x] -Now 'd1' goes in inert_solved_dicts, and we can solve d2 directly from d1. - d1 = $dfCList d - d2 = d1 - -See Note [Example of recursive dictionaries] - -VERY IMPORTANT INVARIANT: - - (Solved Dictionary Invariant) - Every member of the inert_solved_dicts is the result - of applying an instance declaration that "takes a step" - - An instance "takes a step" if it has the form - dfunDList d1 d2 = MkD (...) (...) (...) - That is, the dfun is lazy in its arguments, and guarantees to - immediately return a dictionary constructor. NB: all dictionary - data constructors are lazy in their arguments. - - This property is crucial to ensure that all dictionaries are - non-bottom, which in turn ensures that the whole "recursive - dictionary" idea works at all, even if we get something like - rec { d = dfunDList d dx } - See Note [Recursive superclasses] in GHC.Tc.TyCl.Instance. - - Reason: - - All instances, except two exceptions listed below, "take a step" - in the above sense - - - Exception 1: local quantified constraints have no such guarantee; - indeed, adding a "solved dictionary" when 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.Interact.doTopReactDict - - - ClsInst.InstanceWhat says what kind of instance was - used to solve the constraint. In particular - * LocalInstance identifies quantified constraints - * BuiltinEqInstance identifies the strange built-in - instances for equality. - - - ClsInst.instanceReturnsDictCon says which kind of - instance guarantees to return a dictionary constructor - -Other notes about solved dictionaries - -* See also Note [Do not add superclasses of solved dictionaries] - -* The inert_solved_dicts field is not rewritten by equalities, - so it may get out of date. - -* The inert_solved_dicts are all Wanteds, never givens - -* We only cache dictionaries from top-level instances, not from - local quantified constraints. Reason: if we cached the latter - we'd need to purge the cache when bringing new quantified - constraints into scope, because quantified constraints "shadow" - top-level instances. - -Note [Do not add superclasses of solved dictionaries] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Every member of inert_solved_dicts is the result of applying a -dictionary function, NOT of applying superclass selection to anything. -Consider - - class Ord a => C a where - instance Ord [a] => C [a] where ... - -Suppose we are trying to solve - [G] d1 : Ord a - [W] d2 : C [a] - -Then we'll use the instance decl to give - - [G] d1 : Ord a Solved: d2 : C [a] = $dfCList d3 - [W] d3 : Ord [a] - -We must not add d4 : Ord [a] to the 'solved' set (by taking the -superclass of d2), otherwise we'll use it to solve d3, without ever -using d1, which would be a catastrophe. - -Solution: when extending the solved dictionaries, do not add superclasses. -That's why each element of the inert_solved_dicts is the result of applying -a dictionary function. - -Note [Example of recursive dictionaries] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ---- Example 1 - - data D r = ZeroD | SuccD (r (D r)); - - instance (Eq (r (D r))) => Eq (D r) where - ZeroD == ZeroD = True - (SuccD a) == (SuccD b) = a == b - _ == _ = False; - - equalDC :: D [] -> D [] -> Bool; - equalDC = (==); - -We need to prove (Eq (D [])). Here's how we go: - - [W] d1 : Eq (D []) -By instance decl of Eq (D r): - [W] d2 : Eq [D []] where d1 = dfEqD d2 -By instance decl of Eq [a]: - [W] d3 : Eq (D []) where d2 = dfEqList d3 - d1 = dfEqD d2 -Now this wanted can interact with our "solved" d1 to get: - d3 = d1 - --- Example 2: -This code arises in the context of "Scrap Your Boilerplate with Class" - - class Sat a - class Data ctx a - instance Sat (ctx Char) => Data ctx Char -- dfunData1 - instance (Sat (ctx [a]), Data ctx a) => Data ctx [a] -- dfunData2 - - class Data Maybe a => Foo a - - instance Foo t => Sat (Maybe t) -- dfunSat - - instance Data Maybe a => Foo a -- dfunFoo1 - instance Foo a => Foo [a] -- dfunFoo2 - instance Foo [Char] -- dfunFoo3 - -Consider generating the superclasses of the instance declaration - instance Foo a => Foo [a] - -So our problem is this - [G] d0 : Foo t - [W] d1 : Data Maybe [t] -- Desired superclass - -We may add the given in the inert set, along with its superclasses - Inert: - [G] d0 : Foo t - [G] d01 : Data Maybe t -- Superclass of d0 - WorkList - [W] d1 : Data Maybe [t] - -Solve d1 using instance dfunData2; d1 := dfunData2 d2 d3 - Inert: - [G] d0 : Foo t - [G] d01 : Data Maybe t -- Superclass of d0 - Solved: - d1 : Data Maybe [t] - WorkList: - [W] d2 : Sat (Maybe [t]) - [W] d3 : Data Maybe t - -Now, we may simplify d2 using dfunSat; d2 := dfunSat d4 - Inert: - [G] d0 : Foo t - [G] d01 : Data Maybe t -- Superclass of d0 - Solved: - d1 : Data Maybe [t] - d2 : Sat (Maybe [t]) - WorkList: - [W] d3 : Data Maybe t - [W] d4 : Foo [t] - -Now, we can just solve d3 from d01; d3 := d01 - Inert - [G] d0 : Foo t - [G] d01 : Data Maybe t -- Superclass of d0 - Solved: - d1 : Data Maybe [t] - d2 : Sat (Maybe [t]) - WorkList - [W] d4 : Foo [t] - -Now, solve d4 using dfunFoo2; d4 := dfunFoo2 d5 - Inert - [G] d0 : Foo t - [G] d01 : Data Maybe t -- Superclass of d0 - Solved: - d1 : Data Maybe [t] - d2 : Sat (Maybe [t]) - d4 : Foo [t] - WorkList: - [W] d5 : Foo t - -Now, d5 can be solved! d5 := d0 - -Result - d1 := dfunData2 d2 d3 - d2 := dfunSat d4 - d3 := d01 - d4 := dfunFoo2 d5 - d5 := d0 --} - -{- ********************************************************************* -* * - InertCans: the canonical inerts -* * -* * -********************************************************************* -} - -{- Note [Tracking Given equalities] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -For reasons described in (UNTOUCHABLE) in GHC.Tc.Utils.Unify -Note [Unification preconditions], we can't unify - alpha[2] ~ Int -under a level-4 implication if there are any Given equalities -bound by the implications at level 3 of 4. To that end, the -InertCans tracks - - inert_given_eq_lvl :: TcLevel - -- The TcLevel of the innermost implication that has a Given - -- equality of the sort that make a unification variable untouchable - -- (see Note [Unification preconditions] in GHC.Tc.Utils.Unify). - -We update inert_given_eq_lvl whenever we add a Given to the -inert set, in updateGivenEqs. - -Then a unification variable alpha[n] is untouchable iff - n < inert_given_eq_lvl -that is, if the unification variable was born outside an -enclosing Given equality. - -Exactly which constraints should trigger (UNTOUCHABLE), and hence -should update inert_given_eq_lvl? - -* We do /not/ need to worry about let-bound skolems, such ast - forall[2] a. a ~ [b] => blah - See Note [Let-bound skolems] - -* Consider an implication - forall[2]. beta[1] => alpha[1] ~ Int - where beta is a unification variable that has already been unified - to () in an outer scope. Then alpha[1] is perfectly touchable and - we can unify alpha := Int. So when deciding whether the givens contain - an equality, we should canonicalise first, rather than just looking at - the /original/ givens (#8644). - - * However, we must take account of *potential* equalities. Consider the - same example again, but this time we have /not/ yet unified beta: - forall[2] beta[1] => ...blah... - - Because beta might turn into an equality, updateGivenEqs conservatively - treats it as a potential equality, and updates inert_give_eq_lvl - - * What about something like forall[2] a b. a ~ F b => [W] alpha[1] ~ X y z? - - That Given cannot affect the Wanted, because the Given is entirely - *local*: it mentions only skolems bound in the very same - implication. Such equalities need not make alpha untouchable. (Test - case typecheck/should_compile/LocalGivenEqs has a real-life - motivating example, with some detailed commentary.) - Hence the 'mentionsOuterVar' test in updateGivenEqs. - - However, solely to support better error messages - (see Note [HasGivenEqs] in GHC.Tc.Types.Constraint) we also track - these "local" equalities in the boolean inert_given_eqs field. - This field is used only to set the ic_given_eqs field to LocalGivenEqs; - see the function getHasGivenEqs. - - Here is a simpler case that triggers this behaviour: - - data T where - MkT :: F a ~ G b => a -> b -> T - - f (MkT _ _) = True - - Because of this behaviour around local equality givens, we can infer the - type of f. This is typecheck/should_compile/LocalGivenEqs2. - - * We need not look at the equality relation involved (nominal vs - representational), because representational equalities can still - imply nominal ones. For example, if (G a ~R G b) and G's argument's - role is nominal, then we can deduce a ~N b. - -Note [Let-bound skolems] -~~~~~~~~~~~~~~~~~~~~~~~~ -If * the inert set contains a canonical Given CEqCan (a ~ ty) -and * 'a' is a skolem bound in this very implication, - -then: -a) The Given is pretty much a let-binding, like - f :: (a ~ b->c) => a -> a - Here the equality constraint is like saying - let a = b->c in ... - It is not adding any new, local equality information, - and hence can be ignored by has_given_eqs - -b) 'a' will have been completely substituted out in the inert set, - so we can safely discard it. - -For an example, see #9211. - -See also GHC.Tc.Utils.Unify Note [Deeper level on the left] for how we ensure -that the right variable is on the left of the equality when both are -tyvars. - -You might wonder whether the skolem really needs to be bound "in the -very same implication" as the 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 CEqCans in inert_eqs should be a terminating generalised substitution ------------------------------------------------------------------------------ - -Note that termination is not the same as idempotence. To apply S to a -type, you may have to apply it recursively. But termination does -guarantee that this recursive use will terminate. - -Note [Why R2?] -~~~~~~~~~~~~~~ -R2 states that, if we have f1 >= f and f2 >= f, then either f1 >= f2 or f2 >= -f1. If we do not have R2, we will easily fall into a loop. - -To see why, imagine we have f1 >= f, f2 >= f, and that's it. Then, let our -inert set S = {a -f1-> b, b -f2-> a}. Computing S(f,a) does not terminate. And -yet, we have a hard time noticing an occurs-check problem when building S, as -the two equalities cannot rewrite one another. - -R2 actually restricts our ability to accept user-written programs. See -Note [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.Canonical.canEqTyVarFunEq.) Accordingly, the presence of a -variable in a kind or coercion just might influence the solver. Here is an -example: - - type family Const x y where - Const x y = x - - AxConst :: forall x y. Const x y ~# x - - alpha :: Const Type Nat - [W] alpha ~ Int |> (sym (AxConst Type alpha) ;; - AxConst Type alpha ;; - sym (AxConst Type Nat)) - -The cast is clearly ludicrous (it ties together a cast and its symmetric version), -but we can't quite rule it out. (See (EQ1) from -Note [Respecting definitional equality] in GHC.Core.TyCo.Rep to see why we need -the Const Type Nat bit.) And yet this cast will (quite rightly) prevent alpha -from unifying with the RHS. I (Richard E) don't have an example of where this -problem can arise from a Haskell program, but we don't have an air-tight argument -for why the definition of *rewritable* given here is correct. - -Taking roles into account: we must consider a rewrite at a given role. That is, -a rewrite arises from some equality, and that equality has a role associated -with it. As we traverse a type, we track what role we are allowed to rewrite with. - -For example, suppose we have an inert [G] b ~R# Int. Then b is rewritable in -Maybe b but not in F b, where F is a type function. This role-aware logic is -present in both the anyRewritableXXX functions and in the rewriter. -See also Note [anyRewritableTyVar must be role-aware] in GHC.Tc.Utils.TcType. - -Note [Extending the inert equalities] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Main Theorem [Stability under extension] - Suppose we have a "work item" - lhs -fw-> t - and a terminating generalised substitution S, - THEN the extended substitution T = S+(lhs -fw-> t) - is a terminating generalised substitution - PROVIDED - (T1) S(fw,lhs) = lhs -- LHS of work-item is a fixpoint of S(fw,_) - (T2) S(fw,t) = t -- RHS of work-item is a fixpoint of S(fw,_) - (T3) lhs not in t -- No occurs check in the work item - -- If lhs is a type family application, we require only that - -- lhs is not *rewritable* in t. See Note [Rewritable] and - -- Note [CEqCan occurs check] in GHC.Tc.Types.Constraint. - - AND, for every (lhs1 -fs-> s) in S: - (K0) not (fw >= fs) - Reason: suppose we kick out (lhs1 -fs-> s), - and add (lhs -fw-> t) to the inert set. - The latter can't rewrite the former, - so the kick-out achieved nothing - - -- From here, we can assume fw >= fs - OR (K4) lhs1 is a tyvar AND fs >= fw - - OR { (K1) lhs is not rewritable in lhs1. See Note [Rewritable]. - Reason: if fw >= fs, WF1 says we can't have both - lhs0 -fw-> t and F lhs0 -fs-> s - - AND (K2): guarantees termination of the new substitution - { (K2a) not (fs >= fs) - OR (K2b) lhs not in s } - - AND (K3) See Note [K3: completeness of solving] - { (K3a) If the role of fs is nominal: s /= lhs - (K3b) If the role of fs is representational: - s is not of form (lhs t1 .. tn) } } - - -Conditions (T1-T3) are established by the canonicaliser -Conditions (K1-K3) are established by GHC.Tc.Solver.Monad.kickOutRewritable - -The idea is that -* T1 and T2 are guaranteed by exhaustively rewriting the work-item - with S(fw,_). - -* T3 is guaranteed by an occurs-check on the work item. - This is done during canonicalisation, in checkTypeEq; invariant - (TyEq:OC) of CEqCan. See also Note [CEqCan occurs check] in GHC.Tc.Types.Constraint. - -* (K1-3) are the "kick-out" criteria. (As stated, they are really the - "keep" criteria.) If the current inert S contains a triple that does - not satisfy (K1-3), then we remove it from S by "kicking it out", - and re-processing it. - -* Note that kicking out is a Bad Thing, because it means we have to - re-process a constraint. The less we kick out, the better. - TODO: Make sure that kicking out really *is* a Bad Thing. We've assumed - this but haven't done the empirical study to check. - -* Assume we have G>=G, G>=W and that's all. Then, when performing - a unification we add a new given a -G-> ty. But doing so does NOT require - us to kick out an inert wanted that mentions a, because of (K2a). This - is a common case, hence good not to kick out. See also (K2a) below. - -* Lemma (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 CEqCans with a TyVarLHS; index is the LHS tyvar - -- Domain = skolems and untouchables; a touchable would be unified - - , inert_funeqs :: FunEqMap EqualCtList - -- All CEqCans with a TyFamLHS; index is the whole family head type. - -- LHS is fully rewritten (modulo eqCanRewrite constraints) - -- wrt inert_eqs - -- Can include both [G] and [W] - - , inert_dicts :: DictMap Ct - -- Dictionaries only - -- All fully rewritten (modulo flavour constraints) - -- wrt inert_eqs - - , inert_insts :: [QCInst] - - , inert_safehask :: DictMap Ct - -- Failed dictionary resolution due to Safe Haskell overlapping - -- instances restriction. We keep this separate from inert_dicts - -- as it doesn't cause compilation failure, just safe inference - -- failure. - -- - -- ^ See Note [Safe Haskell Overlapping Instances Implementation] - -- in GHC.Tc.Solver - - , inert_irreds :: Cts - -- Irreducible predicates that cannot be made canonical, - -- and which don't interact with others (e.g. (c a)) - -- and insoluble predicates (e.g. Int ~ Bool, or a ~ [a]) - - , inert_given_eq_lvl :: TcLevel - -- The TcLevel of the innermost implication that has a Given - -- equality of the sort that make a unification variable untouchable - -- (see Note [Unification preconditions] in GHC.Tc.Utils.Unify). - -- See Note [Tracking Given equalities] - - , inert_given_eqs :: Bool - -- True <=> The inert Givens *at this level* (tcl_tclvl) - -- could includes at least one equality /other than/ a - -- let-bound skolem equality. - -- Reason: report these givens when reporting a failed equality - -- See Note [Tracking Given equalities] - } - -type InertEqs = DTyVarEnv EqualCtList - -instance Outputable InertCans where - ppr (IC { inert_eqs = eqs - , inert_funeqs = funeqs - , inert_dicts = dicts - , inert_safehask = safehask - , inert_irreds = irreds - , inert_given_eq_lvl = ge_lvl - , inert_given_eqs = given_eqs - , inert_insts = insts }) - - = braces $ vcat - [ ppUnless (isEmptyDVarEnv eqs) $ - text "Equalities:" - <+> pprCts (foldDVarEnv folder emptyCts eqs) - , ppUnless (isEmptyTcAppMap funeqs) $ - text "Type-function equalities =" <+> pprCts (foldFunEqs folder funeqs emptyCts) - , ppUnless (isEmptyTcAppMap dicts) $ - text "Dictionaries =" <+> pprCts (dictsToBag dicts) - , ppUnless (isEmptyTcAppMap safehask) $ - text "Safe Haskell unsafe overlap =" <+> pprCts (dictsToBag safehask) - , ppUnless (isEmptyCts irreds) $ - text "Irreds =" <+> pprCts irreds - , ppUnless (null insts) $ - text "Given instances =" <+> vcat (map ppr insts) - , text "Innermost given equalities =" <+> ppr ge_lvl - , text "Given eqs at this level =" <+> ppr given_eqs - ] - where - folder eqs rest = listToBag eqs `andCts` rest - -{- ********************************************************************* -* * - Inert equalities -* * -********************************************************************* -} - -addTyEq :: InertEqs -> TcTyVar -> Ct -> InertEqs -addTyEq old_eqs tv ct - = extendDVarEnv_C add_eq old_eqs tv [ct] - where - add_eq old_eqs _ = addToEqualCtList ct old_eqs - -addCanFunEq :: FunEqMap EqualCtList -> TyCon -> [TcType] -> Ct - -> FunEqMap EqualCtList -addCanFunEq old_eqs fun_tc fun_args ct - = alterTcApp old_eqs fun_tc fun_args upd - where - upd (Just old_equal_ct_list) = Just $ addToEqualCtList ct old_equal_ct_list - upd Nothing = Just [ct] - -foldTyEqs :: (Ct -> b -> b) -> InertEqs -> b -> b -foldTyEqs k eqs z - = foldDVarEnv (\cts z -> foldr k z cts) z eqs - -findTyEqs :: InertCans -> TyVar -> [Ct] -findTyEqs icans tv = concat @Maybe (lookupDVarEnv (inert_eqs icans) tv) - -delEq :: InertCans -> CanEqLHS -> TcType -> InertCans -delEq ic lhs rhs = case lhs of - TyVarLHS tv - -> ic { inert_eqs = alterDVarEnv upd (inert_eqs ic) tv } - TyFamLHS tf args - -> ic { inert_funeqs = alterTcApp (inert_funeqs ic) tf args upd } - where - isThisOne :: Ct -> Bool - isThisOne (CEqCan { cc_rhs = t1 }) = tcEqTypeNoKindCheck rhs t1 - isThisOne other = pprPanic "delEq" (ppr lhs $$ ppr ic $$ ppr other) - - upd :: Maybe EqualCtList -> Maybe EqualCtList - upd (Just eq_ct_list) = filterEqualCtList (not . isThisOne) eq_ct_list - upd Nothing = Nothing - -findEq :: InertCans -> CanEqLHS -> [Ct] -findEq icans (TyVarLHS tv) = findTyEqs icans tv -findEq icans (TyFamLHS fun_tc fun_args) - = concat @Maybe (findFunEq (inert_funeqs icans) fun_tc fun_args) - -{-# INLINE partition_eqs_container #-} -partition_eqs_container - :: forall container - . container -- empty container - -> (forall b. (EqualCtList -> b -> b) -> b -> container -> b) -- folder - -> (container -> CanEqLHS -> EqualCtList -> container) -- extender - -> (Ct -> Bool) - -> container - -> ([Ct], container) -partition_eqs_container empty_container fold_container extend_container pred orig_inerts - = fold_container folder ([], empty_container) orig_inerts - where - folder :: EqualCtList -> ([Ct], container) -> ([Ct], container) - folder eqs (acc_true, acc_false) - = (eqs_true ++ acc_true, acc_false') - where - (eqs_true, eqs_false) = partition pred eqs - - acc_false' - | CEqCan { cc_lhs = lhs } : _ <- eqs_false - = extend_container acc_false lhs eqs_false - | otherwise - = acc_false - -partitionInertEqs :: (Ct -> Bool) -- Ct will always be a CEqCan with a TyVarLHS - -> InertEqs - -> ([Ct], InertEqs) -partitionInertEqs = partition_eqs_container emptyDVarEnv foldDVarEnv extendInertEqs - --- precondition: CanEqLHS is a TyVarLHS -extendInertEqs :: InertEqs -> CanEqLHS -> EqualCtList -> InertEqs -extendInertEqs eqs (TyVarLHS tv) new_eqs = extendDVarEnv eqs tv new_eqs -extendInertEqs _ other _ = pprPanic "extendInertEqs" (ppr other) - -partitionFunEqs :: (Ct -> Bool) -- Ct will always be a CEqCan with a TyFamLHS - -> FunEqMap EqualCtList - -> ([Ct], FunEqMap EqualCtList) -partitionFunEqs - = partition_eqs_container emptyFunEqs (\ f z eqs -> foldFunEqs f eqs z) extendFunEqs - --- precondition: CanEqLHS is a TyFamLHS -extendFunEqs :: FunEqMap EqualCtList -> CanEqLHS -> EqualCtList -> FunEqMap EqualCtList -extendFunEqs eqs (TyFamLHS tf args) new_eqs = insertTcApp eqs tf args new_eqs -extendFunEqs _ other _ = pprPanic "extendFunEqs" (ppr other) - -{- ********************************************************************* -* * - Adding to and removing from the inert set -* * -* * -********************************************************************* -} - -addInertItem :: TcLevel -> InertCans -> Ct -> InertCans -addInertItem tc_lvl - ics@(IC { inert_funeqs = funeqs, inert_eqs = eqs }) - item@(CEqCan { cc_lhs = lhs }) - = updateGivenEqs tc_lvl item $ - case lhs of - TyFamLHS tc tys -> ics { inert_funeqs = addCanFunEq funeqs tc tys item } - TyVarLHS tv -> ics { inert_eqs = addTyEq eqs tv item } - -addInertItem tc_lvl ics@(IC { inert_irreds = irreds }) item@(CIrredCan {}) - = updateGivenEqs tc_lvl item $ -- An Irred might turn out to be an - -- equality, so we play safe - ics { inert_irreds = irreds `snocBag` item } - -addInertItem _ ics item@(CDictCan { cc_class = cls, cc_tyargs = tys }) - = ics { inert_dicts = addDict (inert_dicts ics) cls tys item } - -addInertItem _ _ item - = pprPanic "upd_inert set: can't happen! Inserting " $ - ppr item -- Can't be CNonCanonical because they only land in inert_irreds - -updateGivenEqs :: TcLevel -> Ct -> InertCans -> InertCans --- Set the inert_given_eq_level to the current level (tclvl) --- if the constraint is a given equality that should prevent --- filling in an outer unification variable. --- See Note [Tracking Given equalities] -updateGivenEqs tclvl ct inerts@(IC { inert_given_eq_lvl = ge_lvl }) - | not (isGivenCt ct) = inerts - | not_equality ct = inerts -- See Note [Let-bound skolems] - | otherwise = inerts { inert_given_eq_lvl = ge_lvl' - , inert_given_eqs = True } - where - ge_lvl' | mentionsOuterVar tclvl (ctEvidence ct) - -- Includes things like (c a), which *might* be an equality - = tclvl - | otherwise - = ge_lvl - - not_equality :: Ct -> Bool - -- True <=> definitely not an equality of any kind - -- except for a let-bound skolem, which doesn't count - -- See Note [Let-bound skolems] - -- NB: no need to spot the boxed CDictCan (a ~ b) because its - -- superclass (a ~# b) will be a CEqCan - not_equality (CEqCan { cc_lhs = TyVarLHS tv }) = not (isOuterTyVar tclvl tv) - not_equality (CDictCan {}) = True - not_equality _ = False - -kickOutRewritableLHS :: CtFlavourRole -- Flavour/role of the equality that - -- is being added to the inert set - -> CanEqLHS -- The new equality is lhs ~ ty - -> InertCans - -> (WorkList, InertCans) --- See Note [kickOutRewritable] -kickOutRewritableLHS new_fr new_lhs - ics@(IC { inert_eqs = tv_eqs - , inert_dicts = dictmap - , inert_funeqs = funeqmap - , inert_irreds = irreds - , inert_insts = old_insts }) - = (kicked_out, inert_cans_in) - where - -- inert_safehask stays unchanged; is that right? - inert_cans_in = ics { inert_eqs = tv_eqs_in - , inert_dicts = dicts_in - , inert_funeqs = feqs_in - , inert_irreds = irs_in - , inert_insts = insts_in } - - kicked_out :: WorkList - -- NB: use extendWorkList to ensure that kicked-out equalities get priority - -- See Note [Prioritise equalities] (Kick-out). - -- The irreds may include non-canonical (hetero-kinded) equality - -- constraints, which perhaps may have become soluble after new_lhs - -- is substituted; ditto the dictionaries, which may include (a~b) - -- or (a~~b) constraints. - kicked_out = foldr extendWorkListCt - (emptyWorkList { wl_eqs = tv_eqs_out ++ feqs_out }) - ((dicts_out `andCts` irs_out) - `extendCtsList` insts_out) - - (tv_eqs_out, tv_eqs_in) = partitionInertEqs kick_out_eq tv_eqs - (feqs_out, feqs_in) = partitionFunEqs kick_out_eq funeqmap - (dicts_out, dicts_in) = partitionDicts kick_out_ct dictmap - (irs_out, irs_in) = partitionBag kick_out_ct irreds - -- Kick out even insolubles: See Note [Rewrite insolubles] - -- Of course we must kick out irreducibles like (c a), in case - -- we can rewrite 'c' to something more useful - - -- Kick-out for inert instances - -- See Note [Quantified constraints] in GHC.Tc.Solver.Canonical - insts_out :: [Ct] - insts_in :: [QCInst] - (insts_out, insts_in) - | fr_may_rewrite (Given, NomEq) -- All the insts are Givens - = partitionWith kick_out_qci old_insts - | otherwise - = ([], old_insts) - kick_out_qci qci - | let ev = qci_ev qci - , fr_can_rewrite_ty NomEq (ctEvPred (qci_ev qci)) - = Left (mkNonCanonical ev) - | otherwise - = Right qci - - (_, new_role) = new_fr - - fr_tv_can_rewrite_ty :: TyVar -> EqRel -> Type -> Bool - fr_tv_can_rewrite_ty new_tv role ty - = anyRewritableTyVar role can_rewrite ty - where - can_rewrite :: EqRel -> TyVar -> Bool - can_rewrite old_role tv = new_role `eqCanRewrite` old_role && tv == new_tv - - fr_tf_can_rewrite_ty :: TyCon -> [TcType] -> EqRel -> Type -> Bool - fr_tf_can_rewrite_ty new_tf new_tf_args role ty - = anyRewritableTyFamApp role can_rewrite ty - where - can_rewrite :: EqRel -> TyCon -> [TcType] -> Bool - can_rewrite old_role old_tf old_tf_args - = new_role `eqCanRewrite` old_role && - tcEqTyConApps new_tf new_tf_args old_tf old_tf_args - -- it's possible for old_tf_args to have too many. This is fine; - -- we'll only check what we need to. - - {-# INLINE fr_can_rewrite_ty #-} -- perform the check here only once - fr_can_rewrite_ty :: EqRel -> Type -> Bool - fr_can_rewrite_ty = case new_lhs of - TyVarLHS new_tv -> fr_tv_can_rewrite_ty new_tv - TyFamLHS new_tf new_tf_args -> fr_tf_can_rewrite_ty new_tf new_tf_args - - fr_may_rewrite :: CtFlavourRole -> Bool - fr_may_rewrite fs = new_fr `eqCanRewriteFR` fs - -- Can the new item rewrite the inert item? - - {-# INLINE kick_out_ct #-} -- perform case on new_lhs here only once - kick_out_ct :: Ct -> Bool - -- Kick it out if the new CEqCan can rewrite the inert one - -- See Note [kickOutRewritable] - kick_out_ct = case new_lhs of - TyVarLHS new_tv -> \ct -> let fs@(_,role) = ctFlavourRole ct in - fr_may_rewrite fs - && fr_tv_can_rewrite_ty new_tv role (ctPred ct) - TyFamLHS new_tf new_tf_args - -> \ct -> let fs@(_, role) = ctFlavourRole ct in - fr_may_rewrite fs - && fr_tf_can_rewrite_ty new_tf new_tf_args role (ctPred ct) - - -- Implements criteria K1-K3 in Note [Extending the inert equalities] - kick_out_eq :: Ct -> Bool - kick_out_eq (CEqCan { cc_lhs = lhs, cc_rhs = rhs_ty - , cc_ev = ev, cc_eq_rel = eq_rel }) - | not (fr_may_rewrite fs) - = False -- (K0) Keep it in the inert set if the new thing can't rewrite it - - -- Below here (fr_may_rewrite fs) is True - - | TyVarLHS _ <- lhs - , fs `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 -> rhs_ty `eqType` canEqLHSType new_lhs -- (K3a) - ReprEq -> is_can_eq_lhs_head new_lhs rhs_ty -- (K3b) - - kick_out_eq ct = pprPanic "kick_out_eq" (ppr ct) - - is_can_eq_lhs_head (TyVarLHS tv) = go - where - go (Rep.TyVarTy tv') = tv == tv' - go (Rep.AppTy fun _) = go fun - go (Rep.CastTy ty _) = go ty - go (Rep.TyConApp {}) = False - go (Rep.LitTy {}) = False - go (Rep.ForAllTy {}) = False - go (Rep.FunTy {}) = False - go (Rep.CoercionTy {}) = False - is_can_eq_lhs_head (TyFamLHS fun_tc fun_args) = go - where - go (Rep.TyVarTy {}) = False - go (Rep.AppTy {}) = False -- no TyConApp to the left of an AppTy - go (Rep.CastTy ty _) = go ty - go (Rep.TyConApp tc args) = tcEqTyConApps fun_tc fun_args tc args - go (Rep.LitTy {}) = False - go (Rep.ForAllTy {}) = False - go (Rep.FunTy {}) = False - go (Rep.CoercionTy {}) = False - -{- Note [kickOutRewritable] -~~~~~~~~~~~~~~~~~~~~~~~~~~~ -See also Note [inert_eqs: the inert equalities]. - -When we add a new inert equality (lhs ~N ty) to the inert set, -we must kick out any inert items that could be rewritten by the -new equality, to maintain the inert-set invariants. - - - We want to kick out an existing inert constraint if - a) the new constraint can rewrite the inert one - b) 'lhs' is free in the inert constraint (so that it *will*) - rewrite it if we kick it out. - - For (b) we use anyRewritableCanLHS, which examines the types /and - kinds/ that are directly visible in the type. Hence - we will have exposed all the rewriting we care about to make the - most precise kinds visible for matching classes etc. No need to - kick out constraints that mention type variables whose kinds - contain this LHS! - - - We don't kick out constraints from inert_solved_dicts, and - inert_solved_funeqs optimistically. But when we lookup we have to - take the substitution into account - -NB: we could in principle avoid kick-out: - a) When unifying a meta-tyvar from an outer level, because - then the entire implication will be iterated; see - Note [The Unification Level Flag] in GHC.Tc.Solver.Monad. - - b) For Givens, after a unification. By (GivenInv) in GHC.Tc.Utils.TcType - Note [TcLevel invariants], a Given can't include a meta-tyvar from - its own level, so it falls under (a). Of course, we must still - kick out Givens when adding a new non-unification Given. - -But kicking out more vigorously may lead to earlier unification and fewer -iterations, so we don't take advantage of these possibilities. - -Note [Rewrite insolubles] -~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose we have an insoluble alpha ~ [alpha], which is insoluble -because an occurs check. And then we unify alpha := [Int]. Then we -really want to rewrite the insoluble to [Int] ~ [[Int]]. Now it can -be decomposed. Otherwise we end up with a "Can't match [Int] ~ -[[Int]]" which is true, but a bit confusing because the outer type -constructors match. - -Hence: - * In the main simplifier loops in GHC.Tc.Solver (solveWanteds, - simpl_loop), we feed the insolubles in solveSimpleWanteds, - so that they get rewritten (albeit not solved). - - * We kick insolubles out of the inert set, if they can be - rewritten (see GHC.Tc.Solver.Monad.kick_out_rewritable) - - * We rewrite those insolubles in GHC.Tc.Solver.Canonical. - See Note [Make sure that insolubles are fully rewritten] - in GHC.Tc.Solver.Canonical. --} - -{- ********************************************************************* -* * - Queries -* * -* * -********************************************************************* -} - -mentionsOuterVar :: TcLevel -> CtEvidence -> Bool -mentionsOuterVar tclvl ev - = anyFreeVarsOfType (isOuterTyVar tclvl) $ - ctEvPred ev - -isOuterTyVar :: TcLevel -> TyCoVar -> Bool --- True of a type variable that comes from a --- shallower level than the ambient level (tclvl) -isOuterTyVar tclvl tv - | isTyVar tv = assertPpr (not (isTouchableMetaTyVar tclvl tv)) (ppr tv <+> ppr tclvl) $ - tclvl `strictlyDeeperThan` tcTyVarLevel tv - -- ASSERT: we are dealing with Givens here, and invariant (GivenInv) from - -- Note Note [TcLevel invariants] in GHC.Tc.Utils.TcType ensures that there can't - -- be a touchable meta tyvar. If this wasn't true, you might worry that, - -- at level 3, a meta-tv alpha[3] gets unified with skolem b[2], and thereby - -- becomes "outer" even though its level numbers says it isn't. - | otherwise = False -- Coercion variables; doesn't much matter - -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.Canonical --- This is the only call site. -noGivenNewtypeReprEqs tc inerts - = not (anyBag might_help (inert_irreds (inert_cans inerts))) - where - might_help ct - = case classifyPredType (ctPred ct) 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.Interact" -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 :: Ct -> Bool - matchable_given ct - | CtGiven { ctev_loc = loc_g, ctev_pred = pred_g } <- ctEvidence ct - = 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.Interact -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 startSolvingByUnification, 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.Canonical. - This is just like case 6, and we say "no". Saying "no" here is - essential in getting the parser to type-check, with its use of DisambECP. - -9. C cbv ~? C Int - where cbv = F alpha - - Here, we might indeed equal later. Distinguishing between - this case and Example 8 is why we need the InertSet in mightEqualLater. - -10. C (F alpha, Int) ~? C (Bool, F alpha) - - This cannot equal later, because F a would have to equal both Bool and - Int. - -To deal with type family applications, we use the Core flattener. See -Note [Flattening type-family applications when matching instances] in GHC.Core.Unify. -The Core flattener replaces all type family applications with -fresh variables. The next question: should we allow these fresh -variables in the domain of a unifying substitution? - -A type family application that mentions only skolems (example 6) is settled: -any skolems would have been rewritten w.r.t. Givens by now. These type family -applications match only themselves. A type family application that mentions -metavariables, on the other hand, can match anything. So, if the original type -family application contains a metavariable, we use BindMe to tell the unifier -to allow it in the substitution. On the other hand, a type family application -with only skolems is considered rigid. - -This treatment fixes #18910 and is tested in -typecheck/should_compile/InstanceGivenOverlap{,2} - -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 (lookup 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 = ([] <|) - --- | Add a new cycle-breaker binding to the top environment on the stack. -insertCycleBreakerBinding :: TcTyVar -- ^ cbv, must be a CycleBreakerTv - -> TcType -- ^ cbv's expansion - -> CycleBreakerVarStack -> CycleBreakerVarStack -insertCycleBreakerBinding cbv expansion (top_env :| rest_envs) - = assert (isCycleBreakerTyVar cbv) $ - ((cbv, expansion) : 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 +{-# 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/Interact.hs b/GHC/Tc/Solver/Interact.hs deleted file mode 100644 --- a/GHC/Tc/Solver/Interact.hs +++ /dev/null @@ -1,2836 +0,0 @@ -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} - -module GHC.Tc.Solver.Interact ( - solveSimpleGivens, -- Solves [Ct] - solveSimpleWanteds -- Solves Cts - ) where - -import GHC.Prelude -import GHC.Types.Basic ( SwapFlag(..), IntWithInf, intGtLimit ) -import GHC.Tc.Solver.Canonical -import GHC.Types.Var.Set - -import GHC.Types.Var -import GHC.Tc.Errors.Types -import GHC.Tc.Utils.TcType -import GHC.Builtin.Names ( coercibleTyConKey, heqTyConKey, eqTyConKey, ipClassKey ) -import GHC.Tc.Instance.FunDeps -import GHC.Tc.Instance.Family -import GHC.Tc.Instance.Class ( InstanceWhat(..), safeOverlap ) - -import GHC.Tc.Types.Evidence -import GHC.Utils.Outputable -import GHC.Utils.Panic - -import GHC.Tc.Types -import GHC.Tc.Types.Constraint -import GHC.Tc.Types.Origin -import GHC.Tc.Utils.TcMType( promoteMetaTyVarTo ) -import GHC.Tc.Solver.Types -import GHC.Tc.Solver.InertSet -import GHC.Tc.Solver.Monad - -import GHC.Core -import GHC.Core.Type as Type -import GHC.Core.InstEnv ( DFunInstType ) -import GHC.Core.Class -import GHC.Core.TyCon -import GHC.Core.Reduction -import GHC.Core.Predicate -import GHC.Core.Coercion -import GHC.Core.FamInstEnv -import GHC.Core.Unify ( tcUnifyTyWithTFs, ruleMatchTyKiX ) -import GHC.Core.Coercion.Axiom ( CoAxBranch (..), CoAxiom (..), TypeEqn, fromBranches - , sfInteractInert, sfInteractTop ) - -import GHC.Types.SrcLoc -import GHC.Types.Var.Env -import GHC.Types.Unique( hasKey ) - -import GHC.Data.Bag -import GHC.Data.Pair (Pair(..)) - -import GHC.Utils.Monad ( concatMapM, foldlM ) -import GHC.Utils.Misc - -import GHC.Driver.Session - -import qualified GHC.LanguageExtensions as LangExt - -import Data.List( deleteFirstsBy ) -import Data.Maybe ( listToMaybe, mapMaybe ) -import Data.Function ( on ) -import qualified Data.Semigroup as S - -import Control.Monad.Trans.Class -import Control.Monad.Trans.Maybe -import Control.Monad - -{- -********************************************************************** -* * -* Main Interaction 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) - 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 --} - --- 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 { updWorkListTcS (\wl -> foldr extendWorkListCt wl cts) - ; solve_loop } - where - solve_loop - = {-# SCC "solve_loop" #-} - do { sel <- selectNextWorkItem - ; case sel of - Nothing -> return () - Just ct -> do { runSolverPipeline thePipeline ct - ; solve_loop } } - --- | 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 { p <- runTcPluginSolvers solvers (givens,[]) - ; let (solved_givens, _) = pluginSolvedCts p - insols = pluginBadCts p - ; updInertCans (removeInertCts solved_givens) - ; updInertIrreds (\irreds -> extendCtsList irreds insols) - ; 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 - ; p <- runTcPluginSolvers solvers (given, bagToList wanted) - ; let (_, solved_wanted) = pluginSolvedCts p - (_, unsolved_wanted) = pluginInputCts p - new_wanted = pluginNewCts p - insols = pluginBadCts p - --- SLPJ: I'm deeply suspicious of this --- ; updInertCans (removeInertCts $ solved_givens) - - ; mapM_ setEv solved_wanted - ; return ( notNull (pluginNewCts p) - , wc { wc_simple = listToBag new_wanted `andCts` - listToBag unsolved_wanted `andCts` - listToBag insols } ) } } - where - setEv :: (EvTerm,Ct) -> TcS () - setEv (ev,ct) = case ctEvidence ct of - CtWanted { ctev_dest = dest } -> setWantedEvTerm dest ev - _ -> 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 eqCt - - eqCt :: Ct -> Ct -> Bool - eqCt 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) - - -type WorkItem = Ct -type SimplifierStage = WorkItem -> TcS (StopOrContinue Ct) - -runSolverPipeline :: [(String,SimplifierStage)] -- The pipeline - -> WorkItem -- The work item - -> TcS () --- Run this item down the pipeline, leaving behind new work and inerts -runSolverPipeline pipeline workItem - = do { wl <- getWorkList - ; inerts <- getTcSInerts - ; 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 - ; final_res <- run_pipeline pipeline (ContinueWith workItem) - - ; case final_res of - Stop ev s -> do { traceFireTcS ev s - ; traceTcS "End solver pipeline (discharged) }" empty - ; return () } - ContinueWith ct -> do { addInertCan ct - ; traceFireTcS (ctEvidence ct) (text "Kept as inert") - ; traceTcS "End solver pipeline (kept as inert) }" $ - (text "final_item =" <+> ppr ct) } - } - where run_pipeline :: [(String,SimplifierStage)] -> StopOrContinue Ct - -> TcS (StopOrContinue Ct) - run_pipeline [] res = return res - run_pipeline _ (Stop ev s) = return (Stop ev s) - run_pipeline ((stg_name,stg):stgs) (ContinueWith ct) - = do { traceTcS ("runStage " ++ stg_name ++ " {") - (text "workitem = " <+> ppr ct) - ; res <- stg ct - ; traceTcS ("end stage " ++ stg_name ++ " }") empty - ; run_pipeline stgs res } - -{- -Example 1: - Inert: {c ~ d, F a ~ t, b ~ Int, a ~ ty} (all given) - Reagent: a ~ [b] (given) - -React with (c~d) ==> IR (ContinueWith (a~[b])) True [] -React with (F a ~ t) ==> IR (ContinueWith (a~[b])) False [F [b] ~ t] -React with (b ~ Int) ==> IR (ContinueWith (a~[Int]) True [] - -Example 2: - Inert: {c ~w d, F a ~g t, b ~w Int, a ~w ty} - Reagent: a ~w [b] - -React with (c ~w d) ==> IR (ContinueWith (a~[b])) True [] -React with (F a ~g t) ==> IR (ContinueWith (a~[b])) True [] (can't rewrite given with wanted!) -etc. - -Example 3: - Inert: {a ~ Int, F Int ~ b} (given) - Reagent: F a ~ b (wanted) - -React with (a ~ Int) ==> IR (ContinueWith (F Int ~ b)) True [] -React with (F Int ~ b) ==> IR Stop True [] -- after substituting we re-canonicalize and get nothing --} - -thePipeline :: [(String,SimplifierStage)] -thePipeline = [ ("canonicalization", GHC.Tc.Solver.Canonical.canonicalize) - , ("interact with inerts", interactWithInertsStage) - , ("top-level reactions", topReactionsStage) ] - -{- -********************************************************************************* -* * - The interact-with-inert Stage -* * -********************************************************************************* - -Note [The Solver Invariant] -~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We always add Givens first. So you might think that the solver has -the invariant - - If the work-item is Given, - then the inert item must Given - -But this isn't quite true. Suppose we have, - c1: [W] beta ~ [alpha], c2 : [W] blah, c3 :[W] alpha ~ Int -After processing the first two, we get - c1: [G] beta ~ [alpha], c2 : [W] blah -Now, c3 does not interact with the given c1, so when we spontaneously -solve c3, we must re-react it with the inert set. So we can attempt a -reaction between inert c2 [W] and work-item c3 [G]. - -It *is* true that [Solver Invariant] - If the work-item is Given, - AND there is a reaction - then the inert item must Given -or, equivalently, - If the work-item is Given, - and the inert item is Wanted - then there is no reaction --} - --- Interaction result of WorkItem <~> Ct - -interactWithInertsStage :: WorkItem -> TcS (StopOrContinue Ct) --- Precondition: if the workitem is a CEqCan then it will not be able to --- react with anything at this stage (except, maybe, via a type family --- dependency) - -interactWithInertsStage wi - = do { inerts <- getTcSInerts - ; let ics = inert_cans inerts - ; case wi of - CEqCan {} -> interactEq ics wi - CIrredCan {} -> interactIrred ics wi - CDictCan {} -> interactDict ics wi - _ -> pprPanic "interactWithInerts" (ppr wi) } - -- CNonCanonical have been canonicalised - -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] - - 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] - - - 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.Canonical - -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.) - -********************************************************************************* -* * - interactIrred -* * -********************************************************************************* - -Note [Multiple matching irreds] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -You might think that it's impossible to have multiple irreds all match the -work item; after all, interactIrred looks for matches and solves one from the -other. However, note that interacting insoluble, non-droppable irreds does not -do this matching. We thus might end up with several insoluble, non-droppable, -matching irreds in the inert set. When another irred comes along that we have -not yet labeled insoluble, we can find multiple matches. These multiple matches -cause no harm, but it would be wrong to ASSERT that they aren't there (as we -once had done). This problem can be tickled by typecheck/should_compile/holes. - --} - --- Two pieces of irreducible evidence: if their types are *exactly identical* --- we can rewrite them. We can never improve using this: --- if we want ty1 :: Constraint and have ty2 :: Constraint it clearly does not --- mean that (ty1 ~ ty2) -interactIrred :: InertCans -> Ct -> TcS (StopOrContinue Ct) - -interactIrred inerts ct_w@(CIrredCan { cc_ev = ev_w, cc_reason = reason }) - | isInsolubleReason reason - -- For insolubles, don't allow the constraint to be dropped - -- which can happen with solveOneFromTheOther, so that - -- we get distinct error messages with -fdefer-type-errors - = continueWith ct_w - - | let (matching_irreds, others) = findMatchingIrreds (inert_irreds inerts) ev_w - , ((ct_i, swap) : _rest) <- bagToList matching_irreds - -- See Note [Multiple matching irreds] - , let ev_i = ctEvidence ct_i - = do { traceTcS "iteractIrred" $ - 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 (swap_me swap ev_i) - ; return (Stop ev_w (text "Irred equal:KeepInert" <+> ppr ct_w)) } - KeepWork -> do { setEvBindIfWanted ev_i (swap_me swap ev_w) - ; updInertIrreds (\_ -> others) - ; continueWith ct_w } } - - | otherwise - = continueWith ct_w - - where - swap_me :: SwapFlag -> CtEvidence -> EvTerm - swap_me swap ev - = case swap of - NotSwapped -> ctEvTerm ev - IsSwapped -> evCoercion (mkSymCo (evTermCoercion (ctEvTerm ev))) - -interactIrred _ wi = pprPanic "interactIrred" (ppr wi) - -findMatchingIrreds :: Cts -> CtEvidence -> (Bag (Ct, SwapFlag), Bag Ct) -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 ct - | ctPred ct `tcEqTypeNoKindCheck` pred = Left (ct, NotSwapped) - | otherwise = Right ct - - match_eq eq_rel1 lty1 rty1 ct - | EqPred eq_rel2 lty2 rty2 <- classifyPredType (ctPred ct) - , eq_rel1 == eq_rel2 - , Just swap <- match_eq_help lty1 rty1 lty2 rty2 - = Left (ct, swap) - | otherwise - = Right ct - - 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. --} - -{- -********************************************************************************* -* * - interactDict -* * -********************************************************************************* - -Note [Shortcut solving] -~~~~~~~~~~~~~~~~~~~~~~~ -When we interact a [W] constraint with a [G] constraint that solves it, there is -a possibility that we could produce better code if instead we solved from a -top-level instance declaration (See #12791, #5835). For example: - - class M a b where m :: a -> b - - type C a b = (Num a, M a b) - - f :: C Int b => b -> Int -> Int - f _ x = x + 1 - -The body of `f` requires a [W] `Num Int` instance. We could solve this -constraint from the givens because we have `C Int b` and that provides us a -solution for `Num Int`. This would let us produce core like the following -(with -O2): - - f :: forall b. C Int b => b -> Int -> Int - f = \ (@ b) ($d(%,%) :: C Int b) _ (eta1 :: Int) -> - + @ Int - (GHC.Classes.$p1(%,%) @ (Num Int) @ (M Int b) $d(%,%)) - eta1 - A.f1 - -This is bad! We could do /much/ better if we solved [W] `Num Int` directly -from the instance that we have in scope: - - f :: forall b. C Int b => b -> Int -> Int - f = \ (@ b) _ _ (x :: Int) -> - 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]... - -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. - -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. - -An example that succeeds: - - class Eq a => C a b | b -> a where - m :: b -> a - - f :: C [Int] b => b -> Bool - f x = m x == [] - -We solve for `Eq [Int]`, which requires `Eq Int`, which we also have. This -produces the following core: - - f :: forall b. C [Int] b => b -> Bool - f = \ (@ b) ($dC :: C [Int] b) (x :: b) -> - GHC.Classes.$fEq[]_$s$c== - (m @ [Int] @ b $dC x) (GHC.Types.[] @ Int) - -An example that fails: - - class Eq a => C a b | b -> a where - m :: b -> a - - f :: C [a] b => b -> Bool - f x = m x == [] - -Which, because solving `Eq [a]` demands `Eq a` which we cannot solve, produces: - - f :: forall a b. C [a] b => b -> Bool - f = \ (@ a) (@ b) ($dC :: C [a] b) (eta :: b) -> - == - @ [a] - (A.$p1C @ [a] @ b $dC) - (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 .. - -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). - -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). - -Note [Shortcut solving: incoherence] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -This optimization relies on coherence of dictionaries to be correct. When we -cannot assume coherence because of IncoherentInstances then this optimization -can change the behavior of the user's code. - -The following four modules produce a program whose output would change depending -on whether we apply this optimization when IncoherentInstances is in effect: - -========= - {-# LANGUAGE MultiParamTypeClasses #-} - module A where - - class A a where - int :: a -> Int - - class A a => C a b where - m :: b -> a -> a - -========= - {-# LANGUAGE FlexibleInstances #-} - {-# LANGUAGE MultiParamTypeClasses #-} - module B where - - import A - - instance A a where - int _ = 1 - - instance C a [b] where - m _ = id - -========= - {-# LANGUAGE FlexibleContexts #-} - {-# LANGUAGE FlexibleInstances #-} - {-# LANGUAGE IncoherentInstances #-} - {-# LANGUAGE MultiParamTypeClasses #-} - module C where - - import A - - instance A Int where - int _ = 2 - - instance C Int [Int] where - m _ = id - - intC :: C Int a => a -> Int -> Int - intC _ x = int x - -========= - module Main where - - import A - import B - import C - - main :: IO () - main = print (intC [] (0::Int)) - -The output of `main` if we avoid the optimization under the effect of -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: -* Given/Given interactions via functional dependencies or type family - injectivity annotations. -* Given/instance fundep interactions via functional dependencies or - type family injectivity annotations. - -In this Note, all these interactions are called just "fundeps". - -We ingore such fundeps for several reasons: - -1. These fundeps will never serve a purpose in accepting more - programs: Given constraints do not contain metavariables that could - be unified via exploring fundeps. They *could* be useful in - discovering inaccessible code. However, the constraints will be - Wanteds, and as such will cause errors (not just warnings) if they - go unsolved. Maybe there is a clever way to get the right - inaccessible code warnings, but the path forward is far from - clear. #12466 has further commentary. - -2. Furthermore, here is a case where a Given/instance interaction is actively - harmful (from dependent/should_compile/RaeJobTalk): - - type family a == b :: Bool - type family Not a = r | r -> a where - Not False = True - Not True = False - - [G] Not (a == b) ~ True - - Reacting this Given with the equations for Not produces - - [W] a == b ~ False - - This is indeed a true consequence, and would make sense as a fresh Given. - But we don't have a way to produce evidence for fundeps, as a Wanted it - is /harmful/: we can't prove it, and so we'll report an error and reject - the program. (Previously fundeps gave rise to Deriveds, which - carried no evidence, so it didn't matter that they could not be proved.) - -3. #20922 showed a subtle different problem with Given/instance fundeps. - type family ZipCons (as :: [k]) (bssx :: [[k]]) = (r :: [[k]]) | r -> as bssx where - ZipCons (a ': as) (bs ': bss) = (a ': bs) ': ZipCons as bss - ... - - tclevel = 4 - [G] ZipCons is1 iss ~ (i : is2) : jss - - (The tclevel=4 means that this Given is at level 4.) The fundep tells us that - 'iss' must be of form (is2 : beta[4]) where beta[4] is a fresh unification - variable; we don't know what type it stands for. So we would emit - [W] iss ~ is2 : beta - - Again we can't prove that equality; and worse we'll rewrite iss to - (is2:beta) in deeply nested constraints inside this implication, - where beta is untouchable (under other equality constraints), leading - to other insoluble constraints. - -The bottom line: since we have no evidence for them, we should ignore Given/Given -and Given/instance fundeps entirely. --} - -interactDict :: InertCans -> Ct -> TcS (StopOrContinue Ct) -interactDict inerts ct_w@(CDictCan { cc_ev = ev_w, cc_class = cls, cc_tyargs = tys }) - | Just ct_i <- lookupInertDict inerts (ctEvLoc ev_w) cls tys - , let ev_i = ctEvidence ct_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 - -- 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" - - -- 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 ct_w - 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 ct_i ct_w of - KeepInert -> do { traceTcS "lookupInertDict:KeepInert" (ppr ct_w) - ; setEvBindIfWanted ev_w (ctEvTerm ev_i) - ; return $ Stop ev_w (text "Dict equal" <+> ppr ct_w) } - KeepWork -> do { traceTcS "lookupInertDict:KeepWork" (ppr ct_w) - ; setEvBindIfWanted ev_i (ctEvTerm ev_w) - ; updInertDicts $ \ ds -> delDict ds cls tys - ; continueWith ct_w } } } - - | cls `hasKey` ipClassKey - , isGiven ev_w - = interactGivenIP inerts ct_w - - | otherwise - = do { addFunDepWork inerts ev_w cls - ; continueWith ct_w } - -interactDict _ wi = pprPanic "interactDict" (ppr wi) - --- 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 - = 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 CtEvidence) -> CtEvidence - -> MaybeT TcS (EvBindMap, DictMap CtEvidence) - try_solve_from_instance (ev_binds, solved_dicts) ev - | let pred = ctEvPred ev - loc = ctEvLoc 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_what = what } - | safeOverlap what - , all isTyFamFree preds -- Note [Shortcut solving: type families] - -> do { let solved_dicts' = addDict solved_dicts cls tys ev - -- 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 loc what pred - ; lift $ checkReductionDepth loc' pred - - - ; 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. - - ; let ev_tm = mk_ev (map getEvExpr evc_vs) - ev_binds' = extendEvBinds ev_binds $ - mkWantedEvBind (ctEvEvId ev) ev_tm - - ; foldlM try_solve_from_instance - (ev_binds', solved_dicts') - (freshGoals evc_vs) } - - _ -> mzero } - | otherwise = mzero - - - -- 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 CtEvidence -> 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 ctev -> return $ Cached (ctEvExpr ctev) - Nothing -> Fresh <$> newWantedNC loc (ctEvRewriters ev_w) pty - | otherwise = mzero - -addFunDepWork :: InertCans -> CtEvidence -> Class -> TcS () --- Add wanted constraints from type-class functional dependencies. -addFunDepWork inerts work_ev cls - = mapBagM_ add_fds (findDictsByClass (inert_dicts inerts) cls) - -- No need to check flavour; fundeps work between - -- any pair of constraints, regardless of flavour - -- Importantly we don't throw workitem back in the - -- worklist because this can cause loops (see #5236) - where - work_pred = ctEvPred work_ev - work_loc = ctEvLoc work_ev - - add_fds inert_ct - = do { traceTcS "addFunDepWork" (vcat - [ ppr work_ev - , pprCtLoc work_loc, ppr (isGivenLoc work_loc) - , pprCtLoc inert_loc, ppr (isGivenLoc inert_loc) - , pprCtLoc derived_loc, ppr (isGivenLoc derived_loc) ]) - - ; unless (isGiven work_ev && isGiven inert_ev) $ - emitFunDepWanteds (ctEvRewriters work_ev) $ - improveFromAnother (derived_loc, inert_rewriters) inert_pred work_pred - -- We don't really rewrite tys2, see below _rewritten_tys2, so that's ok - -- Do not create FDs from Given/Given interactions: See Note [No Given/Given fundeps] - } - where - inert_ev = ctEvidence inert_ct - inert_pred = ctEvPred inert_ev - inert_loc = ctEvLoc inert_ev - inert_rewriters = ctRewriters inert_ct - derived_loc = work_loc { ctl_depth = ctl_depth work_loc `maxSubGoalDepth` - ctl_depth inert_loc - , ctl_origin = FunDepOrigin1 work_pred - (ctLocOrigin work_loc) - (ctLocSpan work_loc) - inert_pred - (ctLocOrigin inert_loc) - (ctLocSpan inert_loc) } - -{- -********************************************************************** -* * - Implicit parameters -* * -********************************************************************** --} - -interactGivenIP :: InertCans -> Ct -> TcS (StopOrContinue Ct) --- Work item is Given (?x:ty) --- See Note [Shadowing of Implicit Parameters] -interactGivenIP inerts workItem@(CDictCan { cc_ev = ev, cc_class = cls - , cc_tyargs = tys@(ip_str:_) }) - = do { updInertCans $ \cans -> cans { inert_dicts = addDict filtered_dicts cls tys workItem } - ; stopWith ev "Given IP" } - where - dicts = inert_dicts inerts - ip_dicts = findDictsByClass dicts cls - other_ip_dicts = filterBag (not . is_this_ip) ip_dicts - filtered_dicts = addDictsByClass dicts cls other_ip_dicts - - -- Pick out any Given constraints for the same implicit parameter - is_this_ip (CDictCan { cc_ev = ev, cc_tyargs = ip_str':_ }) - = isGiven ev && ip_str `tcEqType` ip_str' - is_this_ip _ = False - -interactGivenIP _ wi = pprPanic "interactGivenIP" (ppr wi) - -{- Note [Shadowing of Implicit Parameters] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider the following example: - -f :: (?x :: Char) => Char -f = let ?x = 'a' in ?x - -The "let ?x = ..." generates an implication constraint of the form: - -?x :: Char => ?x :: Char - -Furthermore, the signature for `f` also generates an implication -constraint, so we end up with the following nested implication: - -?x :: Char => (?x :: Char => ?x :: Char) - -Note that the wanted (?x :: Char) constraint may be solved in -two incompatible ways: either by using the parameter from the -signature, or by using the local definition. Our intention is -that the local definition should "shadow" the parameter of the -signature, and we implement this as follows: when we add a new -*given* implicit parameter to the inert set, it replaces any existing -givens for the same implicit parameter. - -Similarly, consider - f :: (?x::a) => Bool -> a - - g v = let ?x::Int = 3 - in (f v, let ?x::Bool = True in f v) - -This should probably be well typed, with - g :: Bool -> (Int, Bool) - -So the inner binding for ?x::Bool *overrides* the outer one. - -See ticket #17104 for a rather tricky example of this overriding -behaviour. - -All this works for the normal cases but it has an odd side effect in -some pathological programs like this: --- This is accepted, the second parameter shadows -f1 :: (?x :: Int, ?x :: Char) => Char -f1 = ?x - --- This is rejected, the second parameter shadows -f2 :: (?x :: Int, ?x :: Char) => Int -f2 = ?x - -Both of these are actually wrong: when we try to use either one, -we'll get two incompatible wanted constraints (?x :: Int, ?x :: Char), -which would lead to an error. - -I can think of two ways to fix this: - - 1. Simply disallow multiple constraints for the same implicit - parameter---this is never useful, and it can be detected completely - syntactically. - - 2. Move the shadowing machinery to the location where we nest - implications, and add some code here that will produce an - error if we get multiple givens for the same implicit parameter. - - -********************************************************************** -* * - interactFunEq -* * -********************************************************************** --} - -improveLocalFunEqs :: CtEvidence -> InertCans -> TyCon -> [TcType] -> TcType - -> TcS () --- 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 work_ev inerts fam_tc args rhs - = unless (null improvement_eqns) $ - do { traceTcS "interactFunEq improvements: " $ - vcat [ text "Eqns:" <+> ppr improvement_eqns - , text "Candidates:" <+> ppr funeqs_for_tc - , text "Inert eqs:" <+> ppr (inert_eqs inerts) ] - ; emitFunDepWanteds (ctEvRewriters work_ev) improvement_eqns } - where - funeqs = inert_funeqs inerts - funeqs_for_tc = [ funeq_ct | equal_ct_list <- findFunEqsByTyCon funeqs fam_tc - , funeq_ct <- equal_ct_list - , NomEq == ctEqRel 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 (CEqCan { cc_lhs = TyFamLHS _ iargs, cc_rhs = irhs, cc_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) - - -------------------- - -- See Note [Type inference for type families with injectivity] - do_one_injective inj_args rhs (CEqCan { cc_lhs = TyFamLHS _ inert_args - , cc_rhs = irhs, cc_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) - - -------------------- - 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) - inert_pred (ctLocOrigin inert_loc) (ctLocSpan inert_loc) - eqn_loc = setCtLocOrigin initial_loc eqn_orig - inert_pred = ctEvPred inert_ev - inert_loc = ctEvLoc inert_ev - inert_rewriters = ctEvRewriters inert_ev - loc = eqn_loc { ctl_depth = ctl_depth inert_loc `maxSubGoalDepth` - ctl_depth work_loc } - -{- Note [Type inference for type families with injectivity] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose we have a type family with an injectivity annotation: - type family F a b = r | r -> b - -Then if we have an equality like F s1 t1 ~ F s2 t2, -we can use the injectivity to get a new Wanted constraint on -the injective argument - [W] t1 ~ t2 - -That in turn can help GHC solve constraints that would otherwise require -guessing. For example, consider the ambiguity check for - f :: F Int b -> Int -We get the constraint - [W] F Int b ~ F Int beta -where beta is a unification variable. Injectivity lets us pick beta ~ b. - -Injectivity information is also used at the call sites. For example: - g = f True -gives rise to - [W] F Int b ~ Bool -from which we can derive b. This requires looking at the defining equations of -a type family, ie. finding equation with a matching RHS (Bool in this example) -and inferring values of type variables (b in this example) from the LHS patterns -of the matching equation. For closed type families we have to perform -additional apartness check for the selected equation to check that the selected -is guaranteed to fire for given LHS arguments. - -These new constraints are Wanted constraints, but we will not use the evidence. -We could go further and offer evidence from decomposing injective type-function -applications, but that would require new evidence forms, and an extension to -FC, so we don't do that right now (Dec 14). - -We generate these Wanteds in three places, depending on how we notice the -injectivity. - -1. When we have a [W] F tys1 ~ F tys2. This is handled in canEqCanLHS2, and -described in Note [Decomposing type family applications] in GHC.Tc.Solver.Canonical. - -2. When we have [W] F tys1 ~ T and [W] F tys2 ~ T. Note that neither of these -constraints rewrites the other, as they have different LHSs. This is done -in improveLocalFunEqs, called during the interactWithInertsStage. - -3. When we have [W] F tys ~ T and an equation for F that looks like F tys' = T. -This is done in improve_top_fun_eqs, called from the top-level reactions stage. - -See also Note [Injective type families] in GHC.Core.TyCon - -Note [Cache-caused loops] -~~~~~~~~~~~~~~~~~~~~~~~~~ -It is very dangerous to cache a rewritten wanted family equation as 'solved' in our -solved cache (which is the default behaviour or xCtEvidence), because the interaction -may not be contributing towards a solution. Here is an example: - -Initial inert set: - [W] g1 : F a ~ beta1 -Work item: - [W] g2 : F a ~ beta2 -The work item will react with the inert yielding the _same_ inert set plus: - (i) Will set g2 := g1 `cast` g3 - (ii) Will add to our solved cache that [S] g2 : F a ~ beta2 - (iii) Will emit [W] g3 : beta1 ~ beta2 -Now, the g3 work item will be spontaneously solved to [G] g3 : beta1 ~ beta2 -and then it will react the item in the inert ([W] g1 : F a ~ beta1). So it -will set - g1 := g ; sym g3 -and what is g? Well it would ideally be a new goal of type (F a ~ beta2) but -remember that we have this in our solved cache, and it is ... g2! In short we -created the evidence loop: - - g2 := g1 ; g3 - g3 := refl - g1 := g2 ; sym g3 - -To avoid this situation we do not cache as solved any workitems (or inert) -which did not really made a 'step' towards proving some goal. Solved's are -just an optimization so we don't lose anything in terms of completeness of -solving. - -********************************************************************** -* * - interactEq -* * -********************************************************************** --} - -{- 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. --} - -inertsCanDischarge :: InertCans -> Ct - -> Maybe ( CtEvidence -- The evidence for the inert - , SwapFlag ) -- Whether we need mkSymCo -inertsCanDischarge inerts (CEqCan { cc_lhs = lhs_w, cc_rhs = rhs_w - , cc_ev = ev_w, cc_eq_rel = eq_rel }) - | (ev_i : _) <- [ ev_i | CEqCan { cc_ev = ev_i, cc_rhs = rhs_i - , cc_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 | CEqCan { cc_ev = ev_i, cc_rhs = rhs_i - , cc_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 - - -interactEq :: InertCans -> Ct -> TcS (StopOrContinue Ct) -interactEq inerts workItem@(CEqCan { cc_lhs = lhs - , cc_rhs = rhs - , cc_ev = ev - , cc_eq_rel = eq_rel }) - | Just (ev_i, swapped) <- inertsCanDischarge inerts workItem - = do { setEvBindIfWanted ev $ - evCoercion (maybeSymCo swapped $ - downgradeRole (eqRelRole eq_rel) - (ctEvRole ev_i) - (ctEvCoercion ev_i)) - - ; stopWith ev "Solved from inert" } - - | ReprEq <- eq_rel -- See Note [Do not unify representational equalities] - = do { traceTcS "Not unifying representational equality" (ppr workItem) - ; continueWith workItem } - - | otherwise - = case lhs of - TyVarLHS tv -> tryToSolveByUnification workItem ev tv rhs - - TyFamLHS tc args -> do { improveLocalFunEqs ev inerts tc args rhs - ; continueWith workItem } - -interactEq _ wi = pprPanic "interactEq" (ppr wi) - ----------------------- --- We have a meta-tyvar on the left, and metaTyVarUpdateOK has said "yes" --- So try to solve by unifying. --- Three reasons why not: --- Skolem escape --- Given equalities (GADTs) --- Unifying a TyVarTv with a non-tyvar type -tryToSolveByUnification :: Ct -> CtEvidence - -> TcTyVar -- LHS tyvar - -> TcType -- RHS - -> TcS (StopOrContinue Ct) -tryToSolveByUnification work_item ev tv rhs - = do { (is_touchable, rhs) <- touchabilityTest (ctEvFlavour ev) tv rhs - ; traceTcS "tryToSolveByUnification" (vcat [ ppr tv <+> char '~' <+> ppr rhs - , ppr is_touchable ]) - - ; case is_touchable of - Untouchable -> continueWith work_item - -- For the latter two cases see Note [Solve by unification] - TouchableSameLevel -> solveByUnification ev tv rhs - TouchableOuterLevel free_metas tv_lvl - -> do { wrapTcS $ mapM_ (promoteMetaTyVarTo tv_lvl) free_metas - ; setUnificationFlag tv_lvl - ; solveByUnification ev tv rhs } } - -solveByUnification :: CtEvidence -> TcTyVar -> Xi -> TcS (StopOrContinue Ct) --- Solve with the identity coercion --- Precondition: kind(xi) equals kind(tv) --- Precondition: CtEvidence is Wanted --- Precondition: CtEvidence is nominal --- Returns: workItem where --- workItem = the new Given constraint --- --- NB: No need for an occurs check here, because solveByUnification always --- arises from a CEqCan, a *canonical* constraint. Its invariant (TyEq:OC) --- says that in (a ~ xi), the type variable a does not appear in xi. --- See GHC.Tc.Types.Constraint.Ct invariants. --- --- Post: tv is unified (by side effect) with xi; --- we often write tv := xi -solveByUnification wd tv xi - = do { let tv_ty = mkTyVarTy tv - ; traceTcS "Sneaky unification:" $ - vcat [text "Unifies:" <+> ppr tv <+> text ":=" <+> ppr xi, - text "Coercion:" <+> pprEq tv_ty xi, - text "Left Kind is:" <+> ppr (typeKind tv_ty), - text "Right Kind is:" <+> ppr (typeKind xi) ] - ; unifyTyVar tv xi - ; setEvBindIfWanted wd (evCoercion (mkNomReflCo xi)) - ; n_kicked <- kickOutAfterUnification tv - ; return (Stop wd (text "Solved by unification" <+> pprKicked n_kicked)) } - -{- Note [Avoid double unifications] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The spontaneous solver has to return a given which mentions the unified unification -variable *on the left* of the equality. Here is what happens if not: - Original wanted: (a ~ alpha), (alpha ~ Int) -We spontaneously solve the first wanted, without changing the order! - given : a ~ alpha [having unified alpha := a] -Now the second wanted comes along, but it cannot rewrite the given, so we simply continue. -At the end we spontaneously solve that guy, *reunifying* [alpha := Int] - -We avoid this problem by orienting the resulting given so that the unification -variable is on the left (note that alternatively we could attempt to -enforce this at canonicalization). - -See also Note [No touchables as FunEq RHS] in GHC.Tc.Solver.Monad; avoiding -double unifications is the main reason we disallow touchable -unification variables as RHS of type family equations: F xis ~ alpha. - -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.) - - -************************************************************************ -* * -* Functional dependencies, instantiation of equations -* * -************************************************************************ - -When we spot an equality arising from a functional dependency, -we now use that equality (a "wanted") to rewrite the work-item -constraint right away. This avoids two dangers - - Danger 1: If we send the original constraint on down the pipeline - it may react with an instance declaration, and in delicate - situations (when a Given overlaps with an instance) that - may produce new insoluble goals: see #4952 - - Danger 2: If we don't rewrite the constraint, it may re-react - with the same thing later, and produce the same equality - again --> termination worries. - -To achieve this required some refactoring of GHC.Tc.Instance.FunDeps (nicer -now!). - -Note [FunDep and implicit parameter reactions] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Currently, our story of interacting two dictionaries (or a dictionary -and top-level instances) for functional dependencies, and implicit -parameters, is that we simply produce new Wanted equalities. So for example - - class D a b | a -> b where ... - Inert: - d1 :g D Int Bool - WorkItem: - d2 :w D Int alpha - - We generate the extra work item - cv :w 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 - d2 := d2' |> D Int cv - Now d2' can be discharged from d1 - -We could be more aggressive and try to *immediately* solve the dictionary -using those extra equalities. - -If that were the case with the same inert set and work item we might discard -d2 directly: - - cv :w 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 -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 -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 -"aggressive" approach would be much easier to implement. - -Note [Fundeps with instances, and equality orientation] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -This Note describes a delicate interaction that constrains the orientation of -equalities. This one is about fundeps, but the /exact/ same thing arises for -type-family injectivity constraints: see Note [Improvement orientation]. - -doTopFundepImprovement compares the constraint with all the instance -declarations, to see if we can produce any equalities. E.g - class C2 a b | a -> b - instance C Int Bool -Then the constraint (C Int ty) generates the equality [W] ty ~ Bool. - -There is a nasty corner in #19415 which led to the typechecker looping: - class C s t b | s -> t - instance ... => C (T kx x) (T ky y) Int - T :: forall k. k -> Type - - work_item: dwrk :: C (T @ka (a::ka)) (T @kb0 (b0::kb0)) Char - where kb0, b0 are unification vars - - ==> {doTopFundepImprovement: compare work_item with instance, - generate /fresh/ unification variables kfresh0, yfresh0, - emit a new Wanted, and add dwrk to inert set} - - Suppose we emit this new Wanted from the fundep: - [W] T kb0 (b0::kb0) ~ T kfresh0 (yfresh0::kfresh0) - - ==> {solve that equality kb0 := kfresh0, b0 := yfresh0} - Now kick out dwrk, since it mentions kb0 - But now we are back to the start! Loop! - -NB1: This example relies on an instance that does not satisfy the - coverage condition (although it may satisfy the weak coverage - condition), and hence whose fundeps generate fresh unification - variables. Not satisfying the coverage condition is known to - lead to termination trouble, but in this case it's plain silly. - -NB2: In this example, the third parameter to C ensures that the - instance doesn't actually match the Wanted, so we can't use it to - solve the Wanted - -We solve the problem by (#21703): - - carefully orienting the new Wanted so that all the - freshly-generated unification variables are on the LHS. - - Thus we emit - [W] T kfresh0 (yfresh0::kfresh0) ~ T kb0 (b0::kb0) - and /NOT/ - [W] T kb0 (b0::kb0) ~ T kfresh0 (yfresh0::kfresh0) - -Now we'll unify kfresh0:=kb0, yfresh0:=b0, and all is well. The general idea -is that we want to preferentially eliminate those freshly-generated -unification variables, rather than unifying older variables, which causes -kick-out etc. - -Keeping younger variables on the left also gives very minor improvement in -the compiler performance by having less kick-outs and allocations (-0.1% on -average). Indeed Historical Note [Eliminate younger unification variables] -in GHC.Tc.Utils.Unify describes an earlier attempt to do so systematically, -apparently now in abeyance. - -But this is is a delicate solution. We must take care to /preserve/ -orientation during solving. Wrinkles: - -(W1) We start with - [W] T kfresh0 (yfresh0::kfresh0) ~ T kb0 (b0::kb0) - Decompose to - [W] kfresh0 ~ kb0 - [W] (yfresh0::kfresh0) ~ (b0::kb0) - Preserve orientiation when decomposing!! - -(W2) Suppose we happen to tackle the second Wanted from (W1) - first. Then in canEqCanLHSHetero we emit a /kind/ equality, as - well as a now-homogeneous type equality - [W] kco : kfresh0 ~ kb0 - [W] (yfresh0::kfresh0) ~ (b0::kb0) |> (sym kco) - Preserve orientation in canEqCanLHSHetero!! (Failing to - preserve orientation here was the immediate cause of #21703.) - -(W3) There is a potential interaction with the swapping done by - GHC.Tc.Utils.Unify.swapOverTyVars. We think it's fine, but it's - a slight worry. See especially Note [TyVar/TyVar orientation] in - that module. - -The trouble is that "preserving orientation" is a rather global invariant, -and sometimes we definitely do want to swap (e.g. Int ~ alpha), so we don't -even have a precise statement of what the invariant is. The advantage -of the preserve-orientation plan is that it is extremely cheap to implement, -and apparently works beautifully. - ---- Alternative plan (1) --- -Rather than have an ill-defined invariant, another possiblity is to -elminate those fresh unification variables at birth, when generating -the new fundep-inspired equalities. - -The key idea is to call `instFlexiX` in `emitFunDepWanteds` on only those -type variables that are guaranteed to give us some progress. This means we -have to locally (without calling emitWanteds) identify the type variables -that do not give us any progress. In the above example, we _know_ that -emitting the two wanteds `kco` and `co` is fruitless. - - Q: How do we identify such no-ops? - - 1. Generate a matching substitution from LHS to RHS - ɸ = [kb0 :-> k0, b0 :-> y0] - 2. Call `instFlexiX` on only those type variables that do not appear in the domain of ɸ - ɸ' = instFlexiX ɸ (tvs - domain ɸ) - 3. Apply ɸ' on LHS and then call emitWanteds - unifyWanteds ... (subst ɸ' LHS) RHS - -Why will this work? The matching substitution ɸ will be a best effort -substitution that gives us all the easy solutions. It can be generated with -modified version of `Core/Unify.unify_tys` where we run it in a matching mode -and never generate `SurelyApart` and always return a `MaybeApart Subst` -instead. - -The same alternative plan would work for type-family injectivity constraints: -see Note [Improvement orientation]. ---- End of Alternative plan (1) --- - ---- Alternative plan (2) --- -We could have a new flavour of TcTyVar (like `TauTv`, `TyVarTv` etc; see GHC.Tc.Utils.TcType.MetaInfo) -for the fresh unification variables introduced by functional dependencies. Say `FunDepTv`. Then in -GHC.Tc.Utils.Unify.swapOverTyVars we could arrange to keep a `FunDepTv` on the left if possible. -Looks possible, but it's one more complication. ---- End of Alternative plan (2) --- - - ---- Historical note: Failed Alternative Plan (3) --- -Previously we used a flag `cc_fundeps` in `CDictCan`. It would flip to False -once we used a fun dep to hint the solver to break and to stop emitting more -wanteds. This solution was not complete, and caused a failures while trying -to solve for transitive functional dependencies (test case: T21703) --- End of Historical note: Failed Alternative Plan (3) -- - -Note [Weird fundeps] -~~~~~~~~~~~~~~~~~~~~ -Consider class Het a b | a -> b where - het :: m (f c) -> a -> m b - - class GHet (a :: * -> *) (b :: * -> *) | a -> b - instance GHet (K a) (K [a]) - instance Het a b => GHet (K a) (K b) - -The two instances don't actually conflict on their fundeps, -although it's pretty strange. So they are both accepted. Now -try [W] GHet (K Int) (K Bool) -This triggers fundeps from both instance decls; - [W] K Bool ~ K [a] - [W] K Bool ~ K beta -And there's a risk of complaining about Bool ~ [a]. But in fact -the Wanted matches the second instance, so we never get as far -as the fundeps. - -#7875 is a case in point. --} - -doTopFundepImprovement :: Ct -> TcS () --- Try to functional-dependency improvement between the constraint --- and the top-level instance declarations --- See Note [Fundeps with instances, and equality orientation] --- See also Note [Weird fundeps] -doTopFundepImprovement work_item@(CDictCan { cc_ev = ev, cc_class = cls - , cc_tyargs = xis }) - = do { traceTcS "try_fundeps" (ppr work_item) - ; instEnvs <- getInstEnvs - ; let fundep_eqns = improveFromInstEnv instEnvs mk_ct_loc cls xis - ; emitFunDepWanteds (ctEvRewriters ev) fundep_eqns } - where - dict_pred = mkClassPred cls xis - dict_loc = ctEvLoc ev - dict_origin = ctLocOrigin dict_loc - - mk_ct_loc :: PredType -- From instance decl - -> SrcSpan -- also from instance deol - -> (CtLoc, RewriterSet) - mk_ct_loc inst_pred inst_loc - = ( dict_loc { ctl_origin = FunDepOrigin2 dict_pred dict_origin - inst_pred inst_loc } - , emptyRewriterSet ) - -doTopFundepImprovement work_item = pprPanic "doTopFundepImprovement" (ppr work_item) - -emitFunDepWanteds :: RewriterSet -- from the work item - -> [FunDepEqn (CtLoc, RewriterSet)] -> TcS () - -emitFunDepWanteds _ [] = return () -- common case noop --- See Note [FunDep and implicit parameter reactions] - -emitFunDepWanteds work_rewriters fd_eqns - = mapM_ do_one_FDEqn fd_eqns - where - do_one_FDEqn (FDEqn { fd_qtvs = tvs, fd_eqs = eqs, fd_loc = (loc, rewriters) }) - | null tvs -- Common shortcut - = do { traceTcS "emitFunDepWanteds 1" (ppr (ctl_depth loc) $$ ppr eqs $$ ppr (isGivenLoc loc)) - ; mapM_ (\(Pair ty1 ty2) -> unifyWanted all_rewriters loc Nominal ty1 ty2) - (reverse eqs) } - -- See Note [Reverse order of fundep equations] - - | otherwise - = do { traceTcS "emitFunDepWanteds 2" (ppr (ctl_depth loc) $$ ppr tvs $$ ppr eqs) - ; subst <- instFlexiX emptySubst tvs -- Takes account of kind substitution - ; mapM_ (do_one_eq loc all_rewriters subst) (reverse eqs) } - -- See Note [Reverse order of fundep equations] - where - all_rewriters = work_rewriters S.<> rewriters - - do_one_eq loc rewriters subst (Pair ty1 ty2) - = unifyWanted rewriters loc Nominal (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) - where - 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. - -{- -********************************************************************** -* * - The top-reaction Stage -* * -********************************************************************** --} - -topReactionsStage :: WorkItem -> TcS (StopOrContinue Ct) --- The work item does not react with the inert set, --- so try interaction with top-level instances. -topReactionsStage work_item - = do { traceTcS "doTopReact" (ppr work_item) - ; case work_item of - - CDictCan {} -> - do { inerts <- getTcSInerts - ; doTopReactDict inerts work_item } - - CEqCan {} -> - doTopReactEq work_item - - CIrredCan {} -> - doTopReactOther work_item - - -- Any other work item does not react with any top-level equations - _ -> continueWith work_item } - --------------------- -doTopReactOther :: Ct -> TcS (StopOrContinue Ct) --- Try local quantified constraints for --- CEqCan e.g. (lhs ~# ty) --- and CIrredCan e.g. (c a) --- --- Why equalities? See GHC.Tc.Solver.Canonical --- Note [Equality superclasses in quantified constraints] -doTopReactOther work_item - | isGiven ev - = continueWith work_item - - | EqPred eq_rel t1 t2 <- classifyPredType pred - = doTopReactEqPred work_item eq_rel t1 t2 - - | otherwise - = do { res <- matchLocalInst pred loc - ; case res of - OneInst {} -> chooseInstance ev res - _ -> continueWith work_item } - - where - ev = ctEvidence work_item - loc = ctEvLoc ev - pred = ctEvPred ev - -{-******************************************************************** -* * - Top-level reaction for equality constraints (CEqCan) -* * -********************************************************************-} - -doTopReactEqPred :: Ct -> EqRel -> TcType -> TcType -> TcS (StopOrContinue Ct) -doTopReactEqPred work_item eq_rel lhs rhs - -- See Note [Looking up primitive equalities in quantified constraints] - = 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 work_item } - where - ev = ctEvidence work_item - 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 "final_qci_check: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 work_item - - 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 "final_qci_check: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 "final_qci_check:3" (ppr work_item) - ; continueWith work_item }} - | otherwise - = continueWith work_item - - mk_eq_ev cls tys mk_ev evs - = case (mk_ev evs) of - EvExpr e -> EvExpr (Var sc_id `mkTyApps` tys `App` e) - ev -> pprPanic "mk_eq_ev" (ppr ev) - where - [sc_id] = classSCSelIds cls - -{- 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.Canonical - -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 unifyWanted, 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] -in GHC.Tc.Solver.Canonical). However, the idea of working left-to-right still -seems worthwhile, and so the calls to 'reverse' remain. - --} - --------------------- -doTopReactEq :: Ct -> TcS (StopOrContinue Ct) -doTopReactEq work_item@(CEqCan { cc_ev = old_ev, cc_lhs = TyFamLHS fam_tc args - , cc_rhs = rhs }) - = do { improveTopFunEqs old_ev fam_tc args rhs - ; doTopReactOther work_item } -doTopReactEq work_item = doTopReactOther work_item - -improveTopFunEqs :: CtEvidence -> TyCon -> [TcType] -> TcType -> TcS () --- See Note [FunDep and implicit parameter reactions] -improveTopFunEqs ev fam_tc args rhs - | isGiven ev -- See Note [No Given/Given fundeps] - = return () - - | 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 ]) - ; mapM_ (\(Pair ty1 ty2) -> unifyWanted rewriters loc Nominal ty1 ty2) - (reverse eqns) } - -- Missing that `reverse` causes T13135 and T13135_simple to loop. - -- See Note [Reverse order of fundep equations] - where - loc = bumpCtLocDepth (ctEvLoc ev) - -- ToDo: this location is wrong; it should be FunDepOrigin2 - -- See #14778 - rewriters = ctEvRewriters ev - -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 ] } - -{- -Note [MATCHING-SYNONYMS] -~~~~~~~~~~~~~~~~~~~~~~~~ -When trying to match a dictionary (D tau) to a top-level instance, or a -type family equation (F taus_1 ~ tau_2) to a top-level family instance, -we do *not* need to expand type synonyms because the matcher will do that for us. - -Note [Improvement orientation] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -See also Note [Fundeps with instances, and equality orientation], which describes -the Exact Same Prolem, 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. - --} - -{- ******************************************************************* -* * - Top-level reaction for class constraints (CDictCan) -* * -**********************************************************************-} - -doTopReactDict :: InertSet -> Ct -> TcS (StopOrContinue Ct) --- Try to use type-class instance declarations to simplify the constraint -doTopReactDict inerts work_item@(CDictCan { cc_ev = ev, cc_class = cls - , cc_tyargs = xis }) - | isGiven ev -- Never use instances for Given constraints - = continueWith work_item - -- See Note [No Given/Given fundeps] - - | Just solved_ev <- lookupSolvedDict inerts dict_loc cls xis -- Cached - = do { setEvBindIfWanted ev (ctEvTerm solved_ev) - ; stopWith ev "Dict/Top (cached)" } - - | otherwise -- Wanted, but not cached - = do { dflags <- getDynFlags - ; lkup_res <- matchClassInst dflags inerts cls xis dict_loc - ; case lkup_res of - OneInst { cir_what = what } - -> do { insertSafeOverlapFailureTcS what work_item - ; addSolvedDict what ev cls xis - ; chooseInstance ev lkup_res } - _ -> -- NoInstance or NotSure - -- We didn't solve it; so try functional dependencies with - -- the instance environment - do { doTopFundepImprovement work_item - ; tryLastResortProhibitedSuperclass inerts work_item } } - where - dict_loc = ctEvLoc ev - - -doTopReactDict _ w = pprPanic "doTopReactDict" (ppr w) - --- | 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 :: InertSet -> Ct -> TcS (StopOrContinue Ct) -tryLastResortProhibitedSuperclass inerts - work_item@(CDictCan { cc_ev = ev_w, cc_class = cls, cc_tyargs = 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 (inert_cans inerts) loc_w cls xis - , let ev_i = ctEvidence ct_i - , isGiven ev_i - = do { setEvBindIfWanted ev_w (ctEvTerm ev_i) - ; ctLocWarnTcS loc_w $ - TcRnLoopySuperclassSolve loc_w (ctPred work_item) - ; return $ Stop ev_w (text "Loopy superclass") } -tryLastResortProhibitedSuperclass _ work_item - = continueWith work_item - -chooseInstance :: CtEvidence -> ClsInstResult -> TcS (StopOrContinue Ct) -chooseInstance work_item - (OneInst { cir_new_theta = theta - , cir_what = what - , cir_mk_ev = mk_ev }) - = do { traceTcS "doTopReact/found instance for" $ ppr work_item - ; deeper_loc <- checkInstanceOK loc what pred - ; checkReductionDepth deeper_loc pred - ; assertPprM (getTcEvBindsVar >>= return . not . isCoEvBindsVar) - (ppr work_item) - ; evc_vars <- mapM (newWanted deeper_loc (ctEvRewriters work_item)) theta - ; setEvBindIfWanted work_item (mk_ev (map getEvExpr evc_vars)) - ; emitWorkNC (freshGoals evc_vars) - ; stopWith work_item "Dict/Top (solved wanted)" } - where - pred = ctEvPred work_item - loc = ctEvLoc work_item - -chooseInstance work_item lookup_res - = pprPanic "chooseInstance" (ppr work_item $$ ppr lookup_res) - -checkInstanceOK :: CtLoc -> InstanceWhat -> TcPredType -> TcS CtLoc --- Check that it's OK to use this instance: --- (a) the use is well staged in the Template Haskell sense --- Returns the CtLoc to used for sub-goals --- Probably also want to call checkReductionDepth -checkInstanceOK loc what pred - = do { checkWellStagedDFun loc what pred - ; return deeper_loc } - where - deeper_loc = zap_origin (bumpCtLocDepth loc) - origin = ctLocOrigin loc - - zap_origin loc -- After applying an instance we can set ScOrigin to - -- NotNakedSc, so that prohibitedSuperClassSolve never fires - -- See Note [Solving superclass constraints] in - -- GHC.Tc.TyCl.Instance, (sc1). - | ScOrigin what _ <- origin - = setCtLocOrigin loc (ScOrigin what NotNakedSc) - | otherwise - = loc - -{- Note [Instances in no-evidence implications] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In #15290 we had - [G] forall p q. Coercible p q => Coercible (m p) (m q)) - [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. --} - - -matchClassInst :: DynFlags -> InertSet - -> Class -> [Type] - -> CtLoc -> TcS ClsInstResult -matchClassInst dflags inerts clas tys loc --- 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] - | not (xopt LangExt.IncoherentInstances dflags) - , not (naturallyCoherentClass clas) - , not (noMatchableGivenDicts inerts loc clas tys) - = do { traceTcS "Delaying instance application" $ - vcat [ text "Work item=" <+> pprClassPred clas tys ] - ; return NotSure } - - | otherwise - = do { traceTcS "matchClassInst" $ text "pred =" <+> ppr pred <+> char '{' - ; local_res <- matchLocalInst pred loc - ; case local_res of - OneInst {} -> -- See Note [Local instances and incoherence] - do { traceTcS "} matchClassInst local match" $ ppr local_res - ; return local_res } - - NotSure -> -- In the NotSure case for local instances - -- we don't want to try global instances - do { traceTcS "} matchClassInst local not sure" empty - ; return local_res } - - NoInstance -- No local instances, so try global ones - -> do { global_res <- matchGlobalInst dflags False clas tys - ; traceTcS "} matchClassInst global result" $ ppr global_res - ; return global_res } } - where - pred = mkClassPred clas tys - --- | If a class is "naturally coherent", then we needn't worry at all, in any --- way, about overlapping/incoherent instances. Just solve the thing! --- See Note [Naturally coherent classes] --- See also Note [The equality types story] in GHC.Builtin.Types.Prim. -naturallyCoherentClass :: Class -> Bool -naturallyCoherentClass cls - = isCTupleClass cls - || cls `hasKey` heqTyConKey - || cls `hasKey` eqTyConKey - || cls `hasKey` coercibleTyConKey - - -{- Note [Instance and Given overlap] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Example, from the OutsideIn(X) paper: - instance P x => Q [x] - instance (x ~ y) => R y [x] - - wob :: forall a b. (Q [b], R b a) => a -> Int - - g :: forall a. Q [a] => [a] -> Int - g x = wob x - -From 'g' we get the implication constraint: - forall a. Q [a] => (Q [beta], R beta [a]) -If we react (Q [beta]) with its top-level axiom, we end up with a -(P beta), which we have no way of discharging. On the other hand, -if we react R beta [a] with the top-level we get (beta ~ a), which -is solvable and can help us rewrite (Q [beta]) to (Q [a]) which is -now solvable by the given Q [a]. - -The partial solution is that: - In matchClassInst (and thus in topReact), we return a matching - instance only when there is no Given in the inerts which is - unifiable to this particular dictionary. - - We treat any meta-tyvar as "unifiable" for this purpose, - *including* untouchable ones. But not skolems like 'a' in - the implication constraint above. - -The end effect is that, much as we do for overlapping instances, we -delay choosing a class instance if there is a possibility of another -instance OR a given to match our constraint later on. This fixes -tickets #4981 and #5002. - -Other notes: - -* The check is done *first*, so that it also covers classes - with built-in instance solving, such as - - constraint tuples - - natural numbers - - Typeable - -* See also Note [What might equal later?] in GHC.Tc.Solver.InertSet. - -* The given-overlap problem is arguably not easy to appear in practice - due to our aggressive prioritization of equality solving over other - constraints, but it is possible. I've added a test case in - typecheck/should-compile/GivenOverlapping.hs - -* Another "live" example is #10195; another is #10177. - -* We ignore the overlap problem if -XIncoherentInstances is in force: - see #6002 for a worked-out example where this makes a - difference. - -* Moreover notice that our goals here are different than the goals of - the top-level overlapping checks. There we are interested in - validating the following principle: - - If we inline a function f at a site where the same global - instance environment is available as the instance environment at - the definition site of f then we should get the same behaviour. - - But for the Given Overlap check our goal is just related to completeness of - constraint solving. - -* The solution is only a partial one. Consider the above example with - g :: forall a. Q [a] => [a] -> Int - g x = let v = wob x - in v - and suppose we have -XNoMonoLocalBinds, so that we attempt to find the most - general type for 'v'. When generalising v's type we'll simplify its - Q [alpha] constraint, but we don't have Q [a] in the 'givens', so we - will use the instance declaration after all. #11948 was a case - in point. - -All of this is disgustingly delicate, so to discourage people from writing -simplifiable class givens, we warn about signatures that contain them; -see GHC.Tc.Validity Note [Simplifiable given constraints]. - -Note [Naturally coherent classes] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -A few built-in classes are "naturally coherent". This term means that -the "instance" for the class is bidirectional with its superclass(es). -For example, consider (~~), which behaves as if it was defined like -this: - class a ~# b => a ~~ b - instance a ~# b => a ~~ b -(See Note [The equality types story] in GHC.Builtin.Types.Prim.) - -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 -so the reduction of the [W] constraint does not risk losing any solutions. - -On the other hand, it can be fatal to /fail/ to reduce such -equalities, on the grounds of Note [Instance and Given overlap], -because many good things flow from [W] t1 ~# t2. - -The same reasoning applies to - -* (~~) heqTyCon -* (~) eqTyCon -* Coercible coercibleTyCon - -And less obviously to: - -* Tuple classes. For reasons described in GHC.Tc.Solver.Types - Note [Tuples hiding implicit parameters], we may have a constraint - [W] (?x::Int, C a) - with an exactly-matching Given constraint. We must decompose this - tuple and solve the components separately, otherwise we won't solve - it at all! It is perfectly safe to decompose it, because again the - superclasses invert the instance; e.g. - class (c1, c2) => (% c1, c2 %) - instance (c1, c2) => (% c1, c2 %) - Example in #14218 - -Examples: T5853, T10432, T5315, T9222, T2627b, T3028b - -PS: the term "naturally coherent" doesn't really seem helpful. -Perhaps "invertible" or something? I left it for now though. - -Note [Local instances and incoherence] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - f :: forall b c. (Eq b, forall a. Eq a => Eq (c a)) - => c b -> Bool - f x = x==x - -We get [W] Eq (c b), and we must use the local instance to solve it. - -BUT that wanted also unifies with the top-level Eq [a] instance, -and Eq (Maybe a) etc. We want the local instance to "win", otherwise -we can't solve the wanted at all. So we mark it as Incohherent. -According to Note [Rules for instance lookup] in GHC.Core.InstEnv, that'll -make it win even if there are other instances that unify. - -Moreover this is not a hack! The evidence for this local instance -will be constructed by GHC at a call site... from the very instances -that unify with it here. It is not like an incoherent user-written -instance which might have utterly different behaviour. - -Consider f :: Eq a => blah. If we have [W] Eq a, we certainly -get it from the Eq a context, without worrying that there are -lots of top-level instances that unify with [W] Eq a! We'll use -those instances to build evidence to pass to f. That's just the -nullary case of what's happening here. --} - -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 }) <- getTcSInerts - ; 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 - -- See Note [Use only the best matching quantified constraint] - ; 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_what = LocalInstance } - ; traceTcS "Best local instance found:" $ - vcat [ text "pred:" <+> ppr pred - , text "result:" <+> ppr result - , text "matches:" <+> ppr matches - , text "unifs:" <+> ppr unifs ] - ; return result } - - ; mb_best -> - do { traceTcS "Multiple local instances; not committing to any" - $ vcat [ text "pred:" <+> ppr pred - , text "matches:" <+> ppr matches - , text "unifs:" <+> ppr unifs - , text "best_match:" <+> ppr mb_best ] - ; return NotSure }}}}} - where - pred_tv_set = tyCoVarsOfType pred - - mk_instDFun :: (CtEvidence, [DFunInstType]) -> TcS InstDFun - mk_instDFun (ev, tys) = - let dfun_id = ctEvEvId ev - in do { (tys, theta) <- instDFunType (ctEvEvId ev) tys - ; return (dfun_id, tys, theta) } - - -- Compute matching and unifying local instances - match_local_inst :: InertSet - -> [QCInst] - -> ( [(CtEvidence, [DFunInstType])] - , [(CtEvidence, [DFunInstType])] ) - match_local_inst _inerts [] - = ([], []) - match_local_inst inerts (qci@(QCI { qci_tvs = qtvs - , qci_pred = qpred - , qci_ev = qev }) - :qcis) - | let in_scope = mkInScopeSet (qtv_set `unionVarSet` pred_tv_set) - , Just tv_subst <- ruleMatchTyKiX qtv_set (mkRnEnv2 in_scope) - emptyTvSubstEnv qpred pred - , let match = (qev, map (lookupVarEnv tv_subst) qtvs) - = (match:matches, unifs) - - | otherwise - = assertPpr (disjointVarSet qtv_set (tyCoVarsOfType pred)) - (ppr qci $$ ppr pred) - -- ASSERT: unification relies on the - -- quantified variables being fresh - (matches, this_unif `combine` unifs) - where - qloc = ctEvLoc qev - qtv_set = mkVarSet qtvs - (matches, unifs) = match_local_inst inerts qcis - this_unif - | Just subst <- mightEqualLater inerts qpred qloc pred loc - = Just (qev, map (lookupTyVar subst) qtvs) - | otherwise - = Nothing - - combine Nothing us = us - combine (Just u) us = u : us - --- | Instance dictionary function and type. -type InstDFun = (DFunId, [TcType], TcThetaType) - --- | Try to find a local quantified instance that dominates all others, --- i.e. which has a weaker instance context than all the others. --- --- See Note [Use only the best matching quantified constraint]. -dominatingMatch :: [InstDFun] -> Maybe InstDFun -dominatingMatch matches = - listToMaybe $ mapMaybe (uncurry go) (holes matches) - -- listToMaybe: arbitrarily pick any one context that is weaker than - -- all others, e.g. so that we can handle [Eq a, Num a] vs [Num a, Eq a] - -- (see test case T22223). - - where - go :: InstDFun -> [InstDFun] -> Maybe InstDFun - go this [] = Just this - go this@(_,_,this_theta) ((_,_,other_theta):others) - | this_theta `impliedBySCs` other_theta - = go this others - | otherwise - = Nothing - --- | Whether a collection of constraints is implied by another collection, --- according to a simple superclass check. --- --- See Note [When does a quantified instance dominate another?]. -impliedBySCs :: TcThetaType -> TcThetaType -> Bool -impliedBySCs c1 c2 = all in_c2 c1 - where - in_c2 :: TcPredType -> Bool - in_c2 pred = any (pred `tcEqType`) c2_expanded - - c2_expanded :: [TcPredType] -- Includes all superclasses - c2_expanded = [ q | p <- c2, q <- p : transSuperClasses p ] - - -{- Note [When does a quantified instance dominate another?] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When matching local quantified instances, it's useful to be able to pick -the one with the weakest precondition, e.g. if one has both - - [G] d1: forall a b. ( Eq a, Num b, C a b ) => D a b - [G] d2: forall a . C a Int => D a Int - [W] {w}: D a Int - -Then it makes sense to use d2 to solve w, as doing so we end up with a strictly -weaker proof obligation of `C a Int`, compared to `(Eq a, Num Int, C a Int)` -were we to use d1. - -In theory, to compute whether one context implies another, we would need to -recursively invoke the constraint solver. This is expensive, so we instead do -a simple check using superclasses, implemented in impliedBySCs. - -Examples: - - - [Eq a] is implied by [Ord a] - - [Ord a] is not implied by [Eq a], - - any context is implied by itself, - - the empty context is implied by any context. - -Note [Use only the best matching quantified constraint] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider (#20582) the ambiguity check for - (forall a. Ord (m a), forall a. Semigroup a => Eq (m a)) => m Int - -Because of eager expansion of given superclasses, we get - [G] d1: forall a. Ord (m a) - [G] d2: forall a. Eq (m a) - [G] d3: forall a. Semigroup a => Eq (m a) - - [W] {w1}: forall a. Ord (m a) - [W] {w2}: forall a. Semigroup a => Eq (m a) - -The first wanted is solved straightforwardly. But the second wanted -matches *two* local instances: d2 and d3. Our general rule around multiple local -instances is that we refuse to commit to any of them. However, that -means that our type fails the ambiguity check. That's bad: the type -is perfectly fine. (This actually came up in the wild, in the streamly -library.) - -The solution is to prefer local instances which are easier to prove, meaning -that they have a weaker precondition. In this case, the empty context -of d2 is a weaker constraint than the "Semigroup a" context of d3, so we prefer -using it when proving w2. This allows us to pass the ambiguity check here. - -Our criterion for solving a Wanted by matching local quantified instances is -thus as follows: - - - There is a matching local quantified instance that dominates all others - matches, in the sense of [When does a quantified instance dominate another?]. - Any such match do, we pick it arbitrarily (the T22223 example below says why). - - This local quantified instance also dominates all the unifiers, as we - wouldn't want to commit to a single match when we might have multiple, - genuinely different matches after further unification takes place. - -Some other examples: - - - #15244: - - f :: (C g, D g) => .... - class S g => C g where ... - class S g => D g where ... - class (forall a. Eq a => Eq (g a)) => S g where ... - - Here, in f's RHS, there are two identical quantified constraints - available, one via the superclasses of C and one via the superclasses - of D. Given that each implies the other, we pick one arbitrarily. - - - #22216: - - class Eq a - class Eq a => Ord a - class (forall b. Eq b => Eq (f b)) => Eq1 f - class (Eq1 f, forall b. Ord b => Ord (f b)) => Ord1 f - - Suppose we have - - [G] d1: Ord1 f - [G] d2: Eq a - [W] {w}: Eq (f a) - - Superclass expansion of d1 gives us: - - [G] d3 : Eq1 f - [G] d4 : forall b. Ord b => Ord (f b) - - expanding d4 and d5 gives us, respectively: - - [G] d5 : forall b. Eq b => Eq (f b) - [G] d6 : forall b. Ord b => Eq (f b) - - Now we have two matching local instances that we could use when solving the - Wanted. However, it's obviously silly to use d6, given that d5 provides us with - as much information, with a strictly weaker precondition. So we pick d5 to solve - w. If we chose d6, we would get [W] Ord a, which in this case we can't solve. - - - #22223: - - [G] forall a b. (Eq a, Ord b) => C a b - [G] forall a b. (Ord b, Eq a) => C a b - [W] C x y - - Here we should be free to pick either quantified constraint, as they are - equivalent up to re-ordering of the constraints in the context. - See also Note [Do not add duplicate quantified instances] - in GHC.Tc.Solver.Monad. - -Test cases: - typecheck/should_compile/T20582 - quantified-constraints/T15244 - quantified-constraints/T22216{a,b,c,d,e} - quantified-constraints/T22223 - -Historical note: a previous solution was to instead pick the local instance -with the least superclass depth (see Note [Replacement vs keeping]), -but that doesn't work for the example from #22216. --} diff --git a/GHC/Tc/Solver/Irred.hs b/GHC/Tc/Solver/Irred.hs new file mode 100644 --- /dev/null +++ b/GHC/Tc/Solver/Irred.hs @@ -0,0 +1,140 @@ +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE RecursiveDo #-} + +module GHC.Tc.Solver.Irred( + solveIrred + ) where + +import GHC.Prelude + +import GHC.Tc.Types.Constraint +import GHC.Tc.Solver.InertSet +import GHC.Tc.Solver.Dict( matchLocalInst, chooseInstance ) +import GHC.Tc.Solver.Monad +import GHC.Tc.Types.Evidence + +import GHC.Core.Coercion + +import GHC.Types.Basic( SwapFlag(..) ) + +import GHC.Utils.Outputable + +import GHC.Data.Bag + +import Data.Void( Void ) + + +{- ********************************************************************* +* * +* Irreducibles +* * +********************************************************************* -} + +solveIrred :: IrredCt -> SolverStage Void +solveIrred irred + = do { simpleStage $ traceTcS "solveIrred:" (ppr irred) + ; tryInertIrreds irred + ; tryQCsIrredCt irred + ; simpleStage (updInertIrreds irred) + ; stopWithStage (irredCtEvidence irred) "Kept inert IrredCt" } + + +{- ********************************************************************* +* * +* Inert Irreducibles +* * +********************************************************************* -} + +-- Two pieces of irreducible evidence: if their types are *exactly identical* +-- we can rewrite them. We can never improve using this: +-- if we want ty1 :: Constraint and have ty2 :: Constraint it clearly does not +-- mean that (ty1 ~ ty2) +tryInertIrreds :: IrredCt -> SolverStage () +tryInertIrreds irred + = Stage $ do { ics <- getInertCans + ; try_inert_irreds ics irred } + +try_inert_irreds :: InertCans -> IrredCt -> TcS (StopOrContinue ()) + +try_inert_irreds inerts irred_w@(IrredCt { ir_ev = ev_w, ir_reason = reason }) + | let (matching_irreds, others) = findMatchingIrreds (inert_irreds inerts) ev_w + , ((irred_i, swap) : _rest) <- bagToList matching_irreds + -- See Note [Multiple matching irreds] + , let ev_i = irredCtEvidence irred_i + ct_i = CIrredCan irred_i + , not (isInsolubleReason reason) || isGiven ev_i || isGiven ev_w + -- See Note [Insoluble irreds] + = do { traceTcS "iteractIrred" $ + 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 EvCanonical (swap_me swap ev_i) + ; return (Stop ev_w (text "Irred equal:KeepInert" <+> ppr ct_w)) } + KeepWork -> do { setEvBindIfWanted ev_i EvCanonical (swap_me swap ev_w) + ; updInertCans (updIrreds (\_ -> others)) + ; continueWith () } } + + | otherwise + = continueWith () + + where + ct_w = CIrredCan irred_w + + swap_me :: SwapFlag -> CtEvidence -> EvTerm + swap_me swap ev + = case swap of + NotSwapped -> ctEvTerm ev + IsSwapped -> evCoercion (mkSymCo (evTermCoercion (ctEvTerm ev))) + + +{- Note [Multiple matching irreds] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +You might think that it's impossible to have multiple irreds all match the +work item; after all, interactIrred looks for matches and solves one from the +other. However, note that interacting insoluble, non-droppable irreds does not +do this matching. We thus might end up with several insoluble, non-droppable, +matching irreds in the inert set. When another irred comes along that we have +not yet labeled insoluble, we can find multiple matches. These multiple matches +cause no harm, but it would be wrong to ASSERT that they aren't there (as we +once had done). This problem can be tickled by typecheck/should_compile/holes. + +Note [Insoluble irreds] +~~~~~~~~~~~~~~~~~~~~~~~ +We don't allow an /insoluble/ Wanted to be solved from another identical +Wanted. We want to keep all the insoluble Wanteds distinct, so that we get +distinct error messages with -fdefer-type-errors + +However we /do/ allow an insoluble constraint (Given or Wanted) to be solved +from an identical insoluble Given. This might seem a little odd, but there is +lots of discussion in #23413 and #17543. We currently implement the PermissivePlan +of #23413. An alternative would be the LibertarianPlan, but that is harder to +implemnent. + +By "identical" we include swapping. See Note [Solving irreducible equalities] +in GHC.Tc.Solver.InertSet. + +Test cases that are involved bkpfail24.run, T15450, GivenForallLoop, T20189, T8392a. +-} + +{- ********************************************************************* +* * +* Quantified constraints +* * +********************************************************************* -} + +tryQCsIrredCt :: IrredCt -> SolverStage () +-- Try local quantified constraints for +-- and CIrredCan e.g. (c a) +tryQCsIrredCt (IrredCt { ir_ev = ev }) + | isGiven ev + = Stage $ continueWith () + + | otherwise + = Stage $ do { res <- matchLocalInst pred loc + ; case res of + OneInst {} -> chooseInstance ev res + _ -> continueWith () } + where + loc = ctEvLoc ev + pred = ctEvPred ev 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,2040 +1,2458 @@ {-# 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, - - selectNextWorkItem, - getWorkList, - updWorkListTcS, - pushLevelNoWorkList, - - runTcPluginTcS, recordUsedGREs, - matchGlobalInst, TcM.ClsInstResult(..), - - QCInst(..), - - -- Tracing etc - panicTcS, traceTcS, - traceFireTcS, bumpStepCountTcS, csTraceTcS, - wrapErrTcS, wrapWarnTcS, - resetUnificationFlag, setUnificationFlag, - - -- Evidence creation and transformation - MaybeNew(..), freshGoals, isFresh, getEvExpr, - - newTcEvBinds, newNoTcEvBinds, - newWantedEq, emitNewWantedEq, - newWanted, - newWantedNC, newWantedEvVarNC, - newBoundEvVarId, - unifyTyVar, reportUnifications, touchabilityTest, TouchabilityTestResult(..), - setEvBind, setWantedEq, - setWantedEvTerm, setEvBindIfWanted, - newEvVar, newGivenEvVar, newGivenEvVars, - checkReductionDepth, - getSolvedDicts, setSolvedDicts, - - getInstEnvs, getFamInstEnvs, -- Getting the environments - getTopEnv, getGblEnv, getLclEnv, setLclEnv, - getTcEvBindsVar, getTcLevel, - getTcEvTyCoVars, getTcEvBindsMap, setTcEvBindsMap, - tcLookupClass, tcLookupId, - - -- Inerts - updInertTcS, updInertCans, updInertDicts, updInertIrreds, - getHasGivenEqs, setInertCans, - getInertEqs, getInertCans, getInertGivens, - getInertInsols, getInnermostGivenEqLevel, - getTcSInerts, setTcSInerts, - getUnsolvedInerts, - removeInertCts, getPendingGivenScs, - addInertCan, insertFunEq, addInertForAll, - emitWorkNC, emitWork, - lookupInertDict, - - -- The Model - kickOutAfterUnification, - - -- Inert Safe Haskell safe-overlap failures - addInertSafehask, insertSafeOverlapFailureTcS, updInertSafehask, - getSafeOverlapFailures, - - -- Inert solved dictionaries - addSolvedDict, lookupSolvedDict, - - -- Irreds - foldIrreds, - - -- The family application cache - lookupFamAppInert, lookupFamAppCache, extendFamAppCache, - pprKicked, - - instDFunType, -- Instantiation - - -- MetaTyVars - newFlexiTcSTy, instFlexiX, - cloneMetaTyVar, - tcInstSkolTyVarsX, - - TcLevel, - isFilledMetaTyVar_maybe, isFilledMetaTyVar, - zonkTyCoVarsAndFV, zonkTcType, zonkTcTypes, zonkTcTyVar, zonkCo, - zonkTyCoVarsAndFVList, - zonkSimples, zonkWC, - zonkTyCoVarKind, - - -- References - newTcRef, readTcRef, writeTcRef, updTcRef, - - -- Misc - getDefaultInfo, getDynFlags, getGlobalRdrEnvTcS, - matchFam, matchFamTcM, - checkWellStagedDFun, - pprEq, -- Smaller utils, re-exported from TcM - -- TODO (DV): these are only really used in the - -- instance matcher in GHC.Tc.Solver. I am wondering - -- if the whole instance matcher simply belongs - -- here - - breakTyEqCycle_maybe, rewriterView -) where - -import GHC.Prelude - -import GHC.Driver.Env - -import qualified GHC.Tc.Utils.Instantiate as TcM -import GHC.Core.InstEnv -import GHC.Tc.Instance.Family as FamInst -import GHC.Core.FamInstEnv - -import qualified GHC.Tc.Utils.Monad as TcM -import qualified GHC.Tc.Utils.TcMType as TcM -import qualified GHC.Tc.Instance.Class as TcM( matchGlobalInst, ClsInstResult(..) ) -import qualified GHC.Tc.Utils.Env as TcM - ( checkWellStaged, tcGetDefaultTys, tcLookupClass, tcLookupId, topIdLvl - , tcInitTidyEnv ) - -import GHC.Driver.Session - -import GHC.Tc.Instance.Class( InstanceWhat(..), safeOverlap, instanceReturnsDictCon ) -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.Core.Type -import qualified GHC.Core.TyCo.Rep as Rep -- this needs to be used only very locally -import GHC.Core.Coercion -import GHC.Core.Reduction -import GHC.Core.Class -import GHC.Core.TyCon - -import GHC.Types.Error ( mkPlainError, noHints ) -import GHC.Types.Name -import GHC.Types.TyThing -import GHC.Types.Name.Reader - -import GHC.Unit.Module ( HasModule, getModule, extractModule ) -import qualified GHC.Rename.Env as TcM -import GHC.Types.Var -import GHC.Types.Var.Env -import GHC.Types.Var.Set -import GHC.Utils.Outputable -import GHC.Utils.Panic -import GHC.Utils.Logger -import GHC.Utils.Misc (HasDebugCallStack) -import GHC.Data.Bag as Bag -import GHC.Types.Unique.Supply -import GHC.Tc.Types -import GHC.Tc.Types.Origin -import GHC.Tc.Types.Constraint -import GHC.Tc.Utils.Unify -import GHC.Core.Predicate -import GHC.Types.Unique.Set (nonDetEltsUniqSet) - -import Control.Monad -import GHC.Utils.Monad -import Data.IORef -import GHC.Exts (oneShot) -import Data.List ( mapAccumL, partition ) -import Data.Foldable - -#if defined(DEBUG) -import GHC.Data.Graph.Directed -#endif - -{- ********************************************************************* -* * - 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.Interact. --} - -{- ********************************************************************* -* * - Adding an inert -* * -************************************************************************ - -Note [Adding an equality to the InertCans] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When adding an equality to the inerts: - -* Kick out any constraints that can be rewritten by the thing - we are adding. Done by kickOutRewritable. - -* Note that unifying a:=ty, is like adding [G] a~ty; just use - kickOutRewritable with Nominal, Given. See kickOutAfterUnification. - -Note [Kick out existing binding for implicit parameter] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose we have (typecheck/should_compile/ImplicitParamFDs) - flub :: (?x :: Int) => (Int, Integer) - flub = (?x, let ?x = 5 in ?x) -When we are checking the last ?x occurrence, we guess its type -to be a fresh unification variable alpha and emit an (IP "x" alpha) -constraint. But the given (?x :: Int) has been translated to an -IP "x" Int constraint, which has a functional dependency from the -name to the type. So fundep interaction tells us that alpha ~ Int, -and we get a type error. This is bad. - -Instead, we wish to excise any old given for an IP when adding a -new one. We also must make sure not to float out -any IP constraints outside an implication that binds an IP of -the same name; see GHC.Tc.Solver.floatConstraints. --} - -addInertCan :: Ct -> TcS () --- Precondition: item /is/ canonical --- See Note [Adding an equality to the InertCans] -addInertCan ct = - do { traceTcS "addInertCan {" $ - text "Trying to insert new inert item:" <+> ppr ct - ; mkTcS (\TcSEnv{tcs_abort_on_insoluble=abort_flag} -> - when (abort_flag && insolubleEqCt ct) TcM.failM) - ; ics <- getInertCans - ; ics <- maybeKickOut ics ct - ; tclvl <- getTcLevel - ; setInertCans (addInertItem tclvl ics ct) - - ; traceTcS "addInertCan }" $ empty } - -maybeKickOut :: InertCans -> Ct -> TcS InertCans --- For a CEqCan, kick out any inert that can be rewritten by the CEqCan -maybeKickOut ics ct - | CEqCan { cc_lhs = lhs, cc_ev = ev, cc_eq_rel = eq_rel } <- ct - = do { (_, ics') <- kickOutRewritable (ctEvFlavour ev, eq_rel) lhs ics - ; return ics' } - - -- See [Kick out existing binding for implicit parameter] - | isGivenCt ct - , CDictCan { cc_class = cls, cc_tyargs = [ip_name_strty, _ip_ty] } <- ct - , isIPClass cls - , Just ip_name <- isStrLitTy ip_name_strty - -- Would this be more efficient if we used findDictsByClass and then delDict? - = let dict_map = inert_dicts ics - dict_map' = filterDicts doesn't_match_ip_name dict_map - - doesn't_match_ip_name :: Ct -> Bool - doesn't_match_ip_name ct - | Just (inert_ip_name, _inert_ip_ty) <- isIPPred_maybe (ctPred ct) - = inert_ip_name /= ip_name - - | otherwise - = True - - in - return (ics { inert_dicts = dict_map' }) - - | otherwise - = return ics - ------------------------------------------ -kickOutRewritable :: CtFlavourRole -- Flavour/role of the equality that - -- is being added to the inert set - -> CanEqLHS -- The new equality is lhs ~ ty - -> InertCans - -> TcS (Int, InertCans) -kickOutRewritable new_fr new_lhs ics - = do { let (kicked_out, ics') = kickOutRewritableLHS new_fr new_lhs ics - n_kicked = workListSize kicked_out - - ; unless (n_kicked == 0) $ - do { updWorkListTcS (appendWorkList kicked_out) - - -- The famapp-cache contains Given evidence from the inert set. - -- If we're kicking out Givens, we need to remove this evidence - -- from the cache, too. - ; let kicked_given_ev_vars = - [ ev_var | ct <- wl_eqs kicked_out - , CtGiven { ctev_evar = ev_var } <- [ctEvidence ct] ] - ; when (new_fr `eqCanRewriteFR` (Given, NomEq) && - -- if this isn't true, no use looking through the constraints - not (null kicked_given_ev_vars)) $ - do { traceTcS "Given(s) have been kicked out; drop from famapp-cache" - (ppr kicked_given_ev_vars) - ; dropFromFamAppCache (mkVarSet kicked_given_ev_vars) } - - ; csTraceTcS $ - hang (text "Kick out, lhs =" <+> ppr new_lhs) - 2 (vcat [ text "n-kicked =" <+> int n_kicked - , text "kicked_out =" <+> ppr kicked_out - , text "Residual inerts =" <+> ppr ics' ]) } - - ; return (n_kicked, ics') } - -kickOutAfterUnification :: TcTyVar -> TcS Int -kickOutAfterUnification new_tv - = do { ics <- getInertCans - ; (n_kicked, ics2) <- kickOutRewritable (Given,NomEq) - (TyVarLHS new_tv) ics - -- Given because the tv := xi is given; NomEq because - -- only nominal equalities are solved by unification - - ; setInertCans ics2 - ; return n_kicked } - --- See Wrinkle (2) in Note [Equalities with incompatible kinds] in GHC.Tc.Solver.Canonical --- 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 :: CoercionHole -> TcS () -kickOutAfterFillingCoercionHole hole - = do { ics <- getInertCans - ; let (kicked_out, ics') = kick_out ics - n_kicked = workListSize kicked_out - - ; unless (n_kicked == 0) $ - do { updWorkListTcS (appendWorkList kicked_out) - ; csTraceTcS $ - hang (text "Kick out, hole =" <+> ppr hole) - 2 (vcat [ text "n-kicked =" <+> int n_kicked - , text "kicked_out =" <+> ppr kicked_out - , text "Residual inerts =" <+> ppr ics' ]) } - - ; setInertCans ics' } - where - kick_out :: InertCans -> (WorkList, InertCans) - kick_out ics@(IC { inert_eqs = eqs, inert_funeqs = funeqs }) - = (kicked_out, ics { inert_eqs = eqs_to_keep, inert_funeqs = funeqs_to_keep }) - where - (eqs_to_kick, eqs_to_keep) = partitionInertEqs kick_ct eqs - (funeqs_to_kick, funeqs_to_keep) = partitionFunEqs kick_ct funeqs - kicked_out = extendWorkListCts (eqs_to_kick ++ funeqs_to_kick) emptyWorkList - - kick_ct :: Ct -> Bool - -- True: kick out; False: keep. - kick_ct (CEqCan { cc_rhs = rhs, cc_ev = ctev }) - = isWanted ctev && -- optimisation: givens don't have coercion holes anyway - rhs `hasThisCoercionHoleTy` hole - kick_ct other = pprPanic "kick_ct (coercion hole)" (ppr other) - --------------- -addInertSafehask :: InertCans -> Ct -> InertCans -addInertSafehask ics item@(CDictCan { cc_class = cls, cc_tyargs = tys }) - = ics { inert_safehask = addDict (inert_dicts ics) cls tys item } - -addInertSafehask _ item - = pprPanic "addInertSafehask: can't happen! Inserting " $ ppr item - -insertSafeOverlapFailureTcS :: InstanceWhat -> Ct -> TcS () --- See Note [Safe Haskell Overlapping Instances Implementation] in GHC.Tc.Solver -insertSafeOverlapFailureTcS what item - | safeOverlap what = return () - | otherwise = updInertCans (\ics -> addInertSafehask ics item) - -getSafeOverlapFailures :: TcS Cts --- See Note [Safe Haskell Overlapping Instances Implementation] in GHC.Tc.Solver -getSafeOverlapFailures - = do { IC { inert_safehask = safehask } <- getInertCans - ; return $ foldDicts consCts safehask emptyCts } - --------------- -addSolvedDict :: InstanceWhat -> CtEvidence -> Class -> [Type] -> TcS () --- Conditionally add a new item in the solved set of the monad --- See Note [Solved dictionaries] in GHC.Tc.Solver.InertSet -addSolvedDict what item cls tys - | isWanted item - , instanceReturnsDictCon what - = do { traceTcS "updSolvedSetTcs:" $ ppr item - ; updInertTcS $ \ ics -> - ics { inert_solved_dicts = addDict (inert_solved_dicts ics) cls tys item } } - | otherwise - = return () - -getSolvedDicts :: TcS (DictMap CtEvidence) -getSolvedDicts = do { ics <- getTcSInerts; return (inert_solved_dicts ics) } - -setSolvedDicts :: DictMap CtEvidence -> TcS () -setSolvedDicts solved_dicts - = updInertTcS $ \ ics -> - ics { inert_solved_dicts = solved_dicts } - -{- ********************************************************************* -* * - Other inert-set operations -* * -********************************************************************* -} - -updInertTcS :: (InertSet -> InertSet) -> TcS () --- Modify the inert set with the supplied function -updInertTcS upd_fn - = do { is_var <- getTcSInertsRef - ; wrapTcS (do { curr_inert <- TcM.readTcRef is_var - ; TcM.writeTcRef is_var (upd_fn curr_inert) }) } - -getInertCans :: TcS InertCans -getInertCans = do { inerts <- getTcSInerts; return (inert_cans inerts) } - -setInertCans :: InertCans -> TcS () -setInertCans ics = updInertTcS $ \ inerts -> inerts { inert_cans = ics } - -updRetInertCans :: (InertCans -> (a, InertCans)) -> TcS a --- Modify the inert set with the supplied function -updRetInertCans upd_fn - = do { is_var <- getTcSInertsRef - ; wrapTcS (do { inerts <- TcM.readTcRef is_var - ; let (res, cans') = upd_fn (inert_cans inerts) - ; TcM.writeTcRef is_var (inerts { inert_cans = cans' }) - ; return res }) } - -updInertCans :: (InertCans -> InertCans) -> TcS () --- Modify the inert set with the supplied function -updInertCans upd_fn - = updInertTcS $ \ inerts -> inerts { inert_cans = upd_fn (inert_cans inerts) } - -updInertDicts :: (DictMap Ct -> DictMap Ct) -> TcS () --- Modify the inert set with the supplied function -updInertDicts upd_fn - = updInertCans $ \ ics -> ics { inert_dicts = upd_fn (inert_dicts ics) } - -updInertSafehask :: (DictMap Ct -> DictMap Ct) -> TcS () --- Modify the inert set with the supplied function -updInertSafehask upd_fn - = updInertCans $ \ ics -> ics { inert_safehask = upd_fn (inert_safehask ics) } - -updInertIrreds :: (Cts -> Cts) -> TcS () --- Modify the inert set with the supplied function -updInertIrreds upd_fn - = updInertCans $ \ ics -> ics { inert_irreds = upd_fn (inert_irreds ics) } - -getInertEqs :: TcS InertEqs -getInertEqs = do { inert <- getInertCans; return (inert_eqs inert) } - -getInnermostGivenEqLevel :: TcS TcLevel -getInnermostGivenEqLevel = do { inert <- getInertCans - ; return (inert_given_eq_lvl inert) } - -getInertInsols :: TcS Cts --- Returns insoluble equality constraints and TypeError constraints, --- specifically including Givens. --- --- Note that this function only inspects irreducible constraints; --- a DictCan constraint such as 'Eq (TypeError msg)' is not --- considered to be an insoluble constraint by this function. --- --- See Note [Pattern match warnings with insoluble Givens] in GHC.Tc.Solver. -getInertInsols = do { inert <- getInertCans - ; return $ filterBag insolubleCt (inert_irreds inert) } - -getInertGivens :: TcS [Ct] --- Returns the Given constraints in the inert set -getInertGivens - = do { inerts <- getInertCans - ; let all_cts = foldIrreds (:) (inert_irreds inerts) - $ foldDicts (:) (inert_dicts inerts) - $ foldFunEqs (++) (inert_funeqs inerts) - $ foldDVarEnv (++) [] (inert_eqs inerts) - ; return (filter isGivenCt all_cts) } - -getPendingGivenScs :: TcS [Ct] --- Find all inert Given dictionaries, or quantified constraints, --- whose cc_pend_sc flag is True --- and that belong to the current level --- Set their cc_pend_sc flag to False in the inert set, and return that Ct -getPendingGivenScs = do { lvl <- getTcLevel - ; updRetInertCans (get_sc_pending lvl) } - -get_sc_pending :: TcLevel -> InertCans -> ([Ct], InertCans) -get_sc_pending this_lvl ic@(IC { inert_dicts = dicts, inert_insts = insts }) - = assertPpr (all isGivenCt sc_pending) (ppr sc_pending) - -- When getPendingScDics is called, - -- there are never any Wanteds in the inert set - (sc_pending, ic { inert_dicts = dicts', inert_insts = insts' }) - where - sc_pending = sc_pend_insts ++ sc_pend_dicts - - sc_pend_dicts = foldDicts get_pending dicts [] - dicts' = foldr add dicts sc_pend_dicts - - (sc_pend_insts, insts') = mapAccumL get_pending_inst [] insts - - get_pending :: Ct -> [Ct] -> [Ct] -- Get dicts with cc_pend_sc = True - -- but flipping the flag - get_pending dict dicts - | Just dict' <- pendingScDict_maybe dict - , belongs_to_this_level (ctEvidence dict) - = dict' : dicts - | otherwise - = dicts - - add :: Ct -> DictMap Ct -> DictMap Ct - add ct@(CDictCan { cc_class = cls, cc_tyargs = tys }) dicts - = addDict dicts cls tys ct - add ct _ = pprPanic "getPendingScDicts" (ppr ct) - - get_pending_inst :: [Ct] -> QCInst -> ([Ct], QCInst) - get_pending_inst cts qci@(QCI { qci_ev = ev }) - | Just qci' <- pendingScInst_maybe qci - , belongs_to_this_level ev - = (CQuantCan qci' : cts, qci') - | otherwise - = (cts, qci) - - belongs_to_this_level ev = ctLocLevel (ctEvLoc ev) == this_lvl - -- We only want Givens from this level; see (3a) in - -- Note [The superclass story] in GHC.Tc.Solver.Canonical - -getUnsolvedInerts :: TcS ( Bag Implication - , Cts ) -- All simple constraints --- Return all the unsolved [Wanted] constraints --- --- Post-condition: the returned simple constraints are all fully zonked --- (because they come from the inert set) --- the unsolved implics may not be -getUnsolvedInerts - = do { IC { inert_eqs = tv_eqs - , inert_funeqs = fun_eqs - , inert_irreds = irreds - , inert_dicts = idicts - } <- getInertCans - - ; let unsolved_tv_eqs = foldTyEqs add_if_unsolved tv_eqs emptyCts - unsolved_fun_eqs = foldFunEqs add_if_unsolveds fun_eqs emptyCts - unsolved_irreds = Bag.filterBag isWantedCt irreds - unsolved_dicts = foldDicts add_if_unsolved idicts emptyCts - unsolved_others = unionManyBags [ unsolved_irreds - , unsolved_dicts ] - - ; implics <- getWorkListImplics - - ; traceTcS "getUnsolvedInerts" $ - vcat [ text " tv eqs =" <+> ppr unsolved_tv_eqs - , text "fun eqs =" <+> ppr unsolved_fun_eqs - , text "others =" <+> ppr unsolved_others - , text "implics =" <+> ppr implics ] - - ; return ( implics, unsolved_tv_eqs `unionBags` - unsolved_fun_eqs `unionBags` - unsolved_others) } - where - add_if_unsolved :: Ct -> Cts -> Cts - add_if_unsolved ct cts | isWantedCt ct = ct `consCts` cts - | otherwise = cts - - add_if_unsolveds :: EqualCtList -> Cts -> Cts - add_if_unsolveds new_cts old_cts = foldr add_if_unsolved old_cts new_cts - -getHasGivenEqs :: TcLevel -- TcLevel of this implication - -> TcS ( HasGivenEqs -- are there Given equalities? - , Cts ) -- Insoluble equalities arising from givens --- See Note [Tracking Given equalities] in GHC.Tc.Solver.InertSet -getHasGivenEqs tclvl - = do { inerts@(IC { inert_irreds = irreds - , inert_given_eqs = given_eqs - , inert_given_eq_lvl = ge_lvl }) - <- getInertCans - ; let 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 ct - = insolubleEqCt ct && isGivenCt ct - -removeInertCts :: [Ct] -> InertCans -> InertCans --- ^ Remove inert constraints from the 'InertCans', for use when a --- typechecker plugin wishes to discard a given. -removeInertCts cts icans = foldl' removeInertCt icans cts - -removeInertCt :: InertCans -> Ct -> InertCans -removeInertCt is ct = - case ct of - - CDictCan { cc_class = cl, cc_tyargs = tys } -> - is { inert_dicts = delDict (inert_dicts is) cl tys } - - CEqCan { cc_lhs = lhs, cc_rhs = rhs } -> delEq is lhs rhs - - CIrredCan {} -> is { inert_irreds = filterBag (not . eqCt ct) $ inert_irreds is } - - CQuantCan {} -> panic "removeInertCt: CQuantCan" - CNonCanonical {} -> panic "removeInertCt: CNonCanonical" - -eqCt :: Ct -> Ct -> Bool --- Equality via ctEvId -eqCt c c' = ctEvId c == ctEvId c' - --- | 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 } } <- getTcSInerts - ; return (lookup_inerts inert_funeqs) } - where - lookup_inerts inert_funeqs - | Just ecl <- findFunEq inert_funeqs fam_tc tys - , Just (CEqCan { cc_ev = ctev, cc_rhs = rhs }) - <- find (rewrite_pred . ctFlavourRole) 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 <- getTcSInerts - ; let mb_solved = lookupSolvedDict inerts loc cls tys - mb_inert = fmap ctEvidence (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 Ct -lookupInertDict (IC { inert_dicts = dicts }) loc cls tys - = case findDict dicts loc cls tys of - Just ct -> Just ct - _ -> Nothing - --- | Look up a solved inert. -lookupSolvedDict :: InertSet -> CtLoc -> Class -> [Type] -> Maybe CtEvidence --- Returns just if exactly this predicate type exists in the solved. -lookupSolvedDict (IS { inert_solved_dicts = solved }) loc cls tys - = case findDict solved loc cls tys of - Just ev -> Just ev - _ -> Nothing - ---------------------------- -lookupFamAppCache :: TyCon -> [Type] -> TcS (Maybe Reduction) -lookupFamAppCache fam_tc tys - = do { IS { inert_famapp_cache = famapp_cache } <- getTcSInerts - ; 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 ]) - ; updInertTcS $ \ is@(IS { inert_famapp_cache = fc }) -> - is { inert_famapp_cache = insertFunEq fc tc xi_args stuff } } } - --- Remove entries from the cache whose evidence mentions variables in the --- supplied set -dropFromFamAppCache :: VarSet -> TcS () -dropFromFamAppCache varset - = do { inerts@(IS { inert_famapp_cache = famapp_cache }) <- getTcSInerts - ; let filtered = filterTcAppMap check famapp_cache - ; setTcSInerts $ inerts { inert_famapp_cache = filtered } } - where - check :: Reduction -> Bool - check redn - = not (anyFreeVarsOfCo (`elemVarSet` varset) $ reductionCoercion redn) - -{- ********************************************************************* -* * - Irreds -* * -********************************************************************* -} - -foldIrreds :: (Ct -> b -> b) -> Cts -> b -> b -foldIrreds k irreds z = foldr k z irreds - -{- -************************************************************************ -* * -* The TcS solver monad * -* * -************************************************************************ - -Note [The TcS monad] -~~~~~~~~~~~~~~~~~~~~ -The TcS monad is a weak form of the main Tc monad - -All you can do is - * fail - * allocate new variables - * fill in evidence variables - -Filling in a dictionary evidence variable means to create a binding -for it, so TcS carries a mutable location where the binding can be -added. This is initialised from the innermost implication constraint. --} - -data TcSEnv - = TcSEnv { - tcs_ev_binds :: EvBindsVar, - - tcs_unified :: IORef Int, - -- The number of unification variables we have filled - -- The important thing is whether it is non-zero - - tcs_unif_lvl :: IORef (Maybe TcLevel), - -- The Unification Level Flag - -- Outermost level at which we have unified a meta tyvar - -- Starts at Nothing, then (Just i), then (Just j) where j 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 - -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.Canonical" doc - --- | 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 - setTcSInerts inerts - a <- tcs - new_inerts <- getTcSInerts - 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.Canonical - -> 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 --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - --- Getter of inerts and worklist -getTcSInertsRef :: TcS (IORef InertSet) -getTcSInertsRef = TcS (return . tcs_inerts) - -getTcSWorkListRef :: TcS (IORef WorkList) -getTcSWorkListRef = TcS (return . tcs_worklist) - -getTcSInerts :: TcS InertSet -getTcSInerts = getTcSInertsRef >>= readTcRef - -setTcSInerts :: InertSet -> TcS () -setTcSInerts ics = do { r <- getTcSInertsRef; writeTcRef r ics } - -getWorkListImplics :: TcS (Bag Implication) -getWorkListImplics - = do { wl_var <- getTcSWorkListRef - ; wl_curr <- readTcRef wl_var - ; return (wl_implics wl_curr) } - -pushLevelNoWorkList :: SDoc -> TcS a -> TcS (TcLevel, a) --- Push the level and run thing_inside --- However, thing_inside should not generate any work items -#if defined(DEBUG) -pushLevelNoWorkList err_doc (TcS thing_inside) - = TcS (\env -> TcM.pushTcLevelM $ - thing_inside (env { tcs_worklist = wl_panic }) - ) - where - wl_panic = pprPanic "GHC.Tc.Solver.Monad.buildImplication" err_doc - -- This panic checks that the thing-inside - -- does not emit any work-list constraints -#else -pushLevelNoWorkList _ (TcS thing_inside) - = TcS (\env -> TcM.pushTcLevelM (thing_inside env)) -- Don't check -#endif - -updWorkListTcS :: (WorkList -> WorkList) -> TcS () -updWorkListTcS f - = do { wl_var <- getTcSWorkListRef - ; updTcRef wl_var f } - -emitWorkNC :: [CtEvidence] -> TcS () -emitWorkNC evs - | null evs - = return () - | otherwise - = emitWork (map mkNonCanonical evs) - -emitWork :: [Ct] -> TcS () -emitWork [] = return () -- avoid printing, among other work -emitWork cts - = do { traceTcS "Emitting fresh work" (vcat (map ppr cts)) - ; updWorkListTcS (extendWorkListCts cts) } - -emitImplication :: Implication -> TcS () -emitImplication implic - = updWorkListTcS (extendWorkListImplic implic) - -newTcRef :: a -> TcS (TcRef a) -newTcRef x = wrapTcS (TcM.newTcRef x) - -readTcRef :: TcRef a -> TcS a -readTcRef ref = wrapTcS (TcM.readTcRef ref) - -writeTcRef :: TcRef a -> a -> TcS () -writeTcRef ref val = wrapTcS (TcM.writeTcRef ref val) - -updTcRef :: TcRef a -> (a->a) -> TcS () -updTcRef ref upd_fn = wrapTcS (TcM.updTcRef ref upd_fn) - -getTcEvBindsVar :: TcS EvBindsVar -getTcEvBindsVar = TcS (return . tcs_ev_binds) - -getTcLevel :: TcS TcLevel -getTcLevel = wrapTcS TcM.getTcLevel - -getTcEvTyCoVars :: EvBindsVar -> TcS TyCoVarSet -getTcEvTyCoVars ev_binds_var - = wrapTcS $ TcM.getTcEvTyCoVars ev_binds_var - -getTcEvBindsMap :: EvBindsVar -> TcS EvBindMap -getTcEvBindsMap ev_binds_var - = wrapTcS $ TcM.getTcEvBindsMap ev_binds_var - -setTcEvBindsMap :: EvBindsVar -> EvBindMap -> TcS () -setTcEvBindsMap ev_binds_var binds - = wrapTcS $ TcM.setTcEvBindsMap ev_binds_var binds - -unifyTyVar :: TcTyVar -> TcType -> TcS () --- Unify a meta-tyvar with a type --- We keep track of how many unifications have happened in tcs_unified, --- --- We should never unify the same variable twice! -unifyTyVar tv ty - = assertPpr (isMetaTyVar tv) (ppr tv) $ - TcS $ \ env -> - do { TcM.traceTc "unifyTyVar" (ppr tv <+> text ":=" <+> ppr ty) - ; TcM.writeMetaTyVar tv ty - ; TcM.updTcRef (tcs_unified env) (+1) } - -reportUnifications :: TcS a -> TcS (Int, a) -reportUnifications (TcS thing_inside) - = TcS $ \ env -> - do { inner_unified <- TcM.newTcRef 0 - ; res <- thing_inside (env { tcs_unified = inner_unified }) - ; n_unifs <- TcM.readTcRef inner_unified - ; TcM.updTcRef (tcs_unified env) (+ n_unifs) - ; return (n_unifs, res) } - -data TouchabilityTestResult - -- See Note [Solve by unification] in GHC.Tc.Solver.Interact - -- which points out that having TouchableSameLevel is just an optimisation; - -- we could manage with TouchableOuterLevel alone (suitably renamed) - = TouchableSameLevel - | TouchableOuterLevel [TcTyVar] -- Promote these - TcLevel -- ..to this level - | Untouchable - -instance Outputable TouchabilityTestResult where - ppr TouchableSameLevel = text "TouchableSameLevel" - ppr (TouchableOuterLevel tvs lvl) = text "TouchableOuterLevel" <> parens (ppr lvl <+> ppr tvs) - ppr Untouchable = text "Untouchable" - -touchabilityTest :: CtFlavour -> TcTyVar -> TcType -> TcS (TouchabilityTestResult, TcType) --- ^ 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.Interact --- --- Returns a new rhs type, as this function can turn make some metavariables concrete. -touchabilityTest flav tv1 rhs - | flav /= Given -- See Note [Do not unify Givens] - , MetaTv { mtv_tclvl = tv_lvl, mtv_info = info } <- tcTyVarDetails tv1 - = do { continue_solving <- wrapTcS $ startSolvingByUnification info rhs - ; case continue_solving of - { Nothing -> return (Untouchable, rhs) - ; Just rhs -> - do { let (free_metas, free_skols) = partition isPromotableMetaTyVar $ - nonDetEltsUniqSet $ - tyCoVarsOfType rhs - ; ambient_lvl <- getTcLevel - ; given_eq_lvl <- getInnermostGivenEqLevel - - ; if | tv_lvl `sameDepthAs` ambient_lvl - -> return (TouchableSameLevel, rhs) - - | tv_lvl `deeperThanOrSame` given_eq_lvl -- No intervening given equalities - , all (does_not_escape tv_lvl) free_skols -- No skolem escapes - -> return (TouchableOuterLevel free_metas tv_lvl, rhs) - - | otherwise - -> return (Untouchable, rhs) } } } - | otherwise - = return (Untouchable, rhs) - where - - does_not_escape tv_lvl fv - | isTyVar fv = tv_lvl `deeperThanOrSame` tcTyVarLevel fv - | otherwise = True - -- 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. - -{- 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! --} - -getDefaultInfo :: TcS ([Type], (Bool, Bool)) -getDefaultInfo = wrapTcS TcM.tcGetDefaultTys - -getWorkList :: TcS WorkList -getWorkList = do { wl_var <- getTcSWorkListRef - ; wrapTcS (TcM.readTcRef wl_var) } - -selectNextWorkItem :: TcS (Maybe Ct) --- Pick which work item to do next --- See Note [Prioritise equalities] -selectNextWorkItem - = do { wl_var <- getTcSWorkListRef - ; wl <- readTcRef wl_var - ; case selectWorkItem wl of { - Nothing -> return Nothing ; - Just (ct, new_wl) -> - do { -- checkReductionDepth (ctLoc ct) (ctPred ct) - -- This is done by GHC.Tc.Solver.Interact.chooseInstance - ; writeTcRef wl_var new_wl - ; return (Just ct) } } } - --- Just get some environments needed for instance looking up and matching --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -getInstEnvs :: TcS InstEnvs -getInstEnvs = wrapTcS $ TcM.tcGetInstEnvs - -getFamInstEnvs :: TcS (FamInstEnv, FamInstEnv) -getFamInstEnvs = wrapTcS $ FamInst.tcGetFamInstEnvs - -getTopEnv :: TcS HscEnv -getTopEnv = wrapTcS $ TcM.getTopEnv - -getGblEnv :: TcS TcGblEnv -getGblEnv = wrapTcS $ TcM.getGblEnv - -getLclEnv :: TcS TcLclEnv -getLclEnv = wrapTcS $ TcM.getLclEnv - -setLclEnv :: TcLclEnv -> TcS a -> TcS a -setLclEnv env = wrap2TcS (TcM.setLclEnv env) - -tcLookupClass :: Name -> TcS Class -tcLookupClass c = wrapTcS $ TcM.tcLookupClass c - -tcLookupId :: Name -> TcS Id -tcLookupId n = wrapTcS $ TcM.tcLookupId 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 gre_list - -- If a newtype constructor was imported, don't warn about not - -- importing it... - ; wrapTcS $ traverse_ (TcM.keepAlive . greMangledName) 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 pp_thing bind_lvl (thLevel use_stage) } - _ -> - return () - where - pp_thing = text "instance for" <+> quotes (ppr pred) - --- | 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 = wrapTcS (TcM.zonkTyCoVarsAndFV tvs) - -zonkTyCoVarsAndFVList :: [TcTyCoVar] -> TcS [TcTyCoVar] -zonkTyCoVarsAndFVList tvs = wrapTcS (TcM.zonkTyCoVarsAndFVList tvs) - -zonkCo :: Coercion -> TcS Coercion -zonkCo = wrapTcS . TcM.zonkCo - -zonkTcType :: TcType -> TcS TcType -zonkTcType ty = wrapTcS (TcM.zonkTcType ty) - -zonkTcTypes :: [TcType] -> TcS [TcType] -zonkTcTypes tys = wrapTcS (TcM.zonkTcTypes tys) - -zonkTcTyVar :: TcTyVar -> TcS TcType -zonkTcTyVar tv = wrapTcS (TcM.zonkTcTyVar tv) - -zonkSimples :: Cts -> TcS Cts -zonkSimples cts = wrapTcS (TcM.zonkSimples cts) - -zonkWC :: WantedConstraints -> TcS WantedConstraints -zonkWC wc = wrapTcS (TcM.zonkWC wc) - -zonkTyCoVarKind :: TcTyCoVar -> TcS TcTyCoVar -zonkTyCoVarKind tv = wrapTcS (TcM.zonkTyCoVarKind tv) - ----------------------------- -pprKicked :: Int -> SDoc -pprKicked 0 = empty -pprKicked n = parens (int n <+> text "kicked out") - -{- ********************************************************************* -* * -* The Unification Level Flag * -* * -********************************************************************* -} - -{- Note [The Unification Level Flag] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider a deep tree of implication constraints - forall[1] a. -- Outer-implic - C alpha[1] -- Simple - forall[2] c. ....(C alpha[1]).... -- Implic-1 - forall[2] b. ....(alpha[1] ~ Int).... -- Implic-2 - -The (C alpha) is insoluble until we know alpha. We solve alpha -by unifying alpha:=Int somewhere deep inside Implic-2. But then we -must try to solve the Outer-implic all over again. This time we can -solve (C alpha) both in Outer-implic, and nested inside Implic-1. - -When should we iterate solving a level-n implication? -Answer: if any unification of a tyvar at level n takes place - in the ic_implics of that implication. - -* What if a unification takes place at level n-1? Then don't iterate - level n, because we'll iterate level n-1, and that will in turn iterate - level n. - -* What if a unification takes place at level n, in the ic_simples of - level n? No need to track this, because the kick-out mechanism deals - with it. (We can't drop kick-out in favour of iteration, because kick-out - works for skolem-equalities, not just unifications.) - -So the monad-global Unification Level Flag, kept in tcs_unif_lvl keeps -track of - - Whether any unifications at all have taken place (Nothing => no unifications) - - If so, what is the outermost level that has seen a unification (Just lvl) - -The iteration done in the simplify_loop/maybe_simplify_again loop in GHC.Tc.Solver. - -It helpful not to iterate unless there is a chance of progress. #8474 is -an example: - - * There's a deeply-nested chain of implication constraints. - ?x:alpha => ?y1:beta1 => ... ?yn:betan => [W] ?x:Int - - * From the innermost one we get a [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 (foldlM instFlexiHelper subst tvs) - -instFlexiHelper :: Subst -> TKVar -> TcM Subst --- Makes fresh tyvar, extends the substitution, and the in-scope set -instFlexiHelper subst tv - = 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' - ; TcM.traceTc "instFlexi" (ppr tv') - ; return (extendTvSubst subst' tv (mkTyVarTy tv')) } - -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 -> EvTerm -> TcS () -setWantedEvTerm (HoleDest hole) tm - | Just co <- evTermCoercion_maybe tm - = do { useVars (coVarsOfCo co) - ; fillCoercionHole hole co } - | otherwise - = -- See Note [Yukky eq_sel for a HoleDest] - do { let co_var = coHoleCoVar hole - ; setEvBind (mkWantedEvBind co_var tm) - ; fillCoercionHole hole (mkCoVarCo co_var) } - -setWantedEvTerm (EvVarDest ev_id) tm - = setEvBind (mkWantedEvBind ev_id tm) - -{- Note [Yukky eq_sel for a HoleDest] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -How can it be that a Wanted with HoleDest gets evidence that isn't -just a coercion? i.e. evTermCoercion_maybe returns Nothing. - -Consider [G] forall a. blah => a ~ T - [W] S ~# T - -Then doTopReactEqPred carefully looks up the (boxed) constraint (S ~ T) -in the quantified constraints, and wraps the (boxed) evidence it -gets back in an eq_sel to extract the unboxed (S ~# T). We can't put -that term into a coercion, so we add a value binding - h = eq_sel (...) -and the coercion variable h to fill the coercion hole. -We even re-use the CoHole's Id for this binding! - -Yuk! --} - -fillCoercionHole :: CoercionHole -> Coercion -> TcS () -fillCoercionHole hole co - = do { wrapTcS $ TcM.fillCoercionHole hole co - ; kickOutAfterFillingCoercionHole hole } - -setEvBindIfWanted :: CtEvidence -> EvTerm -> TcS () -setEvBindIfWanted ev tm - = case ev of - CtWanted { ctev_dest = dest } -> setWantedEvTerm dest tm - _ -> return () - -newTcEvBinds :: TcS EvBindsVar -newTcEvBinds = wrapTcS TcM.newTcEvBinds - -newNoTcEvBinds :: TcS EvBindsVar -newNoTcEvBinds = wrapTcS TcM.newNoTcEvBinds - -newEvVar :: TcPredType -> TcS EvVar -newEvVar pred = wrapTcS (TcM.newEvVar pred) - -newGivenEvVar :: CtLoc -> (TcPredType, EvTerm) -> TcS CtEvidence --- Make a new variable of the given PredType, --- immediately bind it to the given term --- and return its CtEvidence --- See Note [Bind new Givens immediately] in GHC.Tc.Types.Constraint -newGivenEvVar loc (pred, rhs) - = do { new_ev <- newBoundEvVarId pred rhs - ; return (CtGiven { ctev_pred = pred, ctev_evar = new_ev, ctev_loc = loc }) } - --- | Make a new 'Id' of the given type, bound (in the monad's EvBinds) to the --- given term -newBoundEvVarId :: TcPredType -> EvTerm -> TcS EvVar -newBoundEvVarId pred rhs - = do { new_ev <- newEvVar pred - ; setEvBind (mkGivenEvBind new_ev rhs) - ; return new_ev } - -newGivenEvVars :: CtLoc -> [(TcPredType, EvTerm)] -> TcS [CtEvidence] -newGivenEvVars loc pts = mapM (newGivenEvVar loc) pts - -emitNewWantedEq :: CtLoc -> 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 (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 pty - ; traceTcS "Emitting new coercion hole" (ppr hole <+> dcolon <+> ppr 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 - --- --------- Check done in GHC.Tc.Solver.Interact.selectNewWorkItem???? --------- --- | Checks if the depth of the given location is too much. Fails if --- it's too big, with an appropriate error message. -checkReductionDepth :: CtLoc -> TcType -- ^ type being reduced - -> TcS () -checkReductionDepth loc ty - = do { dflags <- getDynFlags - ; when (subGoalDepthExceeded dflags (ctLocDepth loc)) $ - wrapErrTcS $ 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 <- TcM.zonkTcType ty - ; env0 <- TcM.tcInitTidyEnv - ; let tidy_env = tidyFreeTyCoVars env0 (tyCoVarsOfTypeList ty) - tidy_ty = tidyType tidy_env ty - msg = mkTcRnUnknownMessage $ mkPlainError noHints $ - vcat [ text "Reduction stack overflow; size =" <+> ppr depth - , hang (text "When simplifying the following type:") - 2 (ppr tidy_ty) - , note ] - ; TcM.failWithTcM (tidy_env, msg) } - where - depth = ctLocDepth loc - note = vcat - [ text "Use -freduction-depth=0 to disable this check" - , text "(any upper bound you could choose might fail unpredictably with" - , text " minor updates to GHC, so disabling the check is recommended if" - , text " you're sure that type checking should terminate)" ] - - -{- -************************************************************************ -* * - Breaking type variable cycles -* * -************************************************************************ --} - --- | Conditionally replace all type family applications in the RHS with fresh --- variables, emitting givens that relate the type family application to the --- variable. See Note [Type equality cycles] in GHC.Tc.Solver.Canonical. --- This only works under conditions as described in the Note; otherwise, returns --- Nothing. -breakTyEqCycle_maybe :: CtEvidence - -> CheckTyEqResult -- result of checkTypeEq - -> CanEqLHS - -> TcType -- RHS - -> TcS (Maybe ReductionN) - -- new RHS that doesn't have any type families -breakTyEqCycle_maybe (ctLocOrigin . ctEvLoc -> CycleBreakerOrigin _) _ _ _ - -- see Detail (7) of Note - = return Nothing - -breakTyEqCycle_maybe ev cte_result lhs rhs - | NomEq <- eq_rel - - , cte_result `cterHasOnlyProblem` cteSolubleOccurs - -- only do this if the only problem is a soluble occurs-check - -- See Detail (8) of the Note. - - = do { should_break <- final_check - ; mapM go should_break } - where - flavour = ctEvFlavour ev - eq_rel = ctEvEqRel ev - - final_check = case flavour of - Given -> return $ Just rhs - Wanted -- Wanteds work only with a touchable tyvar on the left - -- See "Wanted" section of the Note. - | TyVarLHS lhs_tv <- lhs -> - do { (result, rhs) <- touchabilityTest Wanted lhs_tv rhs - ; return $ case result of - Untouchable -> Nothing - _ -> Just rhs } - | otherwise -> return Nothing - - -- This could be considerably more efficient. See Detail (5) of Note. - go :: TcType -> TcS ReductionN - go ty | Just ty' <- rewriterView ty = go ty' - go (Rep.TyConApp tc tys) - | isTypeFamilyTyCon tc -- worried about whether this type family is not actually - -- causing trouble? See Detail (5) of Note. - = do { let (fun_args, extra_args) = splitAt (tyConArity tc) tys - fun_app = mkTyConApp tc fun_args - fun_app_kind = typeKind fun_app - ; fun_redn <- emit_work fun_app_kind fun_app - ; arg_redns <- unzipRedns <$> mapM go extra_args - ; return $ mkAppRedns fun_redn arg_redns } - -- Worried that this substitution will change kinds? - -- See Detail (3) of Note - - | otherwise - = do { arg_redns <- unzipRedns <$> mapM go tys - ; return $ mkTyConAppRedn Nominal tc arg_redns } - - go (Rep.AppTy ty1 ty2) - = mkAppRedn <$> go ty1 <*> go ty2 - go (Rep.FunTy vis w arg res) - = mkFunRedn Nominal vis <$> go w <*> go arg <*> go res - go (Rep.CastTy ty cast_co) - = mkCastRedn1 Nominal ty cast_co <$> go ty - go ty@(Rep.TyVarTy {}) = skip ty - go ty@(Rep.LitTy {}) = skip ty - go ty@(Rep.ForAllTy {}) = skip ty -- See Detail (1) of Note - go ty@(Rep.CoercionTy {}) = skip ty -- See Detail (2) of Note - - skip ty = return $ mkReflRedn Nominal ty - - emit_work :: TcKind -- of the function application - -> TcType -- original function application - -> TcS ReductionN -- rewritten type (the fresh tyvar) - emit_work fun_app_kind fun_app = case flavour of - Given -> - do { new_tv <- wrapTcS (TcM.newCycleBreakerTyVar fun_app_kind) - ; let new_ty = mkTyVarTy new_tv - given_pred = mkHeteroPrimEqPred fun_app_kind fun_app_kind - fun_app new_ty - given_term = evCoercion $ mkNomReflCo new_ty -- See Detail (4) of Note - ; new_given <- newGivenEvVar new_loc (given_pred, given_term) - ; traceTcS "breakTyEqCycle replacing type family in Given" (ppr new_given) - ; emitWorkNC [new_given] - ; updInertTcS $ \is -> - is { inert_cycle_breakers = insertCycleBreakerBinding new_tv fun_app - (inert_cycle_breakers is) } - ; return $ mkReflRedn Nominal new_ty } - -- Why reflexive? See Detail (4) of the Note - - Wanted -> - do { new_tv <- wrapTcS (TcM.newFlexiTyVar fun_app_kind) - ; let new_ty = mkTyVarTy new_tv - ; co <- emitNewWantedEq new_loc (ctEvRewriters ev) Nominal new_ty fun_app - ; return $ mkReduction (mkSymCo co) new_ty } - - -- See Detail (7) of the Note - new_loc = updateCtLocOrigin (ctEvLoc ev) CycleBreakerOrigin - --- does not fit scenario from Note -breakTyEqCycle_maybe _ _ _ _ = return Nothing - --- | Fill in CycleBreakerTvs with the variables they stand for. --- See Note [Type equality cycles] in GHC.Tc.Solver.Canonical. -restoreTyVarCycles :: InertSet -> TcM () -restoreTyVarCycles is - = forAllCycleBreakerBindings_ (inert_cycle_breakers is) TcM.writeMetaTyVar -{-# SPECIALISE forAllCycleBreakerBindings_ :: - CycleBreakerVarStack -> (TcTyVar -> TcType -> TcM ()) -> TcM () #-} - --- Unwrap a type synonym only when either: --- The type synonym is forgetful, or --- the type synonym mentions a type family in its expansion --- See Note [Rewriting synonyms] in GHC.Tc.Solver.Rewrite. -rewriterView :: TcType -> Maybe TcType -rewriterView ty@(Rep.TyConApp tc _) - | isForgetfulSynTyCon tc || (isTypeSynonymTyCon tc && not (isFamFreeTyCon tc)) - = coreView ty -rewriterView _other = Nothing +{-# 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] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consdier + [W] a[2] ~ Maybe (F a[2]) + +Should we cycle-break this Wanted, thus? + + [W] a[2] ~ Maybe delta[2] + [W] delta[2] ~ F a[2] + +For a start, this is dodgy because we might just unify delta, thus undoing +what we have done, and getting an infinite loop in the solver. Even if we +somehow prevented ourselves from doing so, is there any merit in the split? +Maybe: perhaps we can use that equality on `a` to unlock other constraints? +Consider + type instance F (Maybe _) = Bool + + [G] g1: a ~ Maybe Bool + [W] w1: a ~ Maybe (F a) + +If we loop-break w1 to get + [W] w1': a ~ Maybe gamma + [W] w3: gamma ~ F a +Now rewrite w3 with w1' + [W] w3': gamma ~ F (Maybe gamma) +Now use the type instance to get + gamma := Bool +Now we are left with + [W] w1': a ~ Maybe Bool +which we can solve from the Given. + +BUT in this situation we could have rewritten the +/original/ Wanted from the Given, like this: + [W] w1': Maybe Bool ~ Maybe (F (Maybe Bool)) +and that is readily soluble. + +In short: loop-breaking Wanteds, when we aren't unifying, +seems of no merit. Hence TEFA_Recurse, rather than TEFA_Break, +in `wanted_flags` in `checkTypeEq`. +-} 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 @@ -27,10 +24,9 @@ import GHC.Types.Var import GHC.Types.Var.Set import GHC.Types.Var.Env -import GHC.Driver.Session +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 @@ -41,6 +37,7 @@ import GHC.Builtin.Types (tYPETyCon) import Data.List ( find ) import GHC.Data.List.Infinite (Infinite) +import GHC.Data.Bag( listToBag ) import qualified GHC.Data.List.Infinite as Inf {- @@ -55,7 +52,6 @@ -- | The 'RewriteM' monad is a wrapper around 'TcS' with a 'RewriteEnv' newtype RewriteM a = RewriteM { runRewriteM :: RewriteEnv -> TcS a } - deriving (Functor) -- | Smart constructor for 'RewriteM', as describe in Note [The one-shot state -- monad trick] in "GHC.Utils.Monad". @@ -72,6 +68,9 @@ pure x = mkRewriteM $ \_ -> pure x (<*>) = ap +instance Functor RewriteM where + fmap f (RewriteM x) = mkRewriteM $ \env -> fmap f (x env) + instance HasDynFlags RewriteM where getDynFlags = liftTcS getDynFlags @@ -83,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; @@ -91,9 +90,9 @@ runRewrite :: CtLoc -> CtFlavour -> EqRel -> RewriteM a -> TcS (a, RewriterSet) runRewrite loc flav eq_rel thing_inside = do { rewriters_ref <- newTcRef emptyRewriterSet - ; let fmode = RE { re_loc = loc - , re_flavour = flav - , re_eq_rel = eq_rel + ; let fmode = RE { re_loc = loc + , re_flavour = flav + , re_eq_rel = eq_rel , re_rewriters = rewriters_ref } ; res <- runRewriteM thing_inside fmode ; rewriters <- readTcRef rewriters_ref @@ -151,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) (`addRewriterSet` 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. @@ -213,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) @@ -235,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) } @@ -315,7 +325,7 @@ Why have these invariants on rewriting? Because we sometimes use typeKind during canonicalisation, and we want this kind to be zonked (e.g., see -GHC.Tc.Solver.Canonical.canEqCanLHS). +GHC.Tc.Solver.Equality.canEqCanLHS). Rewriting is always homogeneous. That is, the kind of the result of rewriting is always the same as the kind of the input, modulo zonking. More formally: @@ -513,7 +523,7 @@ -- Important: look at the *reduced* type, so that any unzonked variables -- in kinds are gone and the getRuntimeRep succeeds. - -- cf. Note [Decomposing FunTy] in GHC.Tc.Solver.Canonical. + -- cf. Note [Decomposing FunTy] in GHC.Tc.Solver.Equality. ; let arg_rep = getRuntimeRep (reductionReducedType arg_redn) res_rep = getRuntimeRep (reductionReducedType res_redn) @@ -667,7 +677,7 @@ {- Note [Do not rewrite newtypes] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We flirted with unwrapping newtypes in the rewriter -- see GHC.Tc.Solver.Canonical +We flirted with unwrapping newtypes in the rewriter -- see GHC.Tc.Solver.Equality Note [Unwrap newtypes first]. But that turned out to be a bad idea because of recursive newtypes, as that Note says. So be careful if you re-add it! @@ -841,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 @@ -945,7 +957,7 @@ TcPluginRewriteTo { tcPluginReduction = redn , tcRewriterNewWanteds = wanteds - } -> do { emitWork wanteds; return $ Just redn } + } -> do { emitWork (listToBag wanteds); return $ Just redn } TcPluginNoRewrite {} -> runRewriters givens rewriters {- @@ -1012,14 +1024,13 @@ ; case lookupDVarEnv ieqs tv of Just equal_ct_list | Just ct <- find can_rewrite equal_ct_list - , CEqCan { cc_ev = ctev, cc_lhs = TyVarLHS tv - , cc_rhs = rhs_ty, cc_eq_rel = ct_eq_rel } <- ct - -> do { let wrw = isWantedCt ct - ; traceRewriteM "Following inert tyvar" $ + , EqCt { eq_ev = ctev, eq_lhs = TyVarLHS tv + , eq_rhs = rhs_ty, eq_eq_rel = ct_eq_rel } <- ct + -> 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 @@ -1035,8 +1046,8 @@ _other -> return RTRNotFollowed } where - can_rewrite :: Ct -> Bool - can_rewrite ct = ctFlavourRole ct `eqCanRewriteFR` fr + can_rewrite :: EqCt -> Bool + can_rewrite ct = eqCtFlavourRole ct `eqCanRewriteFR` fr -- This is THE key call of eqCanRewriteFR {- @@ -1056,8 +1067,9 @@ [G] b ~ Maybe c This avoids "saturating" the Givens, which can save a modest amount of work. -It is easy to implement, in GHC.Tc.Solver.Interact.kick_out, by only kicking out an inert -only if (a) the work item can rewrite the inert AND +It is easy to implement, in GHC.Tc.Solver.InertSet.kickOutRewritableLHS, by +only kicking out an inert only if + (a) the work item can rewrite the inert AND (b) the inert cannot rewrite the work item This is significantly harder to think about. It can save a LOT of work @@ -1097,7 +1109,7 @@ where go (Bndr tv (NamedTCB vis)) (bndrs, _) = (Named (Bndr tv vis) : bndrs, True) - go (Bndr tv (AnonTCB af)) (bndrs, n) - = (Anon (tymult (tyVarKind tv)) af : bndrs, n) + go (Bndr tv AnonTCB) (bndrs, n) + = (Anon (tymult (tyVarKind tv)) FTF_T_T : bndrs, n) {-# INLINE go #-} {-# INLINE ty_con_binders_ty_binders' #-} diff --git a/GHC/Tc/Solver/Solve.hs b/GHC/Tc/Solver/Solve.hs new file mode 100644 --- /dev/null +++ b/GHC/Tc/Solver/Solve.hs @@ -0,0 +1,1837 @@ +{-# 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 @@ -4,29 +4,33 @@ -- | Utility types used within the constraint solver module GHC.Tc.Solver.Types ( -- Inert CDictCans - DictMap, emptyDictMap, findDictsByClass, addDict, - addDictsByClass, delDict, foldDicts, filterDicts, findDict, - dictsToBag, partitionDicts, + DictMap, emptyDictMap, + findDictsByTyConKey, findDictsByClass, + foldDicts, findDict, + dictsToBag, - FunEqMap, emptyFunEqs, foldFunEqs, findFunEq, insertFunEq, + FunEqMap, emptyFunEqs, findFunEq, insertFunEq, findFunEqsByTyCon, TcAppMap, emptyTcAppMap, isEmptyTcAppMap, insertTcApp, alterTcApp, filterTcAppMap, - tcAppMapToBag, foldTcAppMap, + mapMaybeTcAppMap, + tcAppMapToBag, foldTcAppMap, delTcApp, EqualCtList, filterEqualCtList, addToEqualCtList + ) where import GHC.Prelude import GHC.Tc.Types.Constraint -import GHC.Tc.Types.Origin import GHC.Tc.Utils.TcType +import GHC.Types.Unique +import GHC.Types.Unique.DFM + import GHC.Core.Class import GHC.Core.Map.Type -import GHC.Core.Predicate import GHC.Core.TyCon import GHC.Core.TyCon.Env @@ -36,7 +40,6 @@ import GHC.Utils.Constants import GHC.Utils.Outputable import GHC.Utils.Panic -import GHC.Utils.Panic.Plain {- ********************************************************************* * * @@ -109,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 @@ -126,47 +139,17 @@ emptyDictMap :: DictMap a emptyDictMap = emptyTcAppMap -findDict :: DictMap a -> CtLoc -> Class -> [Type] -> Maybe a -findDict m loc cls tys - | hasIPSuperClasses cls tys -- See Note [Tuples hiding implicit parameters] - = Nothing - - | Just {} <- isCallStackPred cls tys - , 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 -findDictsByClass m cls - | Just tm <- lookupDTyConEnv m (classTyCon cls) = foldTM consBag tm emptyBag - | otherwise = emptyBag - -delDict :: DictMap a -> Class -> [Type] -> DictMap a -delDict m cls tys = delTcApp m (classTyCon cls) tys - -addDict :: DictMap a -> Class -> [Type] -> a -> DictMap a -addDict m cls tys item = insertTcApp m (classTyCon cls) tys item - -addDictsByClass :: DictMap Ct -> Class -> Bag Ct -> DictMap Ct -addDictsByClass m cls items - = extendDTyConEnv m (classTyCon cls) (foldr add emptyTM items) - where - add ct@(CDictCan { cc_tyargs = tys }) tm = insertTM tys ct tm - add ct _ = pprPanic "addDictsByClass" (ppr ct) - -filterDicts :: (Ct -> Bool) -> DictMap Ct -> DictMap Ct -filterDicts f m = filterTcAppMap f m +findDictsByClass m cls = findDictsByTyConKey m (getUnique $ classTyCon cls) -partitionDicts :: (Ct -> Bool) -> DictMap Ct -> (Bag Ct, DictMap Ct) -partitionDicts f m = foldTcAppMap k m (emptyBag, emptyDictMap) - where - k ct (yeses, noes) | f ct = (ct `consBag` yeses, noes) - | otherwise = (yeses, add ct noes) - add ct@(CDictCan { cc_class = cls, cc_tyargs = tys }) m - = addDict m cls tys ct - add ct _ = pprPanic "partitionDicts" (ppr ct) +findDictsByTyConKey :: DictMap a -> Unique -> Bag a +findDictsByTyConKey m tc + | Just tm <- lookupUDFM_Directly m tc = foldTM consBag tm emptyBag + | otherwise = emptyBag dictsToBag :: DictMap a -> Bag a dictsToBag = tcAppMapToBag @@ -174,50 +157,6 @@ foldDicts :: (a -> b -> b) -> DictMap a -> b -> b foldDicts = foldTcAppMap -{- Note [Tuples hiding implicit parameters] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - f,g :: (?x::Int, C a) => a -> a - f v = let ?x = 4 in g v - -The call to 'g' gives rise to a Wanted constraint (?x::Int, C a). -We must /not/ solve this from the Given (?x::Int, C a), because of -the intervening binding for (?x::Int). #14218. - -We deal with this by arranging that we always fail when looking up a -tuple constraint that hides an implicit parameter. Note that this applies - * both to the inert_dicts (lookupInertDict) - * and to the solved_dicts (looukpSolvedDict) -An alternative would be not to extend these sets with such tuple -constraints, but it seemed more direct to deal with the lookup. - -Note [Solving CallStack constraints] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -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.Canonical.canClassNC, 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. --} - {- ********************************************************************* * * FunEqMap @@ -241,12 +180,10 @@ | Just tm <- lookupDTyConEnv m tc = foldTM (:) tm [] | otherwise = [] -foldFunEqs :: (a -> b -> b) -> FunEqMap a -> b -> b -foldFunEqs = foldTcAppMap - insertFunEq :: FunEqMap a -> TyCon -> [Type] -> a -> FunEqMap a insertFunEq m tc tys val = insertTcApp m tc tys val + {- ********************************************************************* * * EqualCtList @@ -264,15 +201,15 @@ contains a Given representational equality and a Wanted nominal one. -} -type EqualCtList = [Ct] +type EqualCtList = [EqCt] -- See Note [EqualCtList invariants] -addToEqualCtList :: Ct -> EqualCtList -> EqualCtList +addToEqualCtList :: EqCt -> EqualCtList -> EqualCtList -- See Note [EqualCtList invariants] addToEqualCtList ct old_eqs | debugIsOn = case ct of - CEqCan { cc_lhs = TyVarLHS tv } -> + EqCt { eq_lhs = TyVarLHS tv } -> assert (all (shares_lhs tv) old_eqs) $ assertPpr (null bad_prs) (vcat [ text "bad_prs" <+> ppr bad_prs @@ -284,10 +221,11 @@ | otherwise = ct : old_eqs where - shares_lhs tv (CEqCan { cc_lhs = TyVarLHS old_tv }) = tv == old_tv + shares_lhs tv (EqCt { eq_lhs = TyVarLHS old_tv }) = tv == old_tv shares_lhs _ _ = False bad_prs = filter is_bad_pair (distinctPairs (ct : old_eqs)) - is_bad_pair (ct1,ct2) = ctFlavourRole ct1 `eqCanRewriteFR` ctFlavourRole ct2 + is_bad_pair :: (EqCt, EqCt) -> Bool + is_bad_pair (ct1,ct2) = eqCtFlavourRole ct1 `eqCanRewriteFR` eqCtFlavourRole ct2 distinctPairs :: [a] -> [(a,a)] -- distinctPairs [x1,...xn] is the list of all pairs [ ...(xi, xj)...] @@ -298,7 +236,7 @@ distinctPairs (x:xs) = concatMap (\y -> [(x,y),(y,x)]) xs ++ distinctPairs xs -- returns Nothing when the new list is empty, to keep the environments smaller -filterEqualCtList :: (Ct -> Bool) -> EqualCtList -> Maybe EqualCtList +filterEqualCtList :: (EqCt -> Bool) -> EqualCtList -> Maybe EqualCtList filterEqualCtList pred cts | null new_list = Nothing diff --git a/GHC/Tc/TyCl.hs b/GHC/Tc/TyCl.hs --- a/GHC/Tc/TyCl.hs +++ b/GHC/Tc/TyCl.hs @@ -10,5376 +10,5913 @@ {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE LambdaCase #-} -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} - --- | Typecheck type and class declarations -module GHC.Tc.TyCl ( - tcTyAndClassDecls, - - -- Functions used by GHC.Tc.TyCl.Instance to check - -- data/type family instance declarations - kcConDecls, tcConDecls, DataDeclInfo(..), - dataDeclChecks, checkValidTyCon, - tcFamTyPats, tcTyFamInstEqn, - tcAddTyFamInstCtxt, tcMkDataFamInstCtxt, tcAddDataFamInstCtxt, - unravelFamInstPats, addConsistencyConstraints, - wrongKindOfFamily, checkFamTelescope - ) where - -import GHC.Prelude - -import GHC.Driver.Env -import GHC.Driver.Session -import GHC.Driver.Config.HsToCore - -import GHC.Hs - -import GHC.Tc.Errors.Types ( TcRnMessage(..), FixedRuntimeRepProvenance(..) - , mkTcRnUnknownMessage, IllegalNewtypeReason (..) ) -import GHC.Tc.TyCl.Build -import GHC.Tc.Solver( pushLevelAndSolveEqualities, pushLevelAndSolveEqualitiesX - , reportUnsolvedEqualities ) -import GHC.Tc.Utils.Monad -import GHC.Tc.Utils.Env -import GHC.Tc.Utils.Unify( unifyType, emitResidualTvConstraint ) -import GHC.Tc.Types.Constraint( emptyWC ) -import GHC.Tc.Validity -import GHC.Tc.Utils.Zonk -import GHC.Tc.TyCl.Utils -import GHC.Tc.TyCl.Class -import {-# SOURCE #-} GHC.Tc.TyCl.Instance( tcInstDecls1 ) -import GHC.Tc.Deriv (DerivInfo(..)) -import GHC.Tc.Gen.HsType -import GHC.Tc.Instance.Class( AssocInstInfo(..) ) -import GHC.Tc.Utils.TcMType -import GHC.Tc.Utils.TcType -import GHC.Tc.Instance.Family -import GHC.Tc.Types.Origin - -import GHC.Builtin.Types (oneDataConTy, unitTy, makeRecoveryTyCon ) - -import GHC.Rename.Env( lookupConstructorFields ) - -import GHC.Core.Multiplicity -import GHC.Core.FamInstEnv -import GHC.Core.Coercion -import GHC.Core.Type -import GHC.Core.TyCo.Rep -- for checkValidRoles -import GHC.Core.TyCo.Ppr( pprTyVars ) -import GHC.Core.Class -import GHC.Core.Coercion.Axiom -import GHC.Core.TyCon -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 -import GHC.Types.Var.Env -import GHC.Types.Var.Set -import GHC.Types.Name -import GHC.Types.Name.Set -import GHC.Types.Name.Env -import GHC.Types.SrcLoc -import GHC.Types.SourceFile -import GHC.Types.Unique -import GHC.Types.Basic -import qualified GHC.LanguageExtensions as LangExt - -import GHC.Data.FastString -import GHC.Data.Maybe -import GHC.Data.List.SetOps( minusList, equivClasses ) - -import GHC.Unit - -import GHC.Utils.Outputable -import GHC.Utils.Panic -import GHC.Utils.Panic.Plain -import GHC.Utils.Constants (debugIsOn) -import GHC.Utils.Misc - -import Language.Haskell.Syntax.Basic (FieldLabelString(..)) - -import Control.Monad -import Data.Foldable ( toList, traverse_ ) -import Data.Functor.Identity -import Data.List ( partition) -import Data.List.NonEmpty ( NonEmpty(..) ) -import qualified Data.List.NonEmpty as NE -import Data.Tuple( swap ) - -{- -************************************************************************ -* * -\subsection{Type checking for type and class declarations} -* * -************************************************************************ - -Note [Grouping of type and class declarations] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -tcTyAndClassDecls is called on a list of `TyClGroup`s. Each group is a strongly -connected component of mutually dependent types and classes. We kind check and -type check each group separately to enhance kind polymorphism. Take the -following example: - - type Id a = a - data X = X (Id Int) - -If we were to kind check the two declarations together, we would give Id the -kind * -> *, since we apply it to an Int in the definition of X. But we can do -better than that, since Id really is kind polymorphic, and should get kind -forall (k::*). k -> k. Since it does not depend on anything else, it can be -kind-checked by itself, hence getting the most general kind. We then kind check -X, which works fine because we then know the polymorphic kind of Id, and simply -instantiate k to *. - -Note [Check role annotations in a second pass] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Role inference potentially depends on the types of all of the datacons declared -in a mutually recursive group. The validity of a role annotation, in turn, -depends on the result of role inference. Because the types of datacons might -be ill-formed (see #7175 and Note [rejigConRes]) we must check -*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. --} - -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 - ) --- 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 - 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 } - -tcTyClGroup :: TyClGroup GhcRn - -> TcM (TcGblEnv, [InstInfo GhcRn], [DerivInfo], ThBindEnv) --- 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 - , group_roles = roles - , group_kisigs = kisigs - , group_instds = instds }) - = do { let role_annots = mkRoleAnnotEnv roles - - -- Step 1: Typecheck the standalone kind signatures and type/class declarations - ; traceTc "---- tcTyClGroup ---- {" empty - ; traceTc "Decls for" (ppr (map (tcdName . unLoc) tyclds)) - ; (tyclss, data_deriv_info, kindless) <- - tcExtendKindEnv (mkPromotionErrorEnv tyclds) $ -- See Note [Type environment evolution] - do { kisig_env <- mkNameEnv <$> traverse tcStandaloneKindSig kisigs - ; tcTyClDecls tyclds kisig_env role_annots } - - -- Step 1.5: Make sure we don't have any type synonym cycles - ; traceTc "Starting synonym cycle check" (ppr tyclss) - ; home_unit <- hsc_home_unit <$> getTopEnv - ; checkSynCycles (homeUnitAsUnit home_unit) tyclss tyclds - ; traceTc "Done synonym cycle check" (ppr tyclss) - - -- Step 2: Perform the validity check on those types/classes - -- We can do this now because we are done with the recursive knot - -- Do it before Step 3 (adding implicit things) because the latter - -- expects well-formed TyCons - ; traceTc "Starting validity check" (ppr tyclss) - ; tyclss <- concatMapM checkValidTyCl tyclss - ; traceTc "Done validity check" (ppr tyclss) - ; mapM_ (recoverM (return ()) . checkValidRoleAnnots role_annots) tyclss - -- See Note [Check role annotations in a second pass] - - ; traceTc "---- end tcTyClGroup ---- }" empty - - -- Step 3: Add the implicit things; - -- we want them in the environment because - -- they may be mentioned in interface files - ; (gbl_env, th_bndrs) <- addTyConsToGblEnv tyclss - - -- Step 4: check instance declarations - ; (gbl_env', inst_info, datafam_deriv_info, th_bndrs') <- - setGblEnv gbl_env $ - tcInstDecls1 instds - - ; 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) } - --- Gives the kind for every TyCon that has a standalone kind signature -type KindSigEnv = NameEnv Kind - -tcTyClDecls - :: [LTyClDecl GhcRn] - -> KindSigEnv - -> RoleAnnotEnv - -> TcM ([TyCon], [DerivInfo], NameSet) -tcTyClDecls tyclds kisig_env role_annots - = do { -- Step 1: kind-check this group and returns the final - -- (possibly-polymorphic) kind of each TyCon and Class - -- See Note [Kind checking for type and class decls] - (tc_tycons, kindless) <- kcTyClGroup kisig_env tyclds - ; traceTc "tcTyAndCl generalized kinds" (vcat (map ppr_tc_tycon tc_tycons)) - - -- Step 2: type-check all groups together, returning - -- the final TyCons and Classes - -- - -- NB: We have to be careful here to NOT eagerly unfold - -- type synonyms, as we have not tested for type synonym - -- loops yet and could fall into a black hole. - ; fixM $ \ ~(rec_tyclss, _, _) -> do - { tcg_env <- getGblEnv - -- Forced so we don't retain a reference to the TcGblEnv - ; let !src = tcg_src tcg_env - roles = inferRoles src role_annots rec_tyclss - - -- Populate environment with knot-tied ATyCon for TyCons - -- NB: if the decls mention any ill-staged data cons - -- (see Note [Recursion and promoting data constructors]) - -- we will have failed already in kcTyClGroup, so no worries here - ; (tycons, data_deriv_infos) <- - tcExtendRecEnv (zipRecTyClss tc_tycons rec_tyclss) $ - - -- Also extend the local type envt with bindings giving - -- a TcTyCon for each knot-tied TyCon or Class - -- See Note [Type checking recursive type and class declarations] - -- and Note [Type environment evolution] - tcExtendKindEnvWithTyCons tc_tycons $ - - -- Kind and type check declarations for this group - mapAndUnzipM (tcTyClDecl roles) tyclds - ; return (tycons, concat data_deriv_infos, kindless) - } } - where - ppr_tc_tycon tc = parens (sep [ ppr (tyConName tc) <> comma - , ppr (tyConBinders tc) <> comma - , ppr (tyConResKind tc) - , ppr (isTcTyCon tc) ]) - -zipRecTyClss :: [TcTyCon] - -> [TyCon] -- Knot-tied - -> [(Name,TyThing)] --- Build a name-TyThing mapping for the TyCons bound by decls --- being careful not to look at the knot-tied [TyThing] --- The TyThings in the result list must have a visible ATyCon, --- because typechecking types (in, say, tcTyClDecl) looks at --- this outer constructor -zipRecTyClss tc_tycons rec_tycons - = [ (name, ATyCon (get name)) | tc_tycon <- tc_tycons, let name = getName tc_tycon ] - where - rec_tc_env :: NameEnv TyCon - rec_tc_env = foldr add_tc emptyNameEnv rec_tycons - - add_tc :: TyCon -> NameEnv TyCon -> NameEnv TyCon - add_tc tc env = foldr add_one_tc env (tc : tyConATs tc) - - add_one_tc :: TyCon -> NameEnv TyCon -> NameEnv TyCon - add_one_tc tc env = extendNameEnv env (tyConName tc) tc - - get name = case lookupNameEnv rec_tc_env name of - Just tc -> tc - other -> pprPanic "zipRecTyClss" (ppr name <+> ppr other) - -{- -************************************************************************ -* * - Kind checking -* * -************************************************************************ - -Note [Kind checking for type and class decls] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Kind checking is done thus: - - 1. Make up a kind variable for each parameter of the declarations, - and extend the kind environment (which is in the TcLclEnv) - - 2. Kind check the declarations - -We need to kind check all types in the mutually recursive group -before we know the kind of the type variables. For example: - - class C a where - op :: D b => a -> b -> b - - class D c where - bop :: (Monad c) => ... - -Here, the kind of the locally-polymorphic type variable "b" -depends on *all the uses of class D*. For example, the use of -Monad c in bop's type signature means that D must have kind Type->Type. - -Note: we don't treat type synonyms specially (we used to, in the past); -in particular, even if we have a type synonym cycle, we still kind check -it normally, and test for cycles later (checkSynCycles). The reason -we can get away with this is because we have more systematic TYPE r -inference, which means that we can do unification between kinds that -aren't lifted (this historically was not true.) - -The downside of not directly reading off the kinds of the RHS of -type synonyms in topological order is that we don't transparently -support making synonyms of types with higher-rank kinds. But -you can always specify a CUSK directly to make this work out. -See tc269 for an example. - -Note [CUSKs and PolyKinds] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - - data T (a :: *) = MkT (S a) -- Has CUSK - data S a = MkS (T Int) (S a) -- No CUSK - -Via inferInitialKinds we get - T :: * -> * - S :: kappa -> * - -Then we call kcTyClDecl on each decl in the group, to constrain the -kind unification variables. BUT we /skip/ the RHS of any decl with -a CUSK. Here we skip the RHS of T, so we eventually get - S :: forall k. k -> * - -This gets us more polymorphism than we would otherwise get, similar -(but implemented strangely differently from) the treatment of type -signatures in value declarations. - -However, we only want to do so when we have PolyKinds. -When we have NoPolyKinds, we don't skip those decls, because we have defaulting -(#16609). Skipping won't bring us more polymorphism when we have defaulting. -Consider - - data T1 a = MkT1 T2 -- No CUSK - data T2 = MkT2 (T1 Maybe) -- Has CUSK - -If we skip the rhs of T2 during kind-checking, the kind of a remains unsolved. -With PolyKinds, we do generalization to get T1 :: forall a. a -> *. And the -program type-checks. -But with NoPolyKinds, we do defaulting to get T1 :: * -> *. Defaulting happens -in quantifyTyVars, which is called from generaliseTcTyCon. Then type-checking -(T1 Maybe) will throw a type error. - -Summary: with PolyKinds, we must skip; with NoPolyKinds, we must /not/ skip. - -Open type families -~~~~~~~~~~~~~~~~~~ -This treatment of type synonyms only applies to Haskell 98-style synonyms. -General type functions can be recursive, and hence, appear in `alg_decls'. - -The kind of an open type family is solely determined by its kind signature; -hence, only kind signatures participate in the construction of the initial -kind environment (as constructed by `inferInitialKind'). In fact, we ignore -instances of families altogether in the following. However, we need to include -the kinds of *associated* families into the construction of the initial kind -environment. (This is handled by `allDecls'). - -See also Note [Kind checking recursive type and class declarations] - -Note [How TcTyCons work] -~~~~~~~~~~~~~~~~~~~~~~~~ -TcTyCons are used for two distinct purposes - -1. When recovering from a type error in a type declaration, - we want to put the erroneous TyCon in the environment in a - way that won't lead to more errors. We use a TcTyCon for this; - see makeRecoveryTyCon. - -2. When checking a type/class declaration (in module GHC.Tc.TyCl), we come - upon knowledge of the eventual tycon in bits and pieces, and we use - a TcTyCon to record what we know before we are ready to build the - final TyCon. Here is the plan: - - Step 1 (inferInitialKinds, inference only, skipped for checking): - Make a MonoTcTyCon whose binders are TcTyVars, - which may contain free unification variables - - Step 2 (generaliseTcTyCon) - Generalise that MonoTcTyCon to make a PolyTcTyCon - Its binders are skolem TcTyVars, with accurate SkolemInfo - - Step 3 (tcTyClDecl) - Typecheck the type and class decls to produce a final TyCon - Its binders are final TyVars, not TcTyVars - - Note that a MonoTcTyCon can contain unification variables, - but a PolyTcTyCon does not: only skolem TcTyVars. See - Note [TcTyCon, MonoTcTyCon, and PolyTcTyCon] in GHC.Tc.Utils.TcType - - More details about /kind inference/: - - S1) In kcTyClGroup, we use inferInitialKinds to look over the - declaration of any TyCon that lacks a kind signature or - CUSK, to determine its "shape"; for example, the number of - parameters, and any kind signatures. - - We record that shape record that shape in a MonoTcTyCon; it is - "mono" because it has not been been generalised, and its binders - and result kind may have free unification variables. - - S2) Still in kcTyClGroup, we use kcLTyClDecl to kind-check the - body (class methods, data constructors, etc.) of each of - these MonoTcTyCons, which has the effect of filling in the - metavariables in the tycon's initial kind. - - S3) Still in kcTyClGroup, we use generaliseTyClDecl to generalize - each MonoTcTyCon to get a PolyTcTyCon, with skolem TcTyVars in it, - and a final, fixed kind. - - S4) Finally, back in TcTyClDecls, we extend the environment with - the PolyTcTyCons, and typecheck each declaration (regardless - of kind signatures etc) to get final TyCon. - - More details about /kind checking/ - - S5) In kcTyClGroup, we use checkInitialKinds to get the - utterly-final Kind of all TyCons in the group that - (a) have a separate kind signature or - (b) have a CUSK. - This produces a PolyTcTyCon, that is, a TcTyCon in which the binders - and result kind are full of TyVars (not TcTyVars). No unification - variables here; everything is in its final form. - -3. tyConScopedTyVars. A challenging piece in all of this is that we - end up taking three separate passes over every declaration: - - one in inferInitialKind (this pass look only at the head, not the body) - - one in kcTyClDecls (to kind-check the body) - - a final one in tcTyClDecls (to desugar) - - In the latter two passes, we need to connect the user-written type - variables in an LHsQTyVars with the variables in the tycon's - inferred kind. Because the tycon might not have a CUSK, this - matching up is, in general, quite hard to do. (Look through the - git history between Dec 2015 and Apr 2016 for - GHC.Tc.Gen.HsType.splitTelescopeTvs!) - - Instead of trying, we just store the list of type variables to - bring into scope, in the tyConScopedTyVars field of a MonoTcTyCon. - These tyvars are brought into scope by the calls to - tcExtendNameTyVarEnv (tcTyConScopedTyVars tycon) - in kcTyClDecl. - - In a TcTyCon, why is tyConScopedTyVars :: [(Name,TcTyVar)] rather - than just [TcTyVar]? Consider these mutually-recursive decls - data T (a :: k1) b = MkT (S a b) - data S (c :: k2) d = MkS (T c d) - We start with k1 bound to kappa1, and k2 to kappa2; so initially - in the (Name,TcTyVar) pairs the Name is that of the TcTyVar. But - then kappa1 and kappa2 get unified; so after the zonking in - 'generalise' in 'kcTyClGroup' the Name and TcTyVar may differ. - -See also Note [Type checking recursive type and class declarations]. - -Note [Swizzling the tyvars before generaliseTcTyCon] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -This Note only applies when /inferring/ the kind of a TyCon. -If there is a separate kind signature, or a CUSK, we take an entirely -different code path. - -For inference, consider - class C (f :: k) x where - type T f - op :: D f => blah - class D (g :: j) y where - op :: C g => y -> blah - -Here C and D are considered mutually recursive. Neither has a CUSK. -Just before generalisation we have the (un-quantified) kinds - C :: k1 -> k2 -> Constraint - T :: k1 -> Type - D :: k1 -> Type -> Constraint -Notice that f's kind and g's kind have been unified to 'k1'. We say -that k1 is the "representative" of k in C's decl, and of j in D's decl. - -Now when quantifying, we'd like to end up with - C :: forall {k2}. forall k. k -> k2 -> Constraint - T :: forall k. k -> Type - D :: forall j. j -> Type -> Constraint - -That is, we want to swizzle the representative to have the Name given -by the user. Partly this is to improve error messages and the output of -:info in GHCi. But it is /also/ important because the code for a -default method may mention the class variable(s), but at that point -(tcClassDecl2), we only have the final class tyvars available. -(Alternatively, we could record the scoped type variables in the -TyCon, but it's a nuisance to do so.) - -Notes: - -* On the input to generaliseTyClDecl, the mapping between the - user-specified Name and the representative TyVar is recorded in the - tyConScopedTyVars of the TcTyCon. NB: you first need to zonk to see - this representative TyVar. - -* The swizzling is actually performed by swizzleTcTyConBndrs - -* We must do the swizzling across the whole class decl. Consider - class C f where - type S (f :: k) - type T f - Here f's kind k is a parameter of C, and its identity is shared - with S and T. So if we swizzle the representative k at all, we - must do so consistently for the entire declaration. - - Hence the call to check_duplicate_tc_binders is in generaliseTyClDecl, - rather than in generaliseTcTyCon. - -There are errors to catch here. Suppose we had - class E (f :: j) (g :: k) where - op :: SameKind f g -> blah - -Then, just before generalisation we will have the (unquantified) - E :: k1 -> k1 -> Constraint - -That's bad! Two distinctly-named tyvars (j and k) have ended up with -the same representative k1. So when swizzling, we check (in -check_duplicate_tc_binders) that two distinct source names map -to the same representative. - -Here's an interesting case: - class C1 f where - type S (f :: k1) - type T (f :: k2) -Here k1 and k2 are different Names, but they end up mapped to the -same representative TyVar. To make the swizzling consistent (remember -we must have a single k across C1, S and T) we reject the program. - -Another interesting case - class C2 f where - type S (f :: k) (p::Type) - type T (f :: k) (p::Type->Type) - -Here the two k's (and the two p's) get distinct Uniques, because they -are seen by the renamer as locally bound in S and T resp. But again -the two (distinct) k's end up bound to the same representative TyVar. -You might argue that this should be accepted, but it's definitely -rejected (via an entirely different code path) if you add a kind sig: - type C2' :: j -> Constraint - class C2' f where - type S (f :: k) (p::Type) -We get - • Expected kind ‘j’, but ‘f’ has kind ‘k’ - • In the associated type family declaration for ‘S’ - -So we reject C2 too, even without the kind signature. We have -to do a bit of work to get a good error message, since both k's -look the same to the user. - -Another case - class C3 (f :: k1) where - type S (f :: k2) - -This will be rejected too. - - -Note [Type environment evolution] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -As we typecheck a group of declarations the type environment evolves. -Consider for example: - data B (a :: Type) = MkB (Proxy 'MkB) - -We do the following steps: - - 1. Start of tcTyClDecls: use mkPromotionErrorEnv to initialise the - type env with promotion errors - B :-> TyConPE - MkB :-> DataConPE - - 2. kcTyCLGroup - - Do inferInitialKinds, which will signal a promotion - error if B is used in any of the kinds needed to initialise - B's kind (e.g. (a :: Type)) here - - - Extend the type env with these initial kinds (monomorphic for - decls that lack a CUSK) - B :-> TcTyCon - (thereby overriding the B :-> TyConPE binding) - and do kcLTyClDecl on each decl to get equality constraints on - all those initial kinds - - - Generalise the initial kind, making a poly-kinded TcTyCon - - 3. Back in tcTyDecls, extend the envt with bindings of the poly-kinded - TcTyCons, again overriding the promotion-error bindings. - - But note that the data constructor promotion errors are still in place - so that (in our example) a use of MkB will still be signalled as - an error. - - 4. Typecheck the decls. - - 5. In tcTyClGroup, extend the envt with bindings for TyCon and DataCons - - -Note [Missed opportunity to retain higher-rank kinds] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In 'kcTyClGroup', there is a missed opportunity to make kind -inference work in a few more cases. The idea is analogous -to Note [Special case for non-recursive function bindings]: - - * If we have an SCC with a single decl, which is non-recursive, - instead of creating a unification variable representing the - kind of the decl and unifying it with the rhs, we can just - read the type directly of the rhs. - - * Furthermore, we can update our SCC analysis to ignore - dependencies on declarations which have CUSKs: we don't - have to kind-check these all at once, since we can use - the CUSK to initialize the kind environment. - -Unfortunately this requires reworking a bit of the code in -'kcLTyClDecl' so I've decided to punt unless someone shouts about it. - -Note [Don't process associated types in getInitialKind] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Previously, we processed associated types in the thing_inside in getInitialKind, -but this was wrong -- we want to do ATs separately. -The consequence for not doing it this way is #15142: - - class ListTuple (tuple :: Type) (as :: [(k, Type)]) where - type ListToTuple as :: Type - -We assign k a kind kappa[1]. When checking the tuple (k, Type), we try to unify -kappa ~ Type, but this gets deferred because we bumped the TcLevel as we bring -`tuple` into scope. Thus, when we check ListToTuple, kappa[1] still hasn't -unified with Type. And then, when we generalize the kind of ListToTuple (which -indeed has a CUSK, according to the rules), we skolemize the free metavariable -kappa. Note that we wouldn't skolemize kappa when generalizing the kind of ListTuple, -because the solveEqualities in kcInferDeclHeader is at TcLevel 1 and so kappa[1] -will unify with Type. - -Bottom line: as associated types should have no effect on a CUSK enclosing class, -we move processing them to a separate action, run after the outer kind has -been generalized. - --} - -kcTyClGroup :: KindSigEnv -> [LTyClDecl GhcRn] -> TcM ([PolyTcTyCon], NameSet) - --- Kind check this group, kind generalize, and return the resulting local env --- This binds the TyCons and Classes of the group, but not the DataCons --- See Note [Kind checking for type and class decls] --- and Note [Inferring kinds for type declarations] --- --- The NameSet returned contains kindless tycon names, without CUSK or SAKS. -kcTyClGroup kisig_env decls - = do { mod <- getModule - ; traceTc "---- kcTyClGroup ---- {" - (text "module" <+> ppr mod $$ vcat (map ppr decls)) - - -- Kind checking; - -- 1. Bind kind variables for decls - -- 2. Kind-check decls - -- 3. Generalise the inferred kinds - -- See Note [Kind checking for type and class decls] - - ; cusks_enabled <- xoptM LangExt.CUSKs <&&> xoptM LangExt.PolyKinds - -- See Note [CUSKs and PolyKinds] - ; let (kindless_decls, kinded_decls) = partitionWith get_kind decls - kindless_names = mkNameSet $ map get_name kindless_decls - - get_name d = tcdName (unLoc d) - - get_kind d - | Just ki <- lookupNameEnv kisig_env (get_name d) - = Right (d, SAKS ki) - - | cusks_enabled && hsDeclHasCusk (unLoc d) - = Right (d, CUSK) - - | otherwise = Left d - - ; checked_tcs <- checkNoErrs $ - checkInitialKinds kinded_decls - -- checkNoErrs because we are about to extend - -- the envt with these tycons, and we get - -- knock-on errors if we have tycons with - -- malformed kinds - - ; inferred_tcs - <- tcExtendKindEnvWithTyCons checked_tcs $ - pushLevelAndSolveEqualities unkSkolAnon [] $ - -- We are going to kind-generalise, so unification - -- variables in here must be one level in - do { -- Step 1: Bind kind variables for all decls - mono_tcs <- inferInitialKinds kindless_decls - - ; traceTc "kcTyClGroup: initial kinds" $ - ppr_tc_kinds mono_tcs - - -- Step 2: Set extended envt, kind-check the decls - -- NB: the environment extension overrides the tycon - -- promotion-errors bindings - -- See Note [Type environment evolution] - ; checkNoErrs $ - tcExtendKindEnvWithTyCons mono_tcs $ - mapM_ kcLTyClDecl kindless_decls - - ; return mono_tcs } - - -- Step 3: generalisation - -- Finally, go through each tycon and give it its final kind, - -- with all the required, specified, and inferred variables - -- in order. - ; let inferred_tc_env = mkNameEnv $ - map (\tc -> (tyConName tc, tc)) inferred_tcs - ; generalized_tcs <- concatMapM (generaliseTyClDecl inferred_tc_env) - kindless_decls - - ; let poly_tcs = checked_tcs ++ generalized_tcs - ; traceTc "---- kcTyClGroup end ---- }" (ppr_tc_kinds poly_tcs) - ; return (poly_tcs, kindless_names) } - where - ppr_tc_kinds tcs = vcat (map pp_tc tcs) - pp_tc tc = ppr (tyConName tc) <+> dcolon <+> ppr (tyConKind tc) - -type ScopedPairs = [(Name, TcTyVar)] - -- The ScopedPairs for a TcTyCon are precisely - -- specified-tvs ++ required-tvs - -- You can distinguish them because there are tyConArity required-tvs - -generaliseTyClDecl :: NameEnv MonoTcTyCon -> LTyClDecl GhcRn -> TcM [PolyTcTyCon] --- See Note [Swizzling the tyvars before generaliseTcTyCon] -generaliseTyClDecl inferred_tc_env (L _ decl) - = do { let names_in_this_decl :: [Name] - names_in_this_decl = tycld_names decl - - -- Extract the specified/required binders and skolemise them - ; tc_with_tvs <- mapM skolemise_tc_tycon names_in_this_decl - - -- Zonk, to manifest the side-effects of skolemisation to the swizzler - -- NB: it's important to skolemise them all before this step. E.g. - -- class C f where { type T (f :: k) } - -- We only skolemise k when looking at T's binders, - -- but k appears in f's kind in C's binders. - ; tc_infos <- mapM zonk_tc_tycon tc_with_tvs - - -- Swizzle - ; swizzled_infos <- tcAddDeclCtxt decl (swizzleTcTyConBndrs tc_infos) - - -- And finally generalise - ; mapAndReportM generaliseTcTyCon swizzled_infos } - where - tycld_names :: TyClDecl GhcRn -> [Name] - tycld_names decl = tcdName decl : at_names decl - - at_names :: TyClDecl GhcRn -> [Name] - at_names (ClassDecl { tcdATs = ats }) = map (familyDeclName . unLoc) ats - at_names _ = [] -- Only class decls have associated types - - skolemise_tc_tycon :: Name -> TcM (TcTyCon, SkolemInfo, ScopedPairs) - -- Zonk and skolemise the Specified and Required binders - skolemise_tc_tycon tc_name - = do { let tc = lookupNameEnv_NF inferred_tc_env tc_name - -- This lookup should not fail - ; skol_info <- mkSkolemInfo (TyConSkol (tyConFlavour tc) tc_name ) - ; scoped_prs <- mapSndM (zonkAndSkolemise skol_info) (tcTyConScopedTyVars tc) - ; return (tc, skol_info, scoped_prs) } - - zonk_tc_tycon :: (TcTyCon, SkolemInfo, ScopedPairs) - -> TcM (TcTyCon, SkolemInfo, ScopedPairs, TcKind) - zonk_tc_tycon (tc, skol_info, scoped_prs) - = do { scoped_prs <- mapSndM zonkTcTyVarToTcTyVar scoped_prs - -- We really have to do this again, even though - -- we have just done zonkAndSkolemise, so that - -- occurrences in the /kinds/ get zonked to the skolem - ; res_kind <- zonkTcType (tyConResKind tc) - ; return (tc, skol_info, scoped_prs, res_kind) } - -swizzleTcTyConBndrs :: [(TcTyCon, SkolemInfo, ScopedPairs, TcKind)] - -> TcM [(TcTyCon, SkolemInfo, ScopedPairs, TcKind)] -swizzleTcTyConBndrs tc_infos - | all no_swizzle swizzle_prs - -- This fast path happens almost all the time - -- See Note [Cloning for type variable binders] in GHC.Tc.Gen.HsType - -- "Almost all the time" means not the case of mutual recursion with - -- polymorphic kinds. - = do { traceTc "Skipping swizzleTcTyConBndrs for" (ppr_infos tc_infos) - ; return tc_infos } - - | otherwise - = do { checkForDuplicateScopedTyVars swizzle_prs - - ; traceTc "swizzleTcTyConBndrs" $ - vcat [ text "before" <+> ppr_infos tc_infos - , text "swizzle_prs" <+> ppr swizzle_prs - , text "after" <+> ppr_infos swizzled_infos ] - - ; return swizzled_infos } - - where - swizzled_infos = [ (tc, skol_info, mapSnd swizzle_var scoped_prs, swizzle_ty kind) - | (tc, skol_info, scoped_prs, kind) <- tc_infos ] - - swizzle_prs :: [(Name,TyVar)] - -- Pairs the user-specified Name with its representative TyVar - -- See Note [Swizzling the tyvars before generaliseTcTyCon] - swizzle_prs = [ pr | (_, _, prs, _) <- tc_infos, pr <- prs ] - - no_swizzle :: (Name,TyVar) -> Bool - no_swizzle (nm, tv) = nm == tyVarName tv - - ppr_infos infos = vcat [ ppr tc <+> pprTyVars (map snd prs) - | (tc, _, prs, _) <- infos ] - - -------------- The swizzler ------------ - -- This does a deep traverse, simply doing a - -- Name-to-Name change, governed by swizzle_env - -- The 'swap' is what gets from the representative TyVar - -- back to the original user-specified Name - swizzle_env = mkVarEnv (map swap swizzle_prs) - - swizzleMapper :: TyCoMapper () Identity - swizzleMapper = TyCoMapper { tcm_tyvar = swizzle_tv - , tcm_covar = swizzle_cv - , tcm_hole = swizzle_hole - , tcm_tycobinder = swizzle_bndr - , tcm_tycon = swizzle_tycon } - swizzle_hole _ hole = pprPanic "swizzle_hole" (ppr hole) - -- These types are pre-zonked - swizzle_tycon tc = pprPanic "swizzle_tc" (ppr tc) - -- TcTyCons can't appear in kinds (yet) - swizzle_tv _ tv = return (mkTyVarTy (swizzle_var tv)) - swizzle_cv _ cv = return (mkCoVarCo (swizzle_var cv)) - - swizzle_bndr _ tcv _ - = return ((), swizzle_var tcv) - - swizzle_var :: Var -> Var - swizzle_var v - | Just nm <- lookupVarEnv swizzle_env v - = updateVarType swizzle_ty (v `setVarName` nm) - | otherwise - = updateVarType swizzle_ty v - - (map_type, _, _, _) = mapTyCo swizzleMapper - swizzle_ty ty = runIdentity (map_type ty) - - -generaliseTcTyCon :: (MonoTcTyCon, SkolemInfo, ScopedPairs, TcKind) -> TcM PolyTcTyCon -generaliseTcTyCon (tc, skol_info, scoped_prs, tc_res_kind) - -- The scoped_prs are fully zonked skolem TcTyVars - -- And tc_res_kind is fully zonked too - -- See Note [Required, Specified, and Inferred for types] - = setSrcSpan (getSrcSpan tc) $ - addTyConCtxt tc $ - do { -- Step 1: Separate Specified from Required variables - -- NB: spec_req_tvs = spec_tvs ++ req_tvs - -- And req_tvs is 1-1 with tyConTyVars - -- See Note [Scoped tyvars in a TcTyCon] in GHC.Core.TyCon - ; let spec_req_tvs = map snd scoped_prs - n_spec = length spec_req_tvs - tyConArity tc - (spec_tvs, req_tvs) = splitAt n_spec spec_req_tvs - sorted_spec_tvs = scopedSort spec_tvs - -- NB: We can't do the sort until we've zonked - -- Maintain the L-R order of scoped_tvs - - -- Step 2a: find all the Inferred variables we want to quantify over - ; dvs1 <- candidateQTyVarsOfKinds $ - (tc_res_kind : map tyVarKind spec_req_tvs) - ; let dvs2 = dvs1 `delCandidates` spec_req_tvs - - -- Step 2b: quantify, mainly meaning skolemise the free variables - -- Returned 'inferred' are scope-sorted and skolemised - ; inferred <- quantifyTyVars skol_info DefaultNonStandardTyVars dvs2 - - ; traceTc "generaliseTcTyCon: pre zonk" - (vcat [ text "tycon =" <+> ppr tc - , text "spec_req_tvs =" <+> pprTyVars spec_req_tvs - , text "tc_res_kind =" <+> ppr tc_res_kind - , text "dvs1 =" <+> ppr dvs1 - , text "inferred =" <+> pprTyVars inferred ]) - - -- Step 3: Final zonk: quantifyTyVars may have done some defaulting - ; inferred <- zonkTcTyVarsToTcTyVars inferred - ; sorted_spec_tvs <- zonkTcTyVarsToTcTyVars sorted_spec_tvs - ; req_tvs <- zonkTcTyVarsToTcTyVars req_tvs - ; tc_res_kind <- zonkTcType tc_res_kind - - ; traceTc "generaliseTcTyCon: post zonk" $ - vcat [ text "tycon =" <+> ppr tc - , text "inferred =" <+> pprTyVars inferred - , text "spec_req_tvs =" <+> pprTyVars spec_req_tvs - , text "sorted_spec_tvs =" <+> pprTyVars sorted_spec_tvs - , text "req_tvs =" <+> ppr req_tvs ] - - -- Step 4: Make the TyConBinders. - ; let dep_fv_set = candidateKindVars dvs1 - inferred_tcbs = mkNamedTyConBinders Inferred inferred - specified_tcbs = mkNamedTyConBinders Specified sorted_spec_tvs - required_tcbs = map (mkRequiredTyConBinder dep_fv_set) req_tvs - - -- Step 5: Assemble the final list. - all_tcbs = concat [ inferred_tcbs - , specified_tcbs - , required_tcbs ] - flav = tyConFlavour tc - - -- Eta expand - ; (eta_tcbs, tc_res_kind) <- etaExpandAlgTyCon flav skol_info all_tcbs tc_res_kind - - -- Step 6: Make the result TcTyCon - ; let final_tcbs = all_tcbs `chkAppend` eta_tcbs - tycon = mkTcTyCon (tyConName tc) - final_tcbs tc_res_kind - (mkTyVarNamePairs (sorted_spec_tvs ++ req_tvs)) - True {- it's generalised now -} - flav - - ; traceTc "generaliseTcTyCon done" $ - vcat [ text "tycon =" <+> ppr tc - , text "tc_res_kind =" <+> ppr tc_res_kind - , text "dep_fv_set =" <+> ppr dep_fv_set - , text "inferred_tcbs =" <+> ppr inferred_tcbs - , text "specified_tcbs =" <+> ppr specified_tcbs - , text "required_tcbs =" <+> ppr required_tcbs - , text "final_tcbs =" <+> ppr final_tcbs ] - - -- Step 7: Check for validity. - -- We do this here because we're about to put the tycon into the - -- the environment, and we don't want anything malformed there - ; checkTyConTelescope tycon - - ; return tycon } - -{- Note [Required, Specified, and Inferred for types] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Each forall'd type variable in a type or kind is one of - - * Required: an argument must be provided at every call site - - * Specified: the argument can be inferred at call sites, but - may be instantiated with visible type/kind application - - * Inferred: the argument must be inferred at call sites; it - is unavailable for use with visible type/kind application. - -Why have Inferred at all? Because we just can't make user-facing -promises about the ordering of some variables. These might swizzle -around even between minor released. By forbidding visible type -application, we ensure users aren't caught unawares. - -Go read Note [VarBndrs, ForAllTyBinders, TyConBinders, and visibility] in GHC.Core.TyCo.Rep. - -The question for this Note is this: - given a TyClDecl, how are its quantified type variables classified? -Much of the debate is memorialized in #15743. - -Here is our design choice. When inferring the ordering of variables -for a TyCl declaration (that is, for those variables that the user -has not specified the order with an explicit `forall`), we use the -following order: - - 1. Inferred variables - 2. Specified variables; in the left-to-right order in which - the user wrote them, modified by scopedSort (see below) - to put them in dependency order. - 3. Required variables before a top-level :: - 4. All variables after a top-level :: - -If this ordering does not make a valid telescope, we reject the definition. - -Example: - data SameKind :: k -> k -> * - data Bad a (c :: Proxy b) (d :: Proxy a) (x :: SameKind b d) - -For Bad: - - a, c, d, x are Required; they are explicitly listed by the user - as the positional arguments of Bad - - b is Specified; it appears explicitly in a kind signature - - k, the kind of a, is Inferred; it is not mentioned explicitly at all - -Putting variables in the order Inferred, Specified, Required -gives us this telescope: - Inferred: k - Specified: b : Proxy a - Required : (a : k) (c : Proxy b) (d : Proxy a) (x : SameKind b d) - -But this order is ill-scoped, because b's kind mentions a, which occurs -after b in the telescope. So we reject Bad. - -Associated types -~~~~~~~~~~~~~~~~ -For associated types everything above is determined by the -associated-type declaration alone, ignoring the class header. -Here is an example (#15592) - class C (a :: k) b where - type F (x :: b a) - -In the kind of C, 'k' is Specified. But what about F? -In the kind of F, - - * Should k be Inferred or Specified? It's Specified for C, - but not mentioned in F's declaration. - - * In which order should the Specified variables a and b occur? - It's clearly 'a' then 'b' in C's declaration, but the L-R ordering - in F's declaration is 'b' then 'a'. - -In both cases we make the choice by looking at F's declaration alone, -so it gets the kind - F :: forall {k}. forall b a. b a -> Type - -How it works -~~~~~~~~~~~~ -These design choices are implemented by two completely different code -paths for - - * Declarations with a standalone kind signature or a complete user-specified - kind signature (CUSK). Handled by the kcCheckDeclHeader. - - * Declarations without a kind signature (standalone or CUSK) are handled by - kcInferDeclHeader; see Note [Inferring kinds for type declarations]. - -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.) - -We can tell Inferred apart from Specified by looking at the scoped -tyvars; Specified are always included there. - -Design alternatives -~~~~~~~~~~~~~~~~~~~ -* For associated types we considered putting the class variables - before the local variables, in a nod to the treatment for class - methods. But it got too complicated; see #15592, comment:21ff. - -* We rigidly require the ordering above, even though we could be much more - permissive. Relevant musings are at - https://gitlab.haskell.org/ghc/ghc/issues/15743#note_161623 - The bottom line conclusion is that, if the user wants a different ordering, - then can specify it themselves, and it is better to be predictable and dumb - than clever and capricious. - - I (Richard) conjecture we could be fully permissive, allowing all classes - of variables to intermix. We would have to augment ScopedSort to refuse to - reorder Required variables (or check that it wouldn't have). But this would - allow more programs. See #15743 for examples. Interestingly, Idris seems - to allow this intermixing. The intermixing would be fully specified, in that - we can be sure that inference wouldn't change between versions. However, - would users be able to predict it? That I cannot answer. - -Test cases (and tickets) relevant to these design decisions -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - T15591* - T15592* - T15743* - -Note [Inferring kinds for type declarations] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -This note deals with /inference/ for type declarations -that do not have a CUSK. Consider - data T (a :: k1) k2 (x :: k2) = MkT (S a k2 x) - data S (b :: k3) k4 (y :: k4) = MkS (T b k4 y) - -We do kind inference as follows: - -* Step 1: inferInitialKinds, and in particular kcInferDeclHeader. - Make a unification variable for each of the Required and Specified - type variables in the header. - - Record the connection between the Names the user wrote and the - fresh unification variables in the tcTyConScopedTyVars field - of the TcTyCon we are making - [ (a, aa) - , (k1, kk1) - , (k2, kk2) - , (x, xx) ] - (I'm using the convention that double letter like 'aa' or 'kk' - mean a unification variable.) - - These unification variables - - Are TyVarTvs: that is, unification variables that can - unify only with other type variables. - See Note [TyVarTv] in GHC.Tc.Utils.TcMType - - - Have complete fresh Names; see GHC.Tc.Utils.TcMType - Note [Unification variables need fresh Names] - - Assign initial monomorphic kinds to S, T - T :: kk1 -> * -> kk2 -> * - S :: kk3 -> * -> kk4 -> * - -* Step 2: kcTyClDecl. Extend the environment with a TcTyCon for S and - T, with these monomorphic kinds. Now kind-check the declarations, - and solve the resulting equalities. The goal here is to discover - constraints on all these unification variables. - - Here we find that kk1 := kk3, and kk2 := kk4. - - This is why we can't use skolems for kk1 etc; they have to - unify with each other. - -* Step 3: generaliseTcTyCon. Generalise each TyCon in turn. - We find the free variables of the kind, skolemise them, - sort them out into Inferred/Required/Specified (see the above - Note [Required, Specified, and Inferred for types]), - and perform some validity checks. - - This makes the utterly-final TyConBinders for the TyCon. - - All this is very similar at the level of terms: see GHC.Tc.Gen.Bind - Note [Quantified variables in partial type signatures] - - But there are some tricky corners: Note [Tricky scoping in generaliseTcTyCon] - -* Step 4. Extend the type environment with a TcTyCon for S and T, now - with their utterly-final polymorphic kinds (needed for recursive - occurrences of S, T). Now typecheck the declarations, and build the - final AlgTyCon for S and T resp. - -The first three steps are in kcTyClGroup; the fourth is in -tcTyClDecls. - -There are some wrinkles - -* Do not default TyVarTvs. We always want to kind-generalise over - TyVarTvs, and /not/ default them to Type. By definition a TyVarTv is - not allowed to unify with a type; it must stand for a type - variable. Hence the check in GHC.Tc.Solver.defaultTyVarTcS, and - GHC.Tc.Utils.TcMType.defaultTyVar. Here's another example (#14555): - data Exp :: [TYPE rep] -> TYPE rep -> Type where - Lam :: Exp (a:xs) b -> Exp xs (a -> b) - We want to kind-generalise over the 'rep' variable. - #14563 is another example. - -* Duplicate type variables. Consider #11203 - data SameKind :: k -> k -> * - data Q (a :: k1) (b :: k2) c = MkQ (SameKind a b) - Here we will unify k1 with k2, but this time doing so is an error, - because k1 and k2 are bound in the same declaration. - - We spot this during validity checking (checkForDuplicateScopeTyVars), - in generaliseTcTyCon. - -* Required arguments. Even the Required arguments should be made - into TyVarTvs, not skolems. Consider - data T k (a :: k) - Here, k is a Required, dependent variable. For uniformity, it is helpful - to have k be a TyVarTv, in parallel with other dependent variables. - -* Duplicate skolemisation is expected. When generalising in Step 3, - we may find that one of the variables we want to quantify has - already been skolemised. For example, suppose we have already - generalise S. When we come to T we'll find that kk1 (now the same as - kk3) has already been skolemised. - - That's fine -- but it means that - a) when collecting quantification candidates, in - candidateQTyVarsOfKind, we must collect skolems - b) quantifyTyVars should be a no-op on such a skolem - -Note [Tricky scoping in generaliseTcTyCon] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider #16342 - class C (a::ka) x where - cop :: D a x => x -> Proxy a -> Proxy a - cop _ x = x :: Proxy (a::ka) - - class D (b::kb) y where - dop :: C b y => y -> Proxy b -> Proxy b - dop _ x = x :: Proxy (b::kb) - -C and D are mutually recursive, by the time we get to -generaliseTcTyCon we'll have unified kka := kkb. - -But when typechecking the default declarations for 'cop' and 'dop' in -tcDlassDecl2 we need {a, ka} and {b, kb} respectively to be in scope. -But at that point all we have is the utterly-final Class itself. - -Conclusion: the classTyVars of a class must have the same Name as -that originally assigned by the user. In our example, C must have -classTyVars {a, ka, x} while D has classTyVars {a, kb, y}. Despite -the fact that kka and kkb got unified! - -We achieve this sleight of hand in generaliseTcTyCon, using -the specialised function zonkRecTyVarBndrs. We make the call - zonkRecTyVarBndrs [ka,a,x] [kkb,aa,xxx] -where the [ka,a,x] are the Names originally assigned by the user, and -[kkb,aa,xx] are the corresponding (post-zonking, skolemised) TcTyVars. -zonkRecTyVarBndrs builds a recursive ZonkEnv that binds - kkb :-> (ka :: ) - aa :-> (a :: ) - etc -That is, it maps each skolemised TcTyVars to the utterly-final -TyVar to put in the class, with its correct user-specified name. -When generalising D we'll do the same thing, but the ZonkEnv will map - kkb :-> (kb :: ) - bb :-> (b :: ) - etc -Note that 'kkb' again appears in the domain of the mapping, but this -time mapped to 'kb'. That's how C and D end up with differently-named -final TyVars despite the fact that we unified kka:=kkb - -zonkRecTyVarBndrs we need to do knot-tying because of the need to -apply this same substitution to the kind of each. - -Note [Inferring visible dependent quantification] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - - data T k :: k -> Type where - MkT1 :: T Type Int - MkT2 :: T (Type -> Type) Maybe - -This looks like it should work. However, it is polymorphically recursive, -as the uses of T in the constructor types specialize the k in the kind -of T. This trips up our dear users (#17131, #17541), and so we add -a "landmark" context (which cannot be suppressed) whenever we -spot inferred visible dependent quantification (VDQ). - -It's hard to know when we've actually been tripped up by polymorphic recursion -specifically, so we just include a note to users whenever we infer VDQ. The -testsuite did not show up a single spurious inclusion of this message. - -The context is added in addVDQNote, which looks for a visible TyConBinder -that also appears in the TyCon's kind. (I first looked at the kind for -a visible, dependent quantifier, but Note [No polymorphic recursion] in -GHC.Tc.Gen.HsType defeats that approach.) addVDQNote is used in kcTyClDecl, -which is used only when inferring the kind of a tycon (never with a CUSK or -SAK). - -Once upon a time, I (Richard E) thought that the tycon-kind could -not be a forall-type. But this is wrong: data T :: forall k. k -> Type -(with -XNoCUSKs) could end up here. And this is all OK. - - --} - --------------- -tcExtendKindEnvWithTyCons :: [TcTyCon] -> TcM a -> TcM a -tcExtendKindEnvWithTyCons tcs - = tcExtendKindEnvList [ (tyConName tc, ATcTyCon tc) | tc <- tcs ] - --------------- -mkPromotionErrorEnv :: [LTyClDecl GhcRn] -> TcTypeEnv --- Maps each tycon/datacon to a suitable promotion error --- tc :-> APromotionErr TyConPE --- dc :-> APromotionErr RecDataConPE --- See Note [Recursion and promoting data constructors] - -mkPromotionErrorEnv decls - = foldr (plusNameEnv . mk_prom_err_env . unLoc) - emptyNameEnv decls - -mk_prom_err_env :: TyClDecl GhcRn -> TcTypeEnv -mk_prom_err_env (ClassDecl { tcdLName = L _ nm, tcdATs = ats }) - = unitNameEnv nm (APromotionErr ClassPE) - `plusNameEnv` - mkNameEnv [ (familyDeclName at, APromotionErr TyConPE) - | L _ at <- ats ] - -mk_prom_err_env (DataDecl { tcdLName = L _ name - , tcdDataDefn = HsDataDefn { dd_cons = cons } }) - = unitNameEnv name (APromotionErr TyConPE) - `plusNameEnv` - mkNameEnv [ (con, APromotionErr conPE) - | L _ con' <- toList cons - , L _ con <- getConNames con' ] - where - -- In a "type data" declaration, the constructors are at the type level. - -- See Note [Type data declarations] in GHC.Rename.Module. - conPE - | isTypeDataDefnCons cons = TyConPE - | otherwise = RecDataConPE - -mk_prom_err_env decl - = unitNameEnv (tcdName decl) (APromotionErr TyConPE) - -- Works for family declarations too - --------------- -inferInitialKinds :: [LTyClDecl GhcRn] -> TcM [MonoTcTyCon] --- Returns a TcTyCon for each TyCon bound by the decls, --- each with its initial kind - -inferInitialKinds decls - = do { traceTc "inferInitialKinds {" $ ppr (map (tcdName . unLoc) decls) - ; tcs <- concatMapM infer_initial_kind decls - ; traceTc "inferInitialKinds done }" empty - ; return tcs } - where - infer_initial_kind = addLocMA (getInitialKind InitialKindInfer) - --- Check type/class declarations against their standalone kind signatures or --- CUSKs, producing a generalized TcTyCon for each. -checkInitialKinds :: [(LTyClDecl GhcRn, SAKS_or_CUSK)] -> TcM [PolyTcTyCon] -checkInitialKinds decls - = do { traceTc "checkInitialKinds {" $ ppr (mapFst (tcdName . unLoc) decls) - ; tcs <- concatMapM check_initial_kind decls - ; traceTc "checkInitialKinds done }" empty - ; return tcs } - where - check_initial_kind (ldecl, msig) = - addLocMA (getInitialKind (InitialKindCheck msig)) ldecl - --- | Get the initial kind of a TyClDecl, either generalized or non-generalized, --- depending on the 'InitialKindStrategy'. -getInitialKind :: InitialKindStrategy -> TyClDecl GhcRn -> TcM [TcTyCon] - --- Allocate a fresh kind variable for each TyCon and Class --- For each tycon, return a TcTyCon with kind k --- where k is the kind of tc, derived from the LHS --- of the definition (and probably including --- kind unification variables) --- Example: data T a b = ... --- return (T, kv1 -> kv2 -> kv3) --- --- This pass deals with (ie incorporates into the kind it produces) --- * The kind signatures on type-variable binders --- * The result kinds signature on a TyClDecl --- --- No family instances are passed to checkInitialKinds/inferInitialKinds -getInitialKind strategy - (ClassDecl { tcdLName = L _ name - , tcdTyVars = ktvs - , tcdATs = ats }) - = do { cls_tc <- kcDeclHeader strategy name ClassFlavour ktvs $ - return (TheKind constraintKind) - -- See Note [Don't process associated types in getInitialKind] - - ; at_tcs <- tcExtendTyVarEnv (tyConTyVars cls_tc) $ - mapM (addLocMA (getAssocFamInitialKind cls_tc)) ats - ; return (cls_tc : at_tcs) } - where - getAssocFamInitialKind cls = - case strategy of - InitialKindInfer -> get_fam_decl_initial_kind (Just cls) - InitialKindCheck _ -> check_initial_kind_assoc_fam cls - -getInitialKind strategy - (DataDecl { tcdLName = L _ name - , tcdTyVars = ktvs - , tcdDataDefn = HsDataDefn { dd_kindSig = m_sig, dd_cons = cons } }) - = do { let flav = newOrDataToFlavour (dataDefnConsNewOrData cons) - ctxt = DataKindCtxt name - ; tc <- kcDeclHeader strategy name flav ktvs $ - case m_sig of - Just ksig -> TheKind <$> tcLHsKindSig ctxt ksig - Nothing -> return $ dataDeclDefaultResultKind strategy (dataDefnConsNewOrData cons) - ; return [tc] } - -getInitialKind InitialKindInfer (FamDecl { tcdFam = decl }) - = do { tc <- get_fam_decl_initial_kind Nothing decl - ; return [tc] } - -getInitialKind (InitialKindCheck msig) (FamDecl { tcdFam = - FamilyDecl { fdLName = unLoc -> name - , fdTyVars = ktvs - , fdResultSig = unLoc -> resultSig - , fdInfo = info } } ) - = do { let flav = getFamFlav Nothing info - ctxt = TyFamResKindCtxt name - ; tc <- kcDeclHeader (InitialKindCheck msig) name flav ktvs $ - case famResultKindSignature resultSig of - Just ksig -> TheKind <$> tcLHsKindSig ctxt ksig - Nothing -> - case msig of - CUSK -> return (TheKind liftedTypeKind) - SAKS _ -> return AnyKind - ; return [tc] } - -getInitialKind strategy - (SynDecl { tcdLName = L _ name - , tcdTyVars = ktvs - , tcdRhs = rhs }) - = do { let ctxt = TySynKindCtxt name - ; tc <- kcDeclHeader strategy name TypeSynonymFlavour ktvs $ - case hsTyKindSig rhs of - Just rhs_sig -> TheKind <$> tcLHsKindSig ctxt rhs_sig - Nothing -> return AnyKind - ; return [tc] } - -get_fam_decl_initial_kind - :: Maybe TcTyCon -- ^ Just cls <=> this is an associated family of class cls - -> FamilyDecl GhcRn - -> TcM TcTyCon -get_fam_decl_initial_kind mb_parent_tycon - FamilyDecl { fdLName = L _ name - , fdTyVars = ktvs - , fdResultSig = L _ resultSig - , fdInfo = info } - = kcDeclHeader InitialKindInfer name flav ktvs $ - case resultSig of - KindSig _ ki -> TheKind <$> tcLHsKindSig ctxt ki - TyVarSig _ (L _ (KindedTyVar _ _ _ ki)) -> 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 - -- by default - | otherwise -> return AnyKind - where - flav = getFamFlav mb_parent_tycon info - ctxt = TyFamResKindCtxt name - --- See Note [Standalone kind signatures for associated types] -check_initial_kind_assoc_fam - :: TcTyCon -- parent class - -> FamilyDecl GhcRn - -> TcM TcTyCon -check_initial_kind_assoc_fam cls - FamilyDecl - { fdLName = unLoc -> name - , fdTyVars = ktvs - , fdResultSig = unLoc -> resultSig - , fdInfo = info } - = kcDeclHeader (InitialKindCheck CUSK) name flav ktvs $ - case famResultKindSignature resultSig of - Just ksig -> TheKind <$> tcLHsKindSig ctxt ksig - Nothing -> return (TheKind liftedTypeKind) - where - ctxt = TyFamResKindCtxt name - flav = getFamFlav (Just cls) info - -{- Note [Standalone kind signatures for associated types] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -If associated types had standalone kind signatures, would they wear them - ----------------------------+------------------------------ - like this? (OUT) | or like this? (IN) ----------------------------+------------------------------ - type T :: Type -> Type | class C a where - class C a where | type T :: Type -> Type - type T a | type T a - -The (IN) variant is syntactically ambiguous: - - class C a where - type T :: a -- standalone kind signature? - type T :: a -- declaration header? - -The (OUT) variant does not suffer from this issue, but it might not be the -direction in which we want to take Haskell: we seek to unify type families and -functions, and, by extension, associated types with class methods. And yet we -give class methods their signatures inside the class, not outside. Neither do -we have the counterpart of InstanceSigs for StandaloneKindSignatures. - -For now, we dodge the question by using CUSKs for associated types instead of -standalone kind signatures. This is a simple addition to the rule we used to -have before standalone kind signatures: - - old rule: associated type has a CUSK iff its parent class has a CUSK - new rule: associated type has a CUSK iff its parent class has a CUSK or a standalone kind signature - --} - --- See Note [Data declaration default result kind] -dataDeclDefaultResultKind :: InitialKindStrategy -> NewOrData -> ContextKind -dataDeclDefaultResultKind strategy new_or_data - | NewType <- new_or_data - = OpenKind -- See Note [Implementation of UnliftedNewtypes], point . - | DataType <- new_or_data - , InitialKindCheck (SAKS _) <- strategy - = OpenKind -- See Note [Implementation of UnliftedDatatypes] - | otherwise - = TheKind liftedTypeKind - -{- Note [Data declaration default result kind] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When the user has not written an inline result kind annotation on a data -declaration, we assume it to be 'Type'. That is, the following declarations -D1 and D2 are considered equivalent: - - data D1 where ... - data D2 :: Type where ... - -The consequence of this assumption is that we reject D3 even though we -accept D4: - - data D3 where - MkD3 :: ... -> D3 param - - data D4 :: Type -> Type where - MkD4 :: ... -> D4 param - -However, there are two twists: - - * For unlifted newtypes, we must relax the assumed result kind to (TYPE r): - - newtype D5 where - MkD5 :: Int# -> D5 - - See Note [Implementation of UnliftedNewtypes], STEP 1 and it's sub-note - . - - * For unlifted datatypes, we must relax the assumed result kind to - (TYPE (BoxedRep l)) in the presence of a SAKS: - - type D6 :: Type -> TYPE (BoxedRep Unlifted) - data D6 a = MkD6 a - - Otherwise, it would be impossible to declare unlifted data types in H98 - syntax (which doesn't allow specification of a result kind). - --} - ---------------------------------- -getFamFlav - :: Maybe TcTyCon -- ^ Just cls <=> this is an associated family of class cls - -> FamilyInfo pass - -> TyConFlavour -getFamFlav mb_parent_tycon info = - case info of - DataFamily -> DataFamilyFlavour mb_parent_tycon - OpenTypeFamily -> OpenTypeFamilyFlavour mb_parent_tycon - ClosedTypeFamily _ -> assert (isNothing mb_parent_tycon) -- See Note [Closed type family mb_parent_tycon] - ClosedTypeFamilyFlavour - -{- Note [Closed type family mb_parent_tycon] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -There's no way to write a closed type family inside a class declaration: - - class C a where - type family F a where -- error: parse error on input ‘where’ - -In fact, it is not clear what the meaning of such a declaration would be. -Therefore, 'mb_parent_tycon' of any closed type family has to be Nothing. --} - ------------------------------------------------------------------------- -kcLTyClDecl :: LTyClDecl GhcRn -> TcM () - -- See Note [Kind checking for type and class decls] - -- Called only for declarations without a signature (no CUSKs or SAKs here) -kcLTyClDecl (L loc decl) - = setSrcSpanA loc $ - do { tycon <- tcLookupTcTyCon tc_name -- Always a MonoTcTyCon - ; traceTc "kcTyClDecl {" (ppr tc_name) - ; addVDQNote tycon $ -- See Note [Inferring visible dependent quantification] - addErrCtxt (tcMkDeclCtxt decl) $ - kcTyClDecl decl tycon - ; traceTc "kcTyClDecl done }" (ppr tc_name) } - where - tc_name = tcdName decl - -kcTyClDecl :: TyClDecl GhcRn -> MonoTcTyCon -> TcM () --- This function is used solely for its side effect on kind variables --- NB kind signatures on the type variables and --- result kind signature have already been dealt with --- by inferInitialKind, so we can ignore them here. - --- NB these equations just extend the type environment with carefully constructed --- TcTyVars rather than create skolemised variables for the bound variables. --- - inferInitialKinds makes the TcTyCon where the tyvars are TcTyVars --- - In this function, those TcTyVars are unified with other kind variables during --- kind inference (see [How TcTyCons work]) - -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, - -- and the ones from this bindTyClTyVars are either not mentioned or - -- (conceivably) shadowed. - do { traceTc "kcTyClDecl" (ppr tycon $$ ppr (tyConTyVars tycon) $$ ppr (tyConResKind tycon)) - ; _ <- tcHsContext ctxt - ; kcConDecls (dataDefnConsNewOrData cons) (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) - -- NB: check against the result kind that we allocated - -- in inferInitialKinds. - -kcTyClDecl (ClassDecl { tcdLName = L _ _name - , tcdCtxt = ctxt, tcdSigs = sigs }) tycon - = tcExtendNameTyVarEnv (tcTyConScopedTyVars tycon) $ - do { _ <- tcHsContext ctxt - ; mapM_ (wrapLocMA_ kc_sig) sigs } - where - kc_sig (ClassOpSig _ _ nms op_ty) = kcClassSigType nms op_ty - kc_sig _ = return () - -kcTyClDecl (FamDecl _ (FamilyDecl { fdInfo = fd_info })) fam_tc --- closed type families look at their equations, but other families don't --- do anything here - = case fd_info of - ClosedTypeFamily (Just eqns) -> mapM_ (kcTyFamInstEqn fam_tc) eqns - _ -> return () - -------------------- - --- Kind-check the types of the arguments to a data constructor. --- 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) - -- 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 - --- 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 - -kcConDecls :: Foldable f - => NewOrData - -> TcKind -- The result kind signature - -- Used only in H98 case - -> f (LConDecl GhcRn) -- The data constructors - -> 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)) - --- 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)) $ - discardResult $ - bindExplicitTKBndrs_Tv ex_tvs $ - do { _ <- tcHsContext ex_ctxt - ; kcConH98Args new_or_data tc_res_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 }) - = -- See Note [kcConDecls: kind-checking data type decls] - addErrCtxt (dataConCtxt names) $ - discardResult $ - -- 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] - 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) - ; return () } - -{- 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. - -In the GADT case we may have this: - data T f a where - MkT :: forall g b. g b -> T g b - -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. - -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). - -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. - -* 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. - -Note [Using TyVarTvs for kind-checking GADTs] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - - data Proxy a where - MkProxy1 :: forall k (b :: k). Proxy b - MkProxy2 :: forall j (c :: j). Proxy c - -It seems reasonable that this should be accepted. But something very strange -is going on here: when we're kind-checking this declaration, we need to unify -the kind of `a` with k and j -- even though k and j's scopes are local to the type of -MkProxy{1,2}. - -In effect, we are simply gathering constraints on the shape of Proxy's -kind, with no skolemisation or implication constraints involved at all. - -The best approach we've come up with is to use TyVarTvs during the -kind-checking pass, rather than ordinary skolems. This is why we use -the "_Tv" variant, bindOuterSigTKBndrs_Tv. - -Our only goal is to gather constraints on the kind of the type constructor; -we do not certify that the data declaration is well-kinded. For example: - - data SameKind :: k -> k -> Type - data Bad a where - MkBad :: forall k1 k2 (a :: k1) (b :: k2). Bad (SameKind a b) - -which would be accepted by kcConDecl because k1 and k2 are -TyVarTvs. It is correctly rejected in the second pass, tcConDecl. -(Test case: polykinds/TyVarTvKinds3) - -One drawback of this approach is sometimes it will accept a definition that -a (hypothetical) declarative specification would likely reject. As a general -rule, we don't want to allow polymorphic recursion without a CUSK. Indeed, -the whole point of CUSKs is to allow polymorphic recursion. Yet, the TyVarTvs -approach allows a limited form of polymorphic recursion *without* a CUSK. - -To wit: - data T a = forall k (b :: k). MkT (T b) Int - (test case: dependent/should_compile/T14066a) - -Note that this is polymorphically recursive, with the recursive occurrence -of T used at a kind other than a's kind. The approach outlined here accepts -this definition, because this kind is still a kind variable (and so the -TyVarTvs unify). Stepping back, I (Richard) have a hard time envisioning a -way to describe exactly what declarations will be accepted and which will -be rejected (without a CUSK). However, the accepted definitions are indeed -well-kinded and any rejected definitions would be accepted with a CUSK, -and so this wrinkle need not cause anyone to lose sleep. - -Note [Recursion and promoting data constructors] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We don't want to allow promotion in a strongly connected component -when kind checking. - -Consider: - data T f = K (f (K Any)) - -When kind checking the `data T' declaration the local env contains the -mappings: - T -> ATcTyCon - K -> APromotionErr - -APromotionErr is only used for DataCons, and only used during type checking -in tcTyClGroup. - -The same restriction applies constructors in to "type data" declarations. -See Note [Type data declarations] in GHC.Rename.Module. - - -************************************************************************ -* * -\subsection{Type checking} -* * -************************************************************************ - -Note [Type checking recursive type and class declarations] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -At this point we have completed *kind-checking* of a mutually -recursive group of type/class decls (done in kcTyClGroup). However, -we discarded the kind-checked types (eg RHSs of data type decls); -note that kcTyClDecl returns (). There are two reasons: - - * It's convenient, because we don't have to rebuild a - kinded HsDecl (a fairly elaborate type) - - * It's necessary, because after kind-generalisation, the - TyCons/Classes may now be kind-polymorphic, and hence need - to be given kind arguments. - -Example: - data T f a = MkT (f a) (T f a) -During kind-checking, we give T the kind T :: k1 -> k2 -> * -and figure out constraints on k1, k2 etc. Then we generalise -to get T :: forall k. (k->*) -> k -> * -So now the (T f a) in the RHS must be elaborated to (T k f a). - -However, during tcTyClDecl of T (above) we will be in a recursive -"knot". So we aren't allowed to look at the TyCon T itself; we are only -allowed to put it (lazily) in the returned structures. But when -kind-checking the RHS of T's decl, we *do* need to know T's kind (so -that we can correctly elaborate (T k f a). How can we get T's kind -without looking at T? Delicate answer: during tcTyClDecl, we extend - - *Global* env with T -> ATyCon (the (not yet built) final TyCon for T) - *Local* env with T -> ATcTyCon (TcTyCon with the polymorphic kind of T) - -Then: - - * During GHC.Tc.Gen.HsType.tcTyVar we look in the *local* env, to get the - fully-known, not knot-tied TcTyCon for T. - - * Then, in GHC.Tc.Utils.Zonk.zonkTcTypeToType (and zonkTcTyCon in particular) - we look in the *global* env to get the TyCon. - -This fancy footwork (with two bindings for T) is only necessary for the -TyCons or Classes of this recursive group. Earlier, finished groups, -live in the global env only. - -See also Note [Kind checking recursive type and class declarations] - -Note [Kind checking recursive type and class declarations] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Before we can type-check the decls, we must kind check them. This -is done by establishing an "initial kind", which is a rather uninformed -guess at a tycon's kind (by counting arguments, mainly) and then -using this initial kind for recursive occurrences. - -The initial kind is stored in exactly the same way during -kind-checking as it is during type-checking (Note [Type checking -recursive type and class declarations]): in the *local* environment, -with ATcTyCon. But we still must store *something* in the *global* -environment. Even though we discard the result of kind-checking, we -sometimes need to produce error messages. These error messages will -want to refer to the tycons being checked, except that they don't -exist yet, and it would be Terribly Annoying to get the error messages -to refer back to HsSyn. So we create a TcTyCon and put it in the -global env. This tycon can print out its name and knows its kind, but -any other action taken on it will panic. Note that TcTyCons are *not* -knot-tied, unlike the rather valid but knot-tied ones that occur -during type-checking. - -Note [Declarations for wired-in things] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -For wired-in things we simply ignore the declaration -and take the wired-in information. That avoids complications. -e.g. the need to make the data constructor worker name for - a constraint tuple match the wired-in one - -Note [Datatype return kinds] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -There are several poorly lit corners around datatype/newtype return kinds. -This Note explains these. We cover data/newtype families and instances -in Note [Data family/instance return kinds]. - -data T a :: where ... -- See Point DT4 -newtype T a :: where ... -- See Point DT5 - -DT1 Where this applies: Only GADT syntax for data/newtype/instance declarations - can have declared return kinds. This Note does not apply to Haskell98 - syntax. - -DT2 Where these kinds come from: The return kind is part of the TyCon kind, gotten either - by checkInitialKind (standalone kind signature / CUSK) or - inferInitialKind. It is extracted by bindTyClTyVars in tcTyClDecl1. It is - then passed to tcDataDefn. - -DT3 Eta-expansion: Any forall-bound variables and function arguments in a result kind - become parameters to the type. That is, when we say - - 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, - called in tcDataDefn. - - See also Note [splitTyConKind] in GHC.Tc.Gen.HsType. - -DT4 Datatype return kind restriction: A data type return kind must end - in a type that, after type-synonym expansion, yields `TYPE LiftedRep`. By - "end in", we mean we strip any foralls and function arguments off before - checking. - - Examples: - data T1 :: Type -- good - data T2 :: Bool -> Type -- good - data T3 :: Bool -> forall k. Type -- strange, but still accepted - data T4 :: forall k. k -> Type -- good - data T5 :: Bool -- bad - data T6 :: Type -> Bool -- bad - - Exactly the same applies to data instance (but not data family) - declarations. Examples - data instance D1 :: Type -- good - data instance D2 :: Bool -> Type -- good - - We can "look through" type synonyms - type Star = Type - data T7 :: Bool -> Star -- good (synonym expansion ok) - type Arrow = (->) - data T8 :: Arrow Bool Type -- good (ditto) - - But we specifically do *not* do type family reduction here. - type family ARROW where - ARROW = (->) - data T9 :: ARROW Bool Type -- bad - - type family F a where - F Int = Bool - F Bool = Type - data T10 :: Bool -> F Bool -- bad - - The /principle/ here is that in the TyCon for a data type or data instance, - we must be able to lay out all the type-variable binders, one by one, until - we reach (TYPE xx). There is no place for a cast here. We could add one, - but let's not! - - This check is done in checkDataKindSig. For data declarations, this - call is in tcDataDefn; for data instances, this call is in tcDataFamInstDecl. - -DT5 Newtype return kind restriction. - If -XUnliftedNewtypes is not on, then newtypes are treated just - like datatypes --- see (4) above. - - If -XUnliftedNewtypes is on, then a newtype return kind must end in - TYPE xyz, for some xyz (after type synonym expansion). The "xyz" - may include type families, but the TYPE part must be visible - /without/ expanding type families (only synonyms). - - This kind is unified with the kind of the representation type (the - type of the one argument to the one constructor). See also steps - (2) and (3) of Note [Implementation of UnliftedNewtypes]. - - The checks are done in the same places as for datatypes. - Examples (assume -XUnliftedNewtypes): - - newtype N1 :: Type -- good - newtype N2 :: Bool -> Type -- good - newtype N3 :: forall r. Bool -> TYPE r -- good - - type family F (t :: Type) :: RuntimeRep - newtype N4 :: forall t -> TYPE (F t) -- good - - type family STAR where - STAR = Type - newtype N5 :: Bool -> STAR -- bad - -Note [Data family/instance return kinds] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Within this note, understand "instance" to mean data or newtype -instance, and understand "family" to mean data family. No type -families or classes here. Some examples: - -data family T a :: -- See Point DF56 - -data instance T [a] :: where ... -- See Point DF2 -newtype instance T [a] :: where ... -- See Point DF2 - -Here is the Plan for Data Families: - -DF0 Where these kinds come from: - - Families: The return kind is either written in a standalone signature - or extracted from a family declaration in getInitialKind. - If a family declaration is missing a result kind, it is assumed to be - 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. - -DF1 In a data/newtype instance, we treat the kind of the /data family/, - once instantiated, as the "master kind" for the representation - TyCon. For example: - data family T1 :: Type -> Type -> Type - data instance T1 Int :: F Bool -> Type where ... - The "master kind" for the representation TyCon R:T1Int comes - from T1, not from the signature on the data instance. It is as - if we declared - data R:T1Int :: Type -> Type where ... - See Note [Liberalising data family return kinds] for an alternative - plan. But this current plan is simple, and ensures that all instances - are simple instantiations of the master, without strange casts. - - An example with non-trivial instantiation: - data family T2 :: forall k. Type -> k - data instance T2 :: Type -> Type -> Type where ... - Here 'k' gets instantiated with (Type -> Type), driven by - the signature on the 'data instance'. (See also DT3 of - Note [Datatype return kinds] about eta-expansion, which applies here, - too; see tcDataFamInstDecl's call of etaExpandAlgTyCon.) - - A newtype example: - - data Color = Red | Blue - type family Interpret (x :: Color) :: RuntimeRep where - Interpret 'Red = 'IntRep - Interpret 'Blue = 'WordRep - data family Foo (x :: Color) :: TYPE (Interpret x) - newtype instance Foo 'Red :: TYPE IntRep where - FooRedC :: Int# -> Foo 'Red - - Here we get that Foo 'Red :: TYPE (Interpret Red), and our - representation newtype looks like - newtype R:FooRed :: TYPE (Interpret Red) where - FooRedC :: Int# -> R:FooRed - Remember: the master kind comes from the /family/ tycon. - -DF2 /After/ this instantiation, the return kind of the master kind - must obey the usual rules for data/newtype return kinds (DT4, DT5) - of Note [Datatype return kinds]. Examples: - data family T3 k :: k - data instance T3 Type where ... -- OK - data instance T3 (Type->Type) where ... -- OK - data instance T3 (F Int) where ... -- Not OK - -DF3 Any kind signatures on the data/newtype instance are checked for - equality with the master kind (and hence may guide instantiation) - but are otherwise ignored. So in the T1 example above, we check - that (F Int ~ Type) by unification; but otherwise ignore the - user-supplied signature from the /family/ not the /instance/. - - We must be sure to instantiate any trailing invisible binders - before doing this unification. See the call to tcInstInvisibleBinders - in tcDataFamInstHeader. For example: - data family D :: forall k. k - data instance D :: Type -- forall k. k <: Type - data instance D :: Type -> Type -- forall k. k <: Type -> Type - -- NB: these do not overlap - we must instantiate D before unifying with the signature in the - data instance declaration - -DF4 We also (redundantly) check that any user-specified return kind - signature in the data instance also obeys DT4/DT5. For example we - reject - data family T1 :: Type -> Type -> Type - data instance T1 Int :: Type -> F Int - even if (F Int ~ Type). We could omit this check, because we - use the master kind; but it seems more uniform to check it, again - with checkDataKindSig. - -DF5 Data /family/ return kind restrictions. Consider - data family D8 a :: F a - where F is a type family. No data/newtype instance can instantiate - this so that it obeys the rules of DT4 or DT5. So GHC proactively - rejects the data /family/ declaration if it can never satisfy (DT4)/(DT5). - Remember that a data family supports both data and newtype instances. - - More precisely, the return kind of a data family must be either - * TYPE xyz (for some type xyz) or - * a kind variable - Only in these cases can a data/newtype instance possibly satisfy (DT4)/(DT5). - This is checked by the call to checkDataKindSig in tcFamDecl1. Examples: - - data family D1 :: Type -- good - data family D2 :: Bool -> Type -- good - data family D3 k :: k -- good - data family D4 :: forall k -> k -- good - data family D5 :: forall k. k -> k -- good - data family D6 :: forall r. TYPE r -- good - data family D7 :: Bool -> STAR -- bad (see STAR from point 5) - -DF6 Two return kinds for instances: If an instance has two return kinds, - one from the family declaration and one from the instance declaration - (see point DF3 above), they are unified. More accurately, we make sure - that the kind of the applied data family is a subkind of the user-written - kind. GHC.Tc.Gen.HsType.checkExpectedKind normally does this check for types, but - that's overkill for our needs here. Instead, we just instantiate any - invisible binders in the (instantiated) kind of the data family - (called lhs_kind in tcDataFamInstHeader) with tcInstInvisibleTyBinders - and then unify the resulting kind with the kind written by the user. - This unification naturally produces a coercion, which we can drop, as - the kind annotation on the instance is redundant (except perhaps for - effects of unification). - - This all is Wrinkle (3) in Note [Implementation of UnliftedNewtypes]. - -Note [Liberalising data family return kinds] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Could we allow this? - type family F a where { F Int = Type } - data family T a :: F a - data instance T Int where - MkT :: T Int - -In the 'data instance', T Int :: F Int, and F Int = Type, so all seems -well. But there are lots of complications: - -* The representation constructor R:TInt presumably has kind Type. - So the axiom connecting the two would have to look like - axTInt :: T Int ~ R:TInt |> sym axFInt - and that doesn't match expectation in DataFamInstTyCon - in AlgTyConFlav - -* The wrapper can't have type - $WMkT :: Int -> T Int - because T Int has the wrong kind. It would have to be - $WMkT :: Int -> (T Int) |> axFInt - -* The code for $WMkT would also be more complicated, needing - two coherence coercions. Try it! - -* Code for pattern matching would be complicated in an - exactly dual way. - -So yes, we could allow this, but we currently do not. That's -why we have DF2 in Note [Data family/instance return kinds]. - -Note [Implementation of UnliftedNewtypes] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Expected behavior of UnliftedNewtypes: - -* Proposal: https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0013-unlifted-newtypes.rst -* Discussion: https://github.com/ghc-proposals/ghc-proposals/pull/98 - -What follows is a high-level overview of the implementation of the -proposal. - -STEP 1: Getting the initial kind, as done by inferInitialKind. We have -two sub-cases: - -* With a SAK/CUSK: no change in kind-checking; the tycon is given the kind - the user writes, whatever it may be. - -* Without a SAK/CUSK: If there is no kind signature, the tycon is given - a kind `TYPE r`, for a fresh unification variable `r`. We do this even - when -XUnliftedNewtypes is not on; see , below. - -STEP 2: Kind-checking, as done by kcTyClDecl. This step is skipped for CUSKs. -The key function here is kcConDecl, which looks at an individual constructor -declaration. When we are processing a newtype (but whether or not -XUnliftedNewtypes -is enabled; see , below), we generate a correct ContextKind -for the checking argument types: see getArgExpKind. - -Examples of newtypes affected by STEP 2, assuming -XUnliftedNewtypes is -enabled (we use r0 to denote a unification variable): - -newtype Foo rep = MkFoo (forall (a :: TYPE rep). a) -+ kcConDecl unifies (TYPE r0) with (TYPE rep), where (TYPE r0) - is the kind that inferInitialKind invented for (Foo rep). - -data Color = Red | Blue -type family Interpret (x :: Color) :: RuntimeRep where - Interpret 'Red = 'IntRep - Interpret 'Blue = 'WordRep -data family Foo (x :: Color) :: TYPE (Interpret x) -newtype instance Foo 'Red = FooRedC Int# -+ kcConDecl unifies TYPE (Interpret 'Red) with TYPE 'IntRep - -Note that, in the GADT case, we might have a kind signature with arrows -(newtype XYZ a b :: Type -> Type where ...). We want only the final -component of the kind for checking in kcConDecl, so we call etaExpanAlgTyCon -in kcTyClDecl. - -STEP 3: Type-checking (desugaring), as done by tcTyClDecl. The key function -here is tcConDecl. Once again, we must use getArgExpKind to ensure that the -representation type's kind matches that of the newtype, for two reasons: - - A. It is possible that a GADT has a CUSK. (Note that this is *not* - possible for H98 types.) Recall that CUSK types don't go through - kcTyClDecl, so we might not have done this kind check. - B. We need to produce the coercion to put on the argument type - if the kinds are different (for both H98 and GADT). - -Example of (B): - -type family F a where - F Int = LiftedRep - -newtype N :: TYPE (F Int) where - MkN :: Int -> N - -We really need to have the argument to MkN be (Int |> TYPE (sym axF)), where -axF :: F Int ~ LiftedRep. That way, the argument kind is the same as the -newtype kind, which is the principal correctness condition for newtypes. - -Wrinkle: Consider (#17021, typecheck/should_fail/T17021) - - type family Id (x :: a) :: a where - Id x = x - - newtype T :: TYPE (Id LiftedRep) where - MkT :: Int -> T - - In the type of MkT, we must end with (Int |> TYPE (sym axId)) -> T, - never Int -> (T |> TYPE axId); otherwise, the result type of the - constructor wouldn't match the datatype. However, type-checking the - HsType T might reasonably result in (T |> hole). We thus must ensure - that this cast is dropped, forcing the type-checker to add one to - the Int instead. - - Why is it always safe to drop the cast? This result type is type-checked by - tcHsOpenType, so its kind definitely looks like TYPE r, for some r. It is - important that even after dropping the cast, the type's kind has the form - TYPE r. This is guaranteed by restrictions on the kinds of datatypes. - For example, a declaration like `newtype T :: Id Type` is rejected: a - newtype's final kind always has the form TYPE r, just as we want. - -Note that this is possible in the H98 case only for a data family, because -the H98 syntax doesn't permit a kind signature on the newtype itself. - -There are also some changes for dealing with families: - -1. In tcFamDecl1, we suppress a tcIsLiftedTypeKind check if - UnliftedNewtypes is on. This allows us to write things like: - data family Foo :: TYPE 'IntRep - -2. In a newtype instance (with -XUnliftedNewtypes), if the user does - not write a kind signature, we want to allow the possibility that - the kind is not Type, so we use newOpenTypeKind instead of liftedTypeKind. - This is done in tcDataFamInstHeader in GHC.Tc.TyCl.Instance. Example: - - data family Bar (a :: RuntimeRep) :: TYPE a - newtype instance Bar 'IntRep = BarIntC Int# - newtype instance Bar 'WordRep :: TYPE 'WordRep where - BarWordC :: Word# -> Bar 'WordRep - - The data instance corresponding to IntRep does not specify a kind signature, - so tc_kind_sig just returns `TYPE r0` (where `r0` is a fresh metavariable). - The data instance corresponding to WordRep does have a kind signature, so - we use that kind signature. - -3. A data family and its newtype instance may be declared with slightly - different kinds. See point DF6 in Note [Data family/instance return kinds] - -There's also a change in the renamer: - -* In GHC.RenameSource.rnTyClDecl, enabling UnliftedNewtypes changes what is means - for a newtype to have a CUSK. This is necessary since UnliftedNewtypes - means that, for newtypes without kind signatures, we must use the field - inside the data constructor to determine the result kind. - See Note [Unlifted Newtypes and CUSKs] for more detail. - -For completeness, it was also necessary to make coerce work on -unlifted types, resolving #13595. - -: It's tempting to think that the expected kind for a newtype -constructor argument when -XUnliftedNewtypes is *not* enabled should just be Type. -But this leads to difficulty in suggesting to enable UnliftedNewtypes. Here is -an example: - - newtype A = MkA Int# - -If we expect the argument to MkA to have kind Type, then we get a kind-mismatch -error. The problem is that there is no way to connect this mismatch error to --XUnliftedNewtypes, and suggest enabling the extension. So, instead, we allow -the A to type-check, but then find the problem when doing validity checking (and -where we get make a suitable error message). One potential worry is - - {-# LANGUAGE PolyKinds #-} - newtype B a = MkB a - -This turns out OK, because unconstrained RuntimeReps default to LiftedRep, just -as we would like. Another potential problem comes in a case like - - -- no UnliftedNewtypes - - data family D :: k - newtype instance D = MkD Any - -Here, we want inference to tell us that k should be instantiated to Type in -the instance. With the approach described here (checking for Type only in -the validity checker), that will not happen. But I cannot think of a non-contrived -example that will notice this lack of inference, so it seems better to improve -error messages than be able to infer this instantiation. - -Note [Implementation of UnliftedDatatypes] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Expected behavior of UnliftedDatatypes: - -* Proposal: https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0265-unlifted-datatypes.rst -* Discussion: https://github.com/ghc-proposals/ghc-proposals/pull/265 - -The implementation heavily leans on Note [Implementation of UnliftedNewtypes]. - -In the frontend, the following tweaks have been made in the typechecker: - -* STEP 1: In the inferInitialKinds phase, newExpectedKind gives data type - constructors a result kind of `TYPE r` with a fresh unification variable - `r :: RuntimeRep` when there is a SAKS. (Same as for UnliftedNewtypes.) - Not needed with a CUSK, because it can't specify result kinds. - If there's a GADTSyntax result kind signature, we keep on using that kind. - - Similarly, for data instances without a kind signature, we use - `TYPE r` as the result kind, to support the following code: - - data family F a :: UnliftedType - data instance F Int = TInt - - The omission of a kind signature for `F` should not mean a result kind - of `Type` (and thus a kind error) here. - -* STEP 2: No change to kcTyClDecl. - -* STEP 3: In GHC.Tc.Gen.HsType.checkDataKindSig, we make sure that the result - kind of the data declaration is actually `Type` or `TYPE (BoxedRep l)`, - for some `l`. If UnliftedDatatypes is not activated, we emit an error with a - suggestion in the latter case. - - Why not start out with `TYPE (BoxedRep l)` in the first place? Because then - we get worse kind error messages in e.g. saks_fail010: - - - Couldn't match expected kind: TYPE ('GHC.Types.BoxedRep t0) - - with actual kind: * -> * - + Expected a type, but found something with kind ‘* -> *’ - In the data type declaration for ‘T’ - - It seems `TYPE r` already has appropriate pretty-printing support. - -The changes to Core, STG and Cmm are of rather cosmetic nature. -The IRs are already well-equipped to handle unlifted types, and unlifted -datatypes are just a new sub-class thereof. --} - -tcTyClDecl :: RolesInfo -> LTyClDecl GhcRn -> TcM (TyCon, [DerivInfo]) -tcTyClDecl roles_info (L loc decl) - | Just thing <- wiredInNameTyThing_maybe (tcdName decl) - = case thing of -- See Note [Declarations for wired-in things] - ATyCon tc -> return (tc, wiredInDerivInfo tc decl) - _ -> pprPanic "tcTyClDecl" (ppr thing) - - | otherwise - = setSrcSpanA loc $ tcAddDeclCtxt decl $ - do { traceTc "---- tcTyClDecl ---- {" (ppr decl) - ; (tc, deriv_infos) <- tcTyClDecl1 Nothing roles_info decl - ; traceTc "---- tcTyClDecl end ---- }" (ppr tc) - ; return (tc, deriv_infos) } - -noDerivInfos :: a -> (a, [DerivInfo]) -noDerivInfos a = (a, []) - -wiredInDerivInfo :: TyCon -> TyClDecl GhcRn -> [DerivInfo] -wiredInDerivInfo tycon decl - | DataDecl { tcdDataDefn = dataDefn } <- decl - , HsDataDefn { dd_derivs = derivs } <- dataDefn - = [ DerivInfo { di_rep_tc = tycon - , di_scoped_tvs = - if isPrimTyCon tycon - then [] -- no tyConTyVars - else mkTyVarNamePairs (tyConTyVars tycon) - , di_clauses = derivs - , di_ctxt = tcMkDeclCtxt decl } ] -wiredInDerivInfo _ _ = [] - - -- "type family" declarations -tcTyClDecl1 :: Maybe Class -> RolesInfo -> TyClDecl GhcRn -> TcM (TyCon, [DerivInfo]) -tcTyClDecl1 parent _roles_info (FamDecl { tcdFam = fd }) - = fmap noDerivInfos $ - tcFamDecl1 parent fd - - -- "type" synonym declaration -tcTyClDecl1 _parent roles_info - (SynDecl { tcdLName = L _ tc_name - , tcdRhs = rhs }) - = assert (isNothing _parent ) - fmap noDerivInfos $ - tcTySynRhs roles_info tc_name rhs - - -- "data/newtype" declaration -tcTyClDecl1 _parent roles_info - decl@(DataDecl { tcdLName = L _ tc_name - , tcdDataDefn = defn }) - = assert (isNothing _parent) $ - tcDataDefn (tcMkDeclCtxt decl) roles_info tc_name defn - -tcTyClDecl1 _parent roles_info - (ClassDecl { tcdLName = L _ class_name - , tcdCtxt = hs_ctxt - , tcdMeths = meths - , tcdFDs = fundeps - , tcdSigs = sigs - , tcdATs = ats - , tcdATDefs = at_defs }) - = assert (isNothing _parent) $ - do { clas <- tcClassDecl1 roles_info class_name hs_ctxt - meths fundeps sigs ats at_defs - ; return (noDerivInfos (classTyCon clas)) } - - -{- ********************************************************************* -* * - Class declarations -* * -********************************************************************* -} - -tcClassDecl1 :: RolesInfo -> Name -> Maybe (LHsContext GhcRn) - -> LHsBinds GhcRn -> [LHsFunDep GhcRn] -> [LSig GhcRn] - -> [LFamilyDecl GhcRn] -> [LTyFamDefltDecl GhcRn] - -> TcM Class -tcClassDecl1 roles_info class_name hs_ctxt meths fundeps sigs ats at_defs - = fixM $ \ clas -> -- We need the knot because 'clas' is passed into tcClassATs - bindTyClTyVars class_name $ \ tc_bndrs res_kind -> - do { checkClassKindSig res_kind - ; traceTc "tcClassDecl 1" (ppr class_name $$ ppr tc_bndrs) - ; let tycon_name = class_name -- We use the same name - roles = roles_info tycon_name -- for TyCon and Class - - ; (ctxt, fds, sig_stuff, at_stuff) - <- pushLevelAndSolveEqualities skol_info tc_bndrs $ - -- 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 - ; sig_stuff <- tcClassSigs class_name sigs meths - ; at_stuff <- tcClassATs class_name clas ats at_defs - ; return (ctxt, fds, sig_stuff, at_stuff) } - - -- See Note [Error on unconstrained meta-variables] in GHC.Tc.Utils.TcMType - -- Example: (typecheck/should_fail/T17562) - -- type C :: Type -> Type -> Constraint - -- class (forall a. a b ~ a c) => C b c - -- The kind of `a` is unconstrained. - ; dvs <- candidateQTyVarsOfTypes ctxt - ; let mk_doc tidy_env = do { (tidy_env2, ctxt) <- zonkTidyTcTypes tidy_env ctxt - ; return ( tidy_env2 - , sep [ text "the class context:" - , pprTheta ctxt ] ) } - ; doNotQuantifyTyVars dvs mk_doc - - -- The pushLevelAndSolveEqualities will report errors for any - -- unsolved equalities, so these zonks should not encounter - -- any unfilled coercion variables unless there is such an error - -- The zonk also squeeze out the TcTyCons, and converts - -- Skolems to tyvars. - ; ze <- mkEmptyZonkEnv NoFlexi - ; (ze, bndrs) <- zonkTyVarBindersX ze tc_bndrs -- From TcTyVars to TyVars - ; ctxt <- zonkTcTypesToTypesX ze ctxt - ; sig_stuff <- mapM (zonkTcMethInfoToMethInfoX ze) sig_stuff - -- ToDo: do we need to zonk at_stuff? - - -- TODO: Allow us to distinguish between abstract class, - -- and concrete class with no methods (maybe by - -- specifying a trailing where or not - - ; mindef <- tcClassMinimalDef class_name sigs sig_stuff - ; is_boot <- tcIsHsBootOrSig - ; let body | 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: - -- - -- class () => C a b | a -> b - -- - -- 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 - ; traceTc "tcClassDecl" (ppr fundeps $$ ppr bndrs $$ - ppr fds) - ; return clas } - where - skol_info = TyConSkol ClassFlavour class_name - - tc_fundep :: GHC.Hs.FunDep GhcRn -> TcM ([Var],[Var]) - tc_fundep (FunDep _ tvs1 tvs2) - = do { tvs1' <- mapM (tcLookupTyVar . unLoc) tvs1 ; - ; tvs2' <- mapM (tcLookupTyVar . unLoc) tvs2 ; - ; return (tvs1',tvs2') } - - -{- Note [Associated type defaults] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -The following is an example of associated type defaults: - class C a where - data D a - - type F a b :: * - type F a b = [a] -- Default - -Note that we can get default definitions only for type families, not data -families. --} - -tcClassATs :: Name -- The class name (not knot-tied) - -> Class -- The class parent of this associated type - -> [LFamilyDecl GhcRn] -- Associated types. - -> [LTyFamDefltDecl GhcRn] -- Associated type defaults. - -> TcM [ClassATItem] -tcClassATs class_name cls ats at_defs - = do { -- Complain about associated type defaults for non associated-types - sequence_ [ failWithTc (TcRnBadAssociatedType class_name n) - | n <- map at_def_tycon at_defs - , not (n `elemNameSet` at_names) ] - ; mapM tc_at ats } - where - at_def_tycon :: LTyFamDefltDecl GhcRn -> Name - at_def_tycon = tyFamInstDeclName . unLoc - - at_fam_name :: LFamilyDecl GhcRn -> Name - at_fam_name = familyDeclName . unLoc - - at_names = mkNameSet (map at_fam_name ats) - - at_defs_map :: NameEnv [LTyFamDefltDecl GhcRn] - -- Maps an AT in 'ats' to a list of all its default defs in 'at_defs' - at_defs_map = foldr (\at_def nenv -> extendNameEnv_C (++) nenv - (at_def_tycon at_def) [at_def]) - emptyNameEnv at_defs - - tc_at at = do { fam_tc <- addLocMA (tcFamDecl1 (Just cls)) at - ; let at_defs = lookupNameEnv at_defs_map (at_fam_name at) - `orElse` [] - ; atd <- tcDefaultAssocDecl fam_tc at_defs - ; return (ATI fam_tc atd) } - -------------------------- -tcDefaultAssocDecl :: - TyCon -- ^ Family TyCon (not knot-tied) - -> [LTyFamDefltDecl GhcRn] -- ^ Defaults - -> TcM (Maybe (KnotTied Type, ATValidityInfo)) -- ^ Type checked RHS -tcDefaultAssocDecl _ [] - = return Nothing -- No default declaration - -tcDefaultAssocDecl _ (d1:_:_) - = failWithTc (mkTcRnUnknownMessage $ mkPlainError noHints $ - text "More than one default declaration for" - <+> ppr (tyFamInstDeclName (unLoc d1))) - -tcDefaultAssocDecl fam_tc - [L loc (TyFamInstDecl { tfid_eqn = - FamEqn { feqn_tycon = L _ tc_name - , feqn_bndrs = outer_bndrs - , feqn_pats = hs_pats - , feqn_rhs = hs_rhs_ty }})] - = -- See Note [Type-checking default assoc decls] - setSrcSpanA loc $ - tcAddFamInstCtxt (text "default type instance") tc_name $ - do { traceTc "tcDefaultAssocDecl 1" (ppr tc_name) - ; let fam_tc_name = tyConName fam_tc - vis_arity = length (tyConVisibleTyVars fam_tc) - vis_pats = numVisibleArgs hs_pats - - -- Kind of family check - ; assert (fam_tc_name == tc_name) $ - checkTc (isTypeFamilyTyCon fam_tc) (wrongKindOfFamily fam_tc) - - -- Arity check - ; checkTc (vis_pats == vis_arity) - (wrongNumberOfParmsErr vis_arity) - - -- Typecheck RHS - -- - -- You might think we should pass in some AssocInstInfo, as we're looking - -- at an associated type. But this would be wrong, because an associated - -- type default LHS can mention *different* type variables than the - -- enclosing class. So it's treated more as a freestanding beast. - ; (qtvs, pats, rhs_ty) <- tcTyFamInstEqnGuts fam_tc NotAssociated - outer_bndrs hs_pats hs_rhs_ty - - ; let fam_tvs = tyConTyVars fam_tc - ; traceTc "tcDefaultAssocDecl 2" (vcat - [ text "hs_pats" <+> ppr hs_pats - , text "hs_rhs_ty" <+> ppr hs_rhs_ty - , text "fam_tvs" <+> ppr fam_tvs - , text "qtvs" <+> ppr qtvs - -- NB: Do *not* print `pats` or rhs_ty here, as they can mention - -- knot-tied TyCons. See #18648. - ]) - ; let subst = case traverse getTyVar_maybe pats of - Just cpt_tvs -> zipTvSubst cpt_tvs (mkTyVarTys fam_tvs) - Nothing -> emptySubst - -- The Nothing case can only be reached in invalid - -- associated type family defaults. In such cases, we - -- simply create an empty substitution and let GHC fall - -- over later, in GHC.Tc.Validity.checkValidAssocTyFamDeflt. - -- See Note [Type-checking default assoc decls]. - ; pure $ Just (substTyUnchecked subst rhs_ty, ATVI (locA loc) pats) - -- We perform checks for well-formedness and validity later, in - -- GHC.Tc.Validity.checkValidAssocTyFamDeflt. - } - -{- Note [Type-checking default assoc decls] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider this default declaration for an associated type - - class C a where - type F (a :: k) b :: Type - type F (x :: j) y = Proxy x -> y - -Note that the class variable 'a' doesn't scope over the default assoc -decl, nor do the type variables `k` and `b`. Instead, the default decl is -treated more like a top-level type instance. However, we store the default rhs -(Proxy x -> y) in F's TyCon, using F's own type variables, so we need to -convert it to (Proxy a -> b). We do this in the tcDefaultAssocDecl function by -creating a substitution [j |-> k, x |-> a, b |-> y] and applying this -substitution to the RHS. - -In order to create this substitution, we must first ensure that all of -the arguments in the default instance consist of distinct type variables. -Checking for this property proves surprisingly tricky. Three potential places -where GHC could check for this property include: - -1. Before typechecking (in the parser or renamer) -2. During typechecking (in tcDefaultAssocDecl) -3. After typechecking (using GHC.Tc.Validity) - -Currently, GHC picks option (3) and implements this check using -GHC.Tc.Validity.checkValidAssocTyFamDeflt. GHC previously used options (1) and -(2), but neither option quite worked out for reasons that we will explain -shortly. - -The first thing that checkValidAssocTyFamDeflt does is check that all arguments -in an associated type family default are type variables. As a motivating -example, consider this erroneous program (inspired by #11361): - - class C a where - type F (a :: k) b :: Type - type F x b = x - -If you squint, you'll notice that the kind of `x` is actually Type. However, -we cannot substitute from [Type |-> k], so we reject this default. This also -explains why GHC no longer implements option (1) above, since figuring out that -`x`'s kind is Type would be much more difficult without the knowledge that the -typechecker provides. - -Next, checkValidAssocTyFamDeflt checks that all arguments are distinct. Here is -another offending example, this time taken from #13971: - - class C2 (a :: j) where - type F2 (a :: j) (b :: k) - type F2 (x :: z) y = SameKind x y - data SameKind :: k -> k -> Type - -All of the arguments in the default equation for `F2` are type variables, so -that passes the first check. However, if we were to build this substitution, -then both `j` and `k` map to `z`! In terms of visible kind application, it's as -if we had written `type F2 @z @z x y = SameKind @z x y`, which makes it clear -that we have duplicated a use of `z` on the LHS. Therefore, `F2`'s default is -also rejected. - -There is one more design consideration in play here: what error message should -checkValidAssocTyFamDeflt produce if one of its checks fails? Ideally, it would -be something like this: - - Illegal duplicate variable ‘z’ in: - ‘type F2 @z @z x y = ...’ - The arguments to ‘F2’ must all be distinct type variables - -This requires printing out the arguments to the associated type family. This -can be dangerous, however. Consider this example, adapted from #18648: - - class C3 a where - type F3 a - type F3 (F3 a) = a - -F3's default is illegal, since its argument is not a bare type variable. But -note that when we typecheck F3's default, the F3 type constructor is knot-tied. -Therefore, if we print the type `F3 a` in an error message, GHC will diverge! -This is the reason why GHC no longer implements option (2) above and instead -waits until /after/ typechecking has finished, at which point the typechecker -knot has been worked out. - -As one final point, one might worry that the typechecker knot could cause the -substitution that tcDefaultAssocDecl creates to diverge, but this is not the -case. Since the LHS of a valid associated type family default is always just -variables, it won't contain any tycons. Accordingly, the patterns used in the -substitution won't actually be knot-tied, even though we're in the knot. (This -is too delicate for my taste, but it works.) If we're dealing with /invalid/ -default, such as F3's above, then we simply create an empty substitution and -rely on checkValidAssocTyFamDeflt throwing an error message afterwards before -any damage is done. --} - -{- ********************************************************************* -* * - Type family declarations -* * -********************************************************************* -} - -tcFamDecl1 :: Maybe Class -> FamilyDecl GhcRn -> TcM TyCon -tcFamDecl1 parent (FamilyDecl { fdInfo = fam_info - , fdLName = tc_lname@(L _ tc_name) - , fdResultSig = L _ sig - , fdInjectivityAnn = inj }) - | DataFamily <- fam_info - = bindTyClTyVarsAndZonk tc_name $ \ tc_bndrs res_kind -> do - { traceTc "tcFamDecl1 data family:" (ppr tc_name) - ; checkFamFlag tc_name - - -- Check that the result kind is OK - -- We allow things like - -- data family T (a :: Type) :: forall k. k -> Type - -- We treat T as having arity 1, but result kind forall k. k -> Type - -- But we want to check that the result kind finishes in - -- Type or a kind-variable - -- For the latter, consider - -- data family D a :: forall k. Type -> k - -- When UnliftedNewtypes is enabled, we loosen this restriction - -- on the return kind. See Note [Implementation of UnliftedNewtypes], wrinkle (1). - -- See also Note [Datatype return kinds] - ; checkDataKindSig DataFamilySort res_kind - ; tc_rep_name <- newTyConRepName tc_name - ; let inj = Injective $ replicate (length tc_bndrs) True - tycon = mkFamilyTyCon tc_name tc_bndrs - res_kind - (resultVariableName sig) - (DataFamilyTyCon tc_rep_name) - parent inj - ; return tycon } - - | OpenTypeFamily <- fam_info - = bindTyClTyVarsAndZonk tc_name $ \ tc_bndrs res_kind -> do - { traceTc "tcFamDecl1 open type family:" (ppr tc_name) - ; checkFamFlag tc_name - ; inj' <- tcInjectivity tc_bndrs inj - ; checkResultSigFlag tc_name sig -- check after injectivity for better errors - ; let tycon = mkFamilyTyCon tc_name tc_bndrs res_kind - (resultVariableName sig) OpenSynFamilyTyCon - parent inj' - ; return tycon } - - | ClosedTypeFamily mb_eqns <- fam_info - = -- Closed type families are a little tricky, because they contain the definition - -- of both the type family and the equations for a CoAxiom. - do { traceTc "tcFamDecl1 Closed type family:" (ppr tc_name) - -- the variables in the header scope only over the injectivity - -- declaration but this is not involved here - ; (inj', tc_bndrs, res_kind) - <- bindTyClTyVarsAndZonk tc_name $ \ tc_bndrs res_kind -> - do { inj' <- tcInjectivity tc_bndrs inj - ; return (inj', tc_bndrs, res_kind) } - - ; checkFamFlag tc_name -- make sure we have -XTypeFamilies - ; checkResultSigFlag tc_name sig - - -- If Nothing, this is an abstract family in a hs-boot file; - -- but eqns might be empty in the Just case as well - ; case mb_eqns of - Nothing -> - return $ mkFamilyTyCon tc_name tc_bndrs res_kind - (resultVariableName sig) - AbstractClosedSynFamilyTyCon parent - inj' - Just eqns -> do { - - -- Process the equations, creating CoAxBranches - ; let tc_fam_tc = mkTcTyCon tc_name tc_bndrs res_kind - noTcTyConScopedTyVars - False {- this doesn't matter here -} - ClosedTypeFamilyFlavour - - ; branches <- mapAndReportM (tcTyFamInstEqn tc_fam_tc NotAssociated) eqns - -- Do not attempt to drop equations dominated by earlier - -- ones here; in the case of mutual recursion with a data - -- type, we get a knot-tying failure. Instead we check - -- for this afterwards, in GHC.Tc.Validity.checkValidCoAxiom - -- Example: tc265 - - -- Create a CoAxiom, with the correct src location. - ; co_ax_name <- newFamInstAxiomName tc_lname [] - - ; let mb_co_ax - | null eqns = Nothing -- mkBranchedCoAxiom fails on empty list - | otherwise = Just (mkBranchedCoAxiom co_ax_name fam_tc branches) - - fam_tc = mkFamilyTyCon tc_name tc_bndrs res_kind (resultVariableName sig) - (ClosedSynFamilyTyCon mb_co_ax) parent inj' - - -- We check for instance validity later, when doing validity - -- checking for the tycon. Exception: checking equations - -- overlap done by dropDominatedAxioms - ; return fam_tc } } - -#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). --- True on position --- N means that a function is injective in its Nth argument. False means it is --- not. -tcInjectivity :: [TyConBinder] -> Maybe (LInjectivityAnn GhcRn) - -> TcM Injectivity -tcInjectivity _ Nothing - = return NotInjective - - -- User provided an injectivity annotation, so for each tyvar argument we - -- check whether a type family was declared injective in that argument. We - -- return a list of Bools, where True means that corresponding type variable - -- was mentioned in lInjNames (type family is injective in that argument) and - -- False means that it was not mentioned in lInjNames (type family is not - -- injective in that type variable). We also extend injectivity information to - -- kind variables, so if a user declares: - -- - -- type family F (a :: k1) (b :: k2) = (r :: k3) | r -> a - -- - -- then we mark both `a` and `k1` as injective. - -- NB: the return kind is considered to be *input* argument to a type family. - -- Since injectivity allows to infer input arguments from the result in theory - -- we should always mark the result kind variable (`k3` in this example) as - -- injective. The reason is that result type has always an assigned kind and - -- therefore we can always infer the result kind if we know the result type. - -- But this does not seem to be useful in any way so we don't do it. (Another - -- reason is that the implementation would not be straightforward.) -tcInjectivity tcbs (Just (L loc (InjectivityAnn _ _ lInjNames))) - = setSrcSpanA loc $ - do { let tvs = binderVars tcbs - ; dflags <- getDynFlags - ; checkTc (xopt LangExt.TypeFamilyDependencies dflags) - (mkTcRnUnknownMessage $ mkPlainError noHints $ - text "Illegal injectivity annotation" $$ - text "Use TypeFamilyDependencies to allow this") - ; inj_tvs <- mapM (tcLookupTyVar . unLoc) lInjNames - ; inj_tvs <- zonkTcTyVarsToTcTyVars inj_tvs -- zonk the kinds - ; let inj_ktvs = filterVarSet isTyVar $ -- no injective coercion vars - closeOverKinds (mkVarSet inj_tvs) - ; let inj_bools = map (`elemVarSet` inj_ktvs) tvs - ; traceTc "tcInjectivity" (vcat [ ppr tvs, ppr lInjNames, ppr inj_tvs - , ppr inj_ktvs, ppr inj_bools ]) - ; return $ Injective inj_bools } - -tcTySynRhs :: RolesInfo -> Name - -> LHsType GhcRn -> TcM TyCon -tcTySynRhs roles_info tc_name hs_ty - = bindTyClTyVars tc_name $ \ tc_bndrs res_kind -> - do { env <- getLclEnv - ; traceTc "tc-syn" (ppr tc_name $$ ppr (tcl_env env)) - ; rhs_ty <- pushLevelAndSolveEqualities skol_info tc_bndrs $ - tcCheckLHsType hs_ty (TheKind res_kind) - - -- See Note [Error on unconstrained meta-variables] in GHC.Tc.Utils.TcMType - -- Example: (typecheck/should_fail/T17567) - -- type T = forall a. Proxy a - -- The kind of `a` is unconstrained. - ; dvs <- candidateQTyVarsOfType rhs_ty - ; let mk_doc tidy_env = do { (tidy_env2, rhs_ty) <- zonkTidyTcType tidy_env rhs_ty - ; return ( tidy_env2 - , sep [ text "the type synonym right-hand side:" - , ppr rhs_ty ] ) } - ; doNotQuantifyTyVars dvs mk_doc - - ; ze <- mkEmptyZonkEnv NoFlexi - ; (ze, bndrs) <- zonkTyVarBindersX ze tc_bndrs - ; rhs_ty <- zonkTcTypeToTypeX ze rhs_ty - ; let roles = roles_info tc_name - ; return (buildSynTyCon tc_name bndrs res_kind roles rhs_ty) } - where - skol_info = TyConSkol TypeSynonymFlavour tc_name - -tcDataDefn :: SDoc -> 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 - (HsDataDefn { dd_cType = cType - , dd_ctxt = ctxt - , dd_kindSig = mb_ksig -- Already in tc's kind - -- via inferInitialKinds - , dd_cons = cons - , dd_derivs = derivs }) - = bindTyClTyVars tc_name $ \ tc_bndrs res_kind -> - -- The TyCon tyvars must scope over - -- - the stupid theta (dd_ctxt) - -- - for H98 constructors only, the ConDecl - -- But it does no harm to bring them into scope - -- over GADT ConDecls as well; and it's awkward not to - do { gadt_syntax <- dataDeclChecks tc_name ctxt cons - - ; tcg_env <- getGblEnv - ; let hsc_src = tcg_src tcg_env - ; unless (mk_permissive_kind hsc_src cons) $ - checkDataKindSig (DataDeclSort (dataDefnConsNewOrData cons)) res_kind - - ; stupid_tc_theta <- pushLevelAndSolveEqualities skol_info tc_bndrs $ - tcHsContext ctxt - - -- See Note [Error on unconstrained meta-variables] in GHC.Tc.Utils.TcMType - -- Example: (typecheck/should_fail/T17567StupidTheta) - -- data (forall a. a b ~ a c) => T b c - -- The kind of 'a' is unconstrained. - ; dvs <- candidateQTyVarsOfTypes stupid_tc_theta - ; let mk_doc tidy_env - = do { (tidy_env2, theta) <- zonkTidyTcTypes tidy_env stupid_tc_theta - ; return ( tidy_env2 - , sep [ text "the datatype context:" - , pprTheta theta ] ) } - ; doNotQuantifyTyVars dvs mk_doc - - -- Check that we don't use kind signatures without the extension - ; kind_signatures <- xoptM LangExt.KindSignatures - ; when (isJust mb_ksig) $ - checkTc (kind_signatures) (badSigTyDecl tc_name) - - ; ze <- mkEmptyZonkEnv NoFlexi - ; (ze, bndrs) <- zonkTyVarBindersX ze tc_bndrs - ; stupid_theta <- zonkTcTypesToTypesX ze stupid_tc_theta - ; res_kind <- zonkTcTypeToTypeX ze res_kind - - ; tycon <- fixM $ \ rec_tycon -> do - { data_cons <- tcConDecls DDataType rec_tycon tc_bndrs res_kind cons - ; tc_rhs <- mk_tc_rhs hsc_src rec_tycon data_cons - ; tc_rep_nm <- newTyConRepName tc_name - - ; return (mkAlgTyCon tc_name - bndrs - res_kind - (roles_info tc_name) - (fmap unLoc cType) - stupid_theta tc_rhs - (VanillaAlgTyCon tc_rep_nm) - gadt_syntax) - } - - ; let scoped_tvs = mkTyVarNamePairs (binderVars tc_bndrs) - -- scoped_tvs: still the skolem TcTyVars - deriv_info = DerivInfo { di_rep_tc = tycon - , di_scoped_tvs = scoped_tvs - , di_clauses = derivs - , di_ctxt = err_ctxt } - ; traceTc "tcDataDefn" (ppr tc_name $$ ppr tc_bndrs) - ; return (tycon, [deriv_info]) } - where - skol_info = TyConSkol flav tc_name - flav = newOrDataToFlavour (dataDefnConsNewOrData cons) - - -- Abstract data types in hsig files can have arbitrary kinds, - -- because they may be implemented by type synonyms - -- (which themselves can have arbitrary kinds, not just *). See #13955. - -- - -- Note that this is only a property that data type declarations possess, - -- so one could not have, say, a data family instance in an hsig file that - -- has kind `Bool`. Therefore, this check need only occur in the code that - -- typechecks data type declarations. - mk_permissive_kind HsigFile (DataTypeCons _ []) = True - mk_permissive_kind _ _ = False - - -- In an hs-boot or a signature file, - -- a 'data' declaration with no constructors - -- indicates a nominally distinct abstract data type. - mk_tc_rhs (isHsBootOrSig -> True) _ (DataTypeCons _ []) - = return AbstractTyCon - - mk_tc_rhs _ tycon data_cons = case data_cons of - DataTypeCons is_type_data data_cons -> return $ - mkLevPolyDataTyConRhs - (isFixedRuntimeRepKind (tyConResKind tycon)) - is_type_data - data_cons - NewTypeCon data_con -> mkNewTyConRhs tc_name tycon data_con - -------------------------- -kcTyFamInstEqn :: TcTyCon -> LTyFamInstEqn GhcRn -> TcM () --- Used for the equations of a closed type family only --- Not used for data/type instances -kcTyFamInstEqn tc_fam_tc - (L loc (FamEqn { feqn_tycon = L _ eqn_tc_name - , feqn_bndrs = outer_bndrs - , feqn_pats = hs_pats - , feqn_rhs = hs_rhs_ty })) - = setSrcSpanA loc $ - do { traceTc "kcTyFamInstEqn" (vcat - [ text "tc_name =" <+> ppr eqn_tc_name - , text "fam_tc =" <+> ppr tc_fam_tc <+> dcolon <+> ppr (tyConKind tc_fam_tc) - , text "feqn_bndrs =" <+> ppr outer_bndrs - , text "feqn_pats =" <+> ppr hs_pats ]) - - ; checkTyFamInstEqn tc_fam_tc eqn_tc_name hs_pats - - ; discardResult $ - bindOuterFamEqnTKBndrs_Q_Tv outer_bndrs $ - do { (_fam_app, res_kind) <- tcFamTyPats tc_fam_tc hs_pats - ; tcCheckLHsType hs_rhs_ty (TheKind res_kind) } - -- Why "_Tv" here? Consider (#14066) - -- type family Bar x y where - -- Bar (x :: a) (y :: b) = Int - -- Bar (x :: c) (y :: d) = Bool - -- During kind-checking, a,b,c,d should be TyVarTvs and unify appropriately - } - --------------------------- -tcTyFamInstEqn :: TcTyCon -> AssocInstInfo -> LTyFamInstEqn GhcRn - -> TcM (KnotTied CoAxBranch) --- Needs to be here, not in GHC.Tc.TyCl.Instance, because closed families --- (typechecked here) have TyFamInstEqns - -tcTyFamInstEqn fam_tc mb_clsinfo - (L loc (FamEqn { feqn_tycon = L _ eqn_tc_name - , feqn_bndrs = outer_bndrs - , feqn_pats = hs_pats - , feqn_rhs = hs_rhs_ty })) - = setSrcSpanA loc $ - do { traceTc "tcTyFamInstEqn" $ - vcat [ ppr loc, ppr fam_tc <+> ppr hs_pats - , text "fam tc bndrs" <+> pprTyVars (tyConTyVars fam_tc) - , case mb_clsinfo of - NotAssociated {} -> empty - InClsInst { ai_class = cls } -> text "class" <+> ppr cls <+> pprTyVars (classTyVars cls) ] - - ; checkTyFamInstEqn fam_tc eqn_tc_name hs_pats - - ; (qtvs, pats, rhs_ty) <- tcTyFamInstEqnGuts fam_tc mb_clsinfo - outer_bndrs hs_pats hs_rhs_ty - -- Don't print results they may be knot-tied - -- (tcFamInstEqnGuts zonks to Type) - ; return (mkCoAxBranch qtvs [] [] pats rhs_ty - (map (const Nominal) qtvs) - (locA loc)) } - -checkTyFamInstEqn :: TcTyCon -> Name -> [HsArg tm ty] -> TcM () -checkTyFamInstEqn tc_fam_tc eqn_tc_name hs_pats = - do { -- Ensure that each equation's type constructor is for the right - -- type family. E.g. barf on - -- type family F a where { G Int = Bool } - let tc_fam_tc_name = getName tc_fam_tc - ; checkTc (tc_fam_tc_name == eqn_tc_name) $ - wrongTyFamName tc_fam_tc_name eqn_tc_name - - -- Check the arity of visible arguments - -- If we wait until validity checking, we'll get kind errors - -- below when an arity error will be much easier to understand. - ; let vis_arity = length (tyConVisibleTyVars tc_fam_tc) - vis_pats = numVisibleArgs hs_pats - ; checkTc (vis_pats == vis_arity) $ - wrongNumberOfParmsErr vis_arity - } - -{- Note [Instantiating a family tycon] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -It's possible that kind-checking the result of a family tycon applied to -its patterns will instantiate the tycon further. For example, we might -have - - type family F :: k where - F = Int - F = Maybe - -After checking (F :: forall k. k) (with no visible patterns), we still need -to instantiate the k. With data family instances, this problem can be even -more intricate, due to Note [Arity of data families] in GHC.Core.FamInstEnv. See -indexed-types/should_compile/T12369 for an example. - -So, the kind-checker must return the new skolems and args (that is, Type -or (Type -> Type) for the equations above) and the instantiated kind. - -Note [Generalising in tcTyFamInstEqnGuts] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose we have something like - type instance forall (a::k) b. F (Proxy t1) _ = rhs - -Then imp_vars = [k], exp_bndrs = [a::k, b] - -We want to quantify over all the free vars of the LHS including - * any invisible kind variables arising from instantiating tycons, - such as Proxy - * wildcards such as '_' above - -The wildcards are particularly awkward: they may need to be quantified - - before the explicit variables k,a,b - - after them - - or even interleaved with them - c.f. Note [Naughty quantification candidates] in GHC.Tc.Utils.TcMType - -So, we use bindOuterFamEqnTKBndrs (which does not create an implication for -the telescope), and generalise over /all/ the variables in the LHS, -without treating the explicitly-quantified ones specially. Wrinkles: - - - When generalising, include the explicit user-specified forall'd - variables, so that we get an error from Validity.checkFamPatBinders - if a forall'd variable is not bound on the LHS - - - We still want to complain about a bad telescope among the user-specified - variables. So in checkFamTelescope we emit an implication constraint - quantifying only over them, purely so that we get a good telescope error. - - - Note that, unlike a type signature like - f :: forall (a::k). blah - we do /not/ care about the Inferred/Specified designation or order for - the final quantified tyvars. Type-family instances are not invoked - directly in Haskell source code, so visible type application etc plays - no role. - -See also Note [Re-quantify type variables in rules] in -GHC.Tc.Gen.Rule, which explains a /very/ similar design when -generalising over the type of a rewrite rule. - --} - --------------------------- -tcTyFamInstEqnGuts :: TyCon -> AssocInstInfo - -> HsOuterFamEqnTyVarBndrs GhcRn -- Implicit and explicit binders - -> HsTyPats GhcRn -- Patterns - -> LHsType GhcRn -- RHS - -> TcM ([TyVar], [TcType], TcType) -- (tyvars, pats, rhs) --- Used only for type families, not data families -tcTyFamInstEqnGuts fam_tc mb_clsinfo outer_hs_bndrs hs_pats hs_rhs_ty - = do { traceTc "tcTyFamInstEqnGuts {" (ppr fam_tc $$ ppr outer_hs_bndrs $$ ppr hs_pats) - - -- By now, for type families (but not data families) we should - -- have checked that the number of patterns matches tyConArity - ; skol_info <- mkSkolemInfo FamInstSkol - - -- This code is closely related to the code - -- in GHC.Tc.Gen.HsType.kcCheckDeclHeader_cusk - ; (tclvl, wanted, (outer_bndrs, (lhs_ty, rhs_ty))) - <- pushLevelAndSolveEqualitiesX "tcTyFamInstEqnGuts" $ - bindOuterFamEqnTKBndrs skol_info outer_hs_bndrs $ - do { (lhs_ty, rhs_kind) <- tcFamTyPats fam_tc hs_pats - -- 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) - ; return (lhs_ty, rhs_ty) } - - ; outer_bndrs <- scopedSortOuter outer_bndrs - ; let outer_tvs = outerTyVars outer_bndrs - ; checkFamTelescope tclvl outer_hs_bndrs outer_tvs - - ; traceTc "tcTyFamInstEqnGuts 1" (pprTyVars outer_tvs $$ ppr skol_info) - - -- This code (and the stuff immediately above) is very similar - -- to that in tcDataFamInstHeader. Maybe we should abstract the - -- common code; but for the moment I concluded that it's - -- clearer to duplicate it. Still, if you fix a bug here, - -- check there too! - - -- See Note [Generalising in tcTyFamInstEqnGuts] - ; dvs <- candidateQTyVarsWithBinders outer_tvs lhs_ty - ; qtvs <- quantifyTyVars skol_info TryNotToDefaultNonStandardTyVars dvs - ; let final_tvs = scopedSort (qtvs ++ outer_tvs) - -- This scopedSort is important: the qtvs may be /interleaved/ with - -- the outer_tvs. See Note [Generalising in tcTyFamInstEqnGuts] - ; reportUnsolvedEqualities skol_info final_tvs tclvl wanted - - ; traceTc "tcTyFamInstEqnGuts 2" $ - vcat [ ppr fam_tc - , text "lhs_ty:" <+> ppr lhs_ty - , text "final_tvs:" <+> pprTyVars final_tvs ] - - -- See Note [Error on unconstrained meta-variables] in GHC.Tc.Utils.TcMType - -- Example: typecheck/should_fail/T17301 - ; dvs_rhs <- candidateQTyVarsOfType rhs_ty - ; let mk_doc tidy_env - = do { (tidy_env2, rhs_ty) <- zonkTidyTcType tidy_env rhs_ty - ; return ( tidy_env2 - , sep [ text "type family equation right-hand side:" - , ppr rhs_ty ] ) } - ; doNotQuantifyTyVars dvs_rhs mk_doc - - ; ze <- mkEmptyZonkEnv NoFlexi - ; (ze, final_tvs) <- zonkTyBndrsX ze final_tvs - ; lhs_ty <- zonkTcTypeToTypeX ze lhs_ty - ; rhs_ty <- zonkTcTypeToTypeX ze rhs_ty - - ; let pats = unravelFamInstPats lhs_ty - -- Note that we do this after solveEqualities - -- so that any strange coercions inside lhs_ty - -- have been solved before we attempt to unravel it - - ; traceTc "tcTyFamInstEqnGuts }" (vcat [ ppr fam_tc, pprTyVars final_tvs ]) - -- Don't try to print 'pats' here, because lhs_ty involves - -- a knot-tied type constructor, so we get a black hole - - ; return (final_tvs, pats, rhs_ty) } - -checkFamTelescope :: TcLevel - -> HsOuterFamEqnTyVarBndrs GhcRn - -> [TcTyVar] -> TcM () --- Emit a constraint (forall a b c. ), so that --- we will do telescope-checking on a,b,c --- See Note [Generalising in tcTyFamInstEqnGuts] -checkFamTelescope tclvl hs_outer_bndrs outer_tvs - | HsOuterExplicit { hso_bndrs = bndrs } <- hs_outer_bndrs - , (b_first : _) <- bndrs - , let b_last = last bndrs - = do { skol_info <- mkSkolemInfo (ForAllSkol $ HsTyVarBndrsRn (map unLoc bndrs)) - ; setSrcSpan (combineSrcSpans (getLocA b_first) (getLocA b_last)) $ do - emitResidualTvConstraint skol_info outer_tvs tclvl emptyWC } - | otherwise - = return () - ------------------ -unravelFamInstPats :: TcType -> [TcType] --- Decompose fam_app to get the argument patterns --- --- We expect fam_app to look like (F t1 .. tn) --- tcFamTyPats is capable of returning ((F ty1 |> co) ty2), --- but that can't happen here because we already checked the --- arity of F matches the number of pattern -unravelFamInstPats fam_app - = case tcSplitTyConApp_maybe fam_app of - Just (_, pats) -> pats - Nothing -> panic "unravelFamInstPats: Ill-typed LHS of family instance" - -- 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 - -- for an example of this happening. - -addConsistencyConstraints :: AssocInstInfo -> TcType -> TcM () --- In the corresponding positions of the class and type-family, --- ensure the family argument is the same as the class argument --- E.g class C a b c d where --- F c x y a :: Type --- Here the first arg of F should be the same as the third of C --- and the fourth arg of F should be the same as the first of C -addConsistencyConstraints mb_clsinfo fam_app - | InClsInst { ai_inst_env = inst_env } <- mb_clsinfo - , Just (fam_tc, pats) <- tcSplitTyConApp_maybe fam_app - = do { let eqs = [ (cls_ty, pat) - | (fam_tc_tv, pat) <- tyConTyVars fam_tc `zip` pats - , Just cls_ty <- [lookupVarEnv inst_env fam_tc_tv] ] - ; traceTc "addConsistencyConstraints" (ppr eqs) - ; emitWantedEqs AssocFamPatOrigin eqs } - -- Improve inference; these equalities will not produce errors. - -- See Note [Constraints to ignore] in GHC.Tc.Errors - -- Any mis-match is reports by checkConsistentFamInst - | otherwise - = return () - -{- Note [Constraints in patterns] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -NB: This isn't the whole story. See comment in tcFamTyPats. - -At first glance, it seems there is a complicated story to tell in tcFamTyPats -around constraint solving. After all, type family patterns can now do -GADT pattern-matching, which is jolly complicated. But, there's a key fact -which makes this all simple: everything is at top level! There cannot -be untouchable type variables. There can't be weird interaction between -case branches. There can't be global skolems. - -This means that the semantics of type-level GADT matching is a little -different than term level. If we have - - data G a where - MkGBool :: G Bool - -And then - - type family F (a :: G k) :: k - type instance F MkGBool = True - -we get - - axF : F Bool (MkGBool ) ~ True - -Simple! No casting on the RHS, because we can affect the kind parameter -to F. - -If we ever introduce local type families, this all gets a lot more -complicated, and will end up looking awfully like term-level GADT -pattern-matching. - - -** The new story ** - -Here is really what we want: - -The matcher really can't deal with covars in arbitrary spots in coercions. -But it can deal with covars that are arguments to GADT data constructors. -So we somehow want to allow covars only in precisely those spots, then use -them as givens when checking the RHS. TODO (RAE): Implement plan. - -Note [Quantified kind variables of a family pattern] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider type family KindFam (p :: k1) (q :: k1) - data T :: Maybe k1 -> k2 -> * - type instance KindFam (a :: Maybe k) b = T a b -> Int -The HsBSig for the family patterns will be ([k], [a]) - -Then in the family instance we want to - * Bring into scope [ "k" -> k:*, "a" -> a:k ] - * Kind-check the RHS - * Quantify the type instance over k and k', as well as a,b, thus - type instance [k, k', a:Maybe k, b:k'] - KindFam (Maybe k) k' a b = T k k' a b -> Int - -Notice that in the third step we quantify over all the visibly-mentioned -type variables (a,b), but also over the implicitly mentioned kind variables -(k, k'). In this case one is bound explicitly but often there will be -none. The role of the kind signature (a :: Maybe k) is to add a constraint -that 'a' must have that kind, and to bring 'k' into scope. - - - -************************************************************************ -* * - Data types -* * -************************************************************************ --} - -dataDeclChecks :: Name - -> Maybe (LHsContext GhcRn) -> DataDefnCons (LConDecl GhcRn) - -> TcM Bool -dataDeclChecks tc_name mctxt cons - = do { let stupid_theta = fromMaybeContext mctxt - -- Check that we don't use GADT syntax in H98 world - ; gadtSyntax_ok <- xoptM LangExt.GADTSyntax - ; let gadt_syntax = anyLConIsGadt cons - ; checkTc (gadtSyntax_ok || not gadt_syntax) (badGadtDecl tc_name) - - -- Check that the stupid theta is empty for a GADT-style declaration. - -- See Note [The stupid context] in GHC.Core.DataCon. - ; checkTc (null stupid_theta || not gadt_syntax) (badStupidTheta tc_name) - - -- Check that there's at least one condecl, - -- or else we're reading an hs-boot file, or -XEmptyDataDecls - ; empty_data_decls <- xoptM LangExt.EmptyDataDecls - ; is_boot <- tcIsHsBootOrSig -- Are we compiling an hs-boot file? - ; checkTc (not (null cons) || empty_data_decls || is_boot) - (emptyConDeclsErr tc_name) - ; return gadt_syntax } - - ------------------------------------ -data DataDeclInfo - = DDataType -- data T a b = T1 a | T2 b - | DDataInstance -- data instance D [a] = D1 a | D2 - Type -- The header D [a] - -mkDDHeaderTy :: DataDeclInfo -> TyCon -> [TyConBinder] -> Type -mkDDHeaderTy dd_info rep_tycon tc_bndrs - = case dd_info of - DDataType -> mkTyConApp rep_tycon $ - mkTyVarTys (binderVars tc_bndrs) - DDataInstance header_ty -> header_ty - --- We use `concatMapDataDefnConsTcM` here, since the following is illegal: --- @newtype T a where T1, T2 :: a -> T a@ --- It would be represented as a single 'ConDeclGadt' with multiple names, which is valid for 'data', but not 'newtype'. --- So when 'tcConDecl' expands the 'ConDecl' per each name it has, if we are type-checking a 'newtype' declaration, we --- must fail if it returns more than one. -tcConDecls :: DataDeclInfo - -> KnotTied TyCon -- Representation TyCon - -> [TcTyConBinder] -- Binders of representation TyCon - -> TcKind -- Result kind - -> 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) - -- mkTyConTagMap: it's important that we pay for tag allocation here, - -- once per TyCon. See Note [Constructor tag allocation], fixes #14657 - --- 'concatMap' for 'DataDefnCons', but fail if the given function returns multiple values and the argument is a 'NewTypeCon'. -concatMapDataDefnConsTcM :: Name -> (NewOrData -> a -> TcM (NonEmpty b)) -> DataDefnCons a -> TcM (DataDefnCons b) -concatMapDataDefnConsTcM name f = \ case - NewTypeCon a -> f NewType a >>= \ case - b:|[] -> pure (NewTypeCon b) - bs -> failWithTc $ newtypeConError name (length bs) - DataTypeCons is_type_data as -> DataTypeCons is_type_data <$> concatMapM (fmap toList . f DataType) as - -tcConDecl :: NewOrData - -> DataDeclInfo - -> KnotTied TyCon -- Representation tycon. Knot-tied! - -> [TcTyConBinder] -- Binders of representation TyCon - -> TcKind -- Result kind - -> NameEnv ConTag - -> ConDecl GhcRn - -> TcM (NonEmpty DataCon) - -tcConDecl new_or_data dd_info rep_tycon tc_bndrs res_kind tag_map - (ConDeclH98 { con_name = lname@(L _ name) - , con_ex_tvs = explicit_tkv_nms - , con_mb_cxt = hs_ctxt - , con_args = hs_args }) - = addErrCtxt (dataConCtxt (NE.singleton lname)) $ - do { -- NB: the tyvars from the declaration header are in scope - - -- Get hold of the existential type variables - -- e.g. data T a = forall k (b::k) f. MkT a (f b) - -- Here tc_bndrs = {a} - -- hs_qvars = HsQTvs { hsq_implicit = {k} - -- , hsq_explicit = {f,b} } - - ; traceTc "tcConDecl 1" (vcat [ ppr name - , text "explicit_tkv_nms" <+> ppr explicit_tkv_nms - , text "tc_bndrs" <+> ppr tc_bndrs ]) - ; skol_info <- mkSkolemInfo (ForAllSkol (HsTyVarBndrsRn (unLoc <$> explicit_tkv_nms))) - - ; (tclvl, wanted, (exp_tvbndrs, (ctxt, arg_tys, field_lbls, stricts))) - <- pushLevelAndSolveEqualitiesX "tcConDecl:H98" $ - tcExplicitTKBndrs skol_info explicit_tkv_nms $ - do { ctxt <- tcHsContext hs_ctxt - ; let exp_kind = getArgExpKind new_or_data res_kind - ; btys <- tcConH98Args exp_kind hs_args - ; field_lbls <- lookupConstructorFields name - ; let (arg_tys, stricts) = unzip btys - ; return (ctxt, arg_tys, field_lbls, stricts) - } - - - ; let tc_tvs = binderVars tc_bndrs - fake_ty = mkSpecForAllTys tc_tvs $ - mkInvisForAllTys exp_tvbndrs $ - tcMkPhiTy ctxt $ - tcMkScaledFunTys arg_tys $ - unitTy - -- That type is a lie, of course. (It shouldn't end in ()!) - -- And we could construct a proper result type from the info - -- at hand. But the result would mention only the univ_tvs, - -- and so it just creates more work to do it right. Really, - -- we're only doing this to find the right kind variables to - -- quantify over, and this type is fine for that purpose. - - -- exp_tvbndrs have explicit, user-written binding sites - -- the kvs below are those kind variables entirely unmentioned by the user - -- and discovered only by generalization - - ; kvs <- kindGeneralizeAll skol_info fake_ty - - ; let all_skol_tvs = tc_tvs ++ kvs - ; reportUnsolvedEqualities skol_info all_skol_tvs tclvl wanted - -- The skol_info claims that all the variables are bound - -- by the data constructor decl, whereas actually the - -- univ_tvs are bound by the data type decl itself. It - -- would be better to have a doubly-nested implication. - -- But that just doesn't seem worth it. - -- See test dependent/should_fail/T13780a - - -- Zonk to Types - ; ze <- mkEmptyZonkEnv NoFlexi - ; (ze, tc_bndrs) <- zonkTyVarBindersX ze tc_bndrs - ; (ze, kvs) <- zonkTyBndrsX ze kvs - ; (ze, exp_tvbndrs) <- zonkTyVarBindersX ze exp_tvbndrs - ; arg_tys <- zonkScaledTcTypesToTypesX ze arg_tys - ; ctxt <- zonkTcTypesToTypesX ze ctxt - - -- Can't print univ_tvs, arg_tys etc, because we are inside the knot here - ; traceTc "tcConDecl 2" (ppr name $$ ppr field_lbls) - ; let univ_tvbs = tyConInvisTVBinders tc_bndrs - ex_tvbs = mkTyVarBinders InferredSpec kvs ++ exp_tvbndrs - ex_tvs = binderVars ex_tvbs - -- 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_res_ty = mkDDHeaderTy dd_info rep_tycon tc_bndrs - - ; traceTc "tcConDecl 2" (ppr name) - ; is_infix <- tcConIsInfixH98 name hs_args - ; rep_nm <- newTyConRepName name - ; fam_envs <- tcGetFamInstEnvs - ; dflags <- getDynFlags - ; let bang_opts = SrcBangOpts (initBangOpts dflags) - ; dc <- buildDataCon fam_envs bang_opts name is_infix rep_nm - stricts field_lbls - tc_tvs ex_tvs user_tvbs - [{- no eq_preds -}] ctxt arg_tys - user_res_ty rep_tycon tag_map - -- NB: we put data_tc, the type constructor gotten from the - -- constructor type signature into the data constructor; - -- that way checkValidDataCon can complain if it's wrong. - - ; return (NE.singleton dc) } - -tcConDecl new_or_data dd_info rep_tycon tc_bndrs _res_kind tag_map - -- 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_mb_cxt = cxt, con_g_args = hs_args - , con_res_ty = hs_res_ty }) - = addErrCtxt (dataConCtxt 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))) - <- pushLevelAndSolveEqualitiesX "tcConDecl:GADT" $ - tcOuterTKBndrs skol_info outer_hs_bndrs $ - do { ctxt <- tcHsContext cxt - ; (res_ty, res_kind) <- tcInferLHsTypeKind hs_res_ty - -- See Note [GADT return kinds] - - -- For data instances (only), ensure that the return type, - -- res_ty, is a substitution instance of the header. - -- See Note [GADT return types] - ; case dd_info of - DDataType -> return () - DDataInstance hdr_ty -> - do { (subst, _meta_tvs) <- newMetaTyVars (binderVars tc_bndrs) - ; let head_shape = substTy subst hdr_ty - ; discardResult $ - popErrCtxt $ -- Drop dataConCtxt - addErrCtxt (dataConResCtxt names) $ - unifyType Nothing res_ty head_shape } - - -- See Note [Datatype return kinds] - ; let exp_kind = getArgExpKind new_or_data res_kind - ; btys <- tcConGADTArgs exp_kind hs_args - - ; let (arg_tys, stricts) = unzip btys - ; field_lbls <- lookupConstructorFields 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 $ - 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 - - -- Zonk to Types - ; ze <- mkEmptyZonkEnv NoFlexi - ; (ze, tvbndrs) <- zonkTyVarBindersX ze tvbndrs - ; arg_tys <- zonkScaledTcTypesToTypesX ze arg_tys - ; ctxt <- zonkTcTypesToTypesX ze ctxt - ; res_ty <- zonkTcTypeToTypeX ze res_ty - - ; let res_tmpl = mkDDHeaderTy dd_info rep_tycon tc_bndrs - (univ_tvs, ex_tvs, tvbndrs', eq_preds, arg_subst) - = rejigConRes tc_bndrs res_tmpl tvbndrs res_ty - -- See Note [rejigConRes] - - ctxt' = substTys arg_subst ctxt - arg_tys' = substScaledTys arg_subst arg_tys - res_ty' = substTy arg_subst res_ty - - -- Can't print univ_tvs, arg_tys etc, because we are inside the knot here - ; traceTc "tcConDecl 2" (ppr names $$ ppr field_lbls) - ; fam_envs <- tcGetFamInstEnvs - ; dflags <- getDynFlags - ; let - buildOneDataCon (L _ name) = do - { is_infix <- tcConIsInfixGADT name hs_args - ; rep_nm <- newTyConRepName name - - ; let bang_opts = SrcBangOpts (initBangOpts dflags) - ; buildDataCon fam_envs bang_opts name is_infix - rep_nm stricts field_lbls - univ_tvs ex_tvs tvbndrs' eq_preds - ctxt' arg_tys' res_ty' rep_tycon tag_map - -- NB: we put data_tc, the type constructor gotten from the - -- constructor type signature into the data constructor; - -- that way checkValidDataCon can complain if it's wrong. - } - ; mapM buildOneDataCon names } - -{- Note [GADT return types] -~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - data family T :: forall k. k -> Type - data instance T (a :: Type) where - MkT :: forall b. T b - -What kind does `b` have in the signature for MkT? -Since the return type must be an instance of the type in the header, -we must have (b :: Type), but you can't tell that by looking only at -the type of the data constructor; you have to look at the header too. -If you wrote it out fully, it'd look like - data instance T @Type (a :: Type) where - MkT :: forall (b::Type). T @Type b - -We could reject the program, and expect the user to add kind -annotations to `MkT` to restrict the signature. But an easy and -helpful alternative is this: simply instantiate the type from the -header with fresh unification variables, and unify with the return -type of `MkT`. That will force `b` to have kind `Type`. See #8707 -and #14111. - -Wrikles -* At first sight it looks as though this would completely subsume the - return-type check in checkValidDataCon. But it does not. Suppose we - have - data instance T [a] where - MkT :: T (F (Maybe a)) - - where F is a type function. Then maybe (F (Maybe a)) evaluates to - [a], so unifyType will succeed. But we discard the coercion - returned by unifyType; and we really don't want to accept this - program. The check in checkValidDataCon will, however, reject it. - TL;DR: keep the check in checkValidDataCon. - -* Consider a data type, rather than a data instance, declaration - data S a where { MkS :: b -> S [b] } - In tcConDecl, S is knot-tied, so we don't want to unify (S alpha) - with (S [b]). To put it another way, unifyType should never see a - TcTycon. Simple solution: do *not* do the extra unifyType for - data types (DDataType) only for data instances (DDataInstance); in - the latter the family constructor is not knot-tied so there is no - problem. - -* Consider this (from an earlier form of GHC itself): - - data Pass = Parsed | ... - data GhcPass (c :: Pass) where - GhcPs :: GhcPs - ... - type GhcPs = GhcPass 'Parsed - - Now GhcPs and GhcPass are mutually recursive. If we did unifyType - for datatypes like GhcPass, we would not be able to expand the type - synonym (it'd still be a TcTyCon). So again, we don't do unifyType - for data types; we leave it to checkValidDataCon. - - We /do/ perform the unifyType for data /instances/, but a data - instance doesn't declare a new (user-visible) type constructor, so - there is no mutual recursion with type synonyms to worry about. - All good. - - TL;DR we do support mutual recursion between type synonyms and - data type/instance declarations, as above. - -Note [GADT return kinds] -~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - type family Star where Star = Type - data T :: Type where - MkT :: Int -> T - -If, for some stupid reason, tcInferLHsTypeKind on the return type of -MkT returned (T |> ax, Star), then the return-type check in -checkValidDataCon would reject the decl (although of course there is -nothing wrong with it). We are implicitly requiring tha -tcInferLHsTypeKind doesn't any gratuitous top-level casts. --} - --- | 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 NewType res_ki = TheKind res_ki -getArgExpKind DataType _ = OpenKind - -tcConIsInfixH98 :: Name - -> HsConDeclH98Details GhcRn - -> TcM Bool -tcConIsInfixH98 _ details - = case details of - InfixCon{} -> return True - RecCon{} -> return False - PrefixCon{} -> return False - -tcConIsInfixGADT :: Name - -> HsConDeclGADTDetails GhcRn - -> TcM Bool -tcConIsInfixGADT con details - = case details of - RecConGADT{} -> return False - PrefixConGADT arg_tys -- See Note [Infix GADT constructors] - | isSymOcc (getOccName con) - , [_ty1,_ty2] <- map hsScaledThing arg_tys - -> do { fix_env <- getFixityEnv - ; return (con `elemNameEnv` fix_env) } - | otherwise -> return False - -tcConH98Args :: ContextKind -- 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 (InfixCon bty1 bty2) - = do { bty1' <- tcConArg exp_kind bty1 - ; bty2' <- tcConArg exp_kind bty2 - ; return [bty1', bty2'] } -tcConH98Args exp_kind (RecCon fields) - = tcRecConDeclFields exp_kind fields - -tcConGADTArgs :: ContextKind -- 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 - -tcConArg :: ContextKind -- 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) - = do { traceTc "tcConArg 1" (ppr bty) - ; arg_ty <- tcCheckLHsType (getBangType bty) exp_kind - ; w' <- tcDataConMult w - ; traceTc "tcConArg 2" (ppr bty) - ; return (Scaled w' arg_ty, getBangStrictness bty) } - -tcRecConDeclFields :: ContextKind - -> LocatedL [LConDeclField GhcRn] - -> TcM [(Scaled TcType, HsSrcBang)] -tcRecConDeclFields exp_kind fields - = mapM (tcConArg exp_kind) 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))) - (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 - -{- -Note [Function arrows in GADT constructors] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In the absence of -XLinearTypes, we always interpret function arrows -in GADT constructor types as linear, even if the user wrote an -unrestricted arrow. See the "Without -XLinearTypes" section of the -linear types GHC proposal (#111). We opt to do this in the -typechecker, and not in an earlier pass, to ensure that the AST -matches what the user wrote (#18791). - -Note [Infix GADT constructors] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We do not currently have syntax to declare an infix constructor in GADT syntax, -but it makes a (small) difference to the Show instance. So as a slightly -ad-hoc solution, we regard a GADT data constructor as infix if - a) it is an operator symbol - b) it has two arguments - c) there is a fixity declaration for it -For example: - infix 6 (:--:) - data T a where - (:--:) :: t1 -> t2 -> T Int - - -Note [rejigConRes] -~~~~~~~~~~~~~~~~~~ -There is a delicacy around checking the return types of a datacon. The -central problem is dealing with a declaration like - - data T a where - MkT :: T a -> Q a - -Note that the return type of MkT is totally bogus. When creating the T -tycon, we also need to create the MkT datacon, which must have a "rejigged" -return type. That is, the MkT datacon's type must be transformed to have -a uniform return type with explicit coercions for GADT-like type parameters. -This rejigging is what rejigConRes does. The problem is, though, that checking -that the return type is appropriate is much easier when done over *Type*, -not *HsType*, and doing a call to tcMatchTy will loop because T isn't fully -defined yet. - -So, we want to make rejigConRes lazy and then check the validity of -the return type in checkValidDataCon. To do this we /always/ return a -6-tuple from rejigConRes (so that we can compute the return type from it, which -checkValidDataCon needs), but the first three fields may be bogus if -the return type isn't valid (the last equation for rejigConRes). - -This is better than an earlier solution which reduced the number of -errors reported in one pass. See #7175, and #10836. --} - --- Example --- data instance T (b,c) where --- TI :: forall e. e -> T (e,e) --- --- The representation tycon looks like this: --- data :R7T b c where --- TI :: forall b1 c1. (b1 ~ c1) => b1 -> :R7T b1 c1 --- In this case orig_res_ty = T (e,e) - -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) - -> KnotTied Type -- res_ty - -> ([TyVar], -- Universal - [TyVar], -- Existential (distinct OccNames from univs) - [InvisTVBinder], -- The constructor's rejigged, user-written - -- type variables - [EqSpec], -- Equality predicates - Subst) -- Substitution to apply to argument types - -- We don't check that the TyCon given in the ResTy is - -- the same as the parent tycon, because checkValidDataCon will do it --- NB: All arguments may potentially be knot-tied -rejigConRes tc_tvbndrs res_tmpl dc_tvbndrs res_ty - -- E.g. data T [a] b c where - -- MkT :: forall x y z. T [(x,y)] z z - -- The {a,b,c} are the tc_tvs, and the {x,y,z} are the dc_tvs - -- (NB: unlike the H98 case, the dc_tvs are not all existential) - -- Then we generate - -- Univ tyvars Eq-spec - -- a a~(x,y) - -- b b~z - -- z - -- Existentials are the leftover type vars: [x,y] - -- The user-written type variables are what is listed in the forall: - -- [x, y, z] (all specified). We must rejig these as well. - -- See Note [DataCon user type variable binders] in GHC.Core.DataCon. - -- So we return ( [a,b,z], [x,y] - -- , [], [x,y,z] - -- , [a~(x,y),b~z], ) - | Just subst <- tcMatchTy res_tmpl res_ty - = let (univ_tvs, raw_eqs, kind_subst) = mkGADTVars tc_tvs dc_tvs subst - raw_ex_tvs = dc_tvs `minusList` univ_tvs - (arg_subst, substed_ex_tvs) = substTyVarBndrs kind_subst raw_ex_tvs - - -- After rejigging the existential tyvars, the resulting substitution - -- gives us exactly what we need to rejig the user-written tyvars, - -- since the dcUserTyVarBinders invariant guarantees that the - -- substitution has *all* the tyvars in its domain. - -- See Note [DataCon user type variable binders] in GHC.Core.DataCon. - subst_user_tvs = mapVarBndrs (substTyVarToTyVar arg_subst) - substed_tvbndrs = subst_user_tvs dc_tvbndrs - - substed_eqs = [ mkEqSpec (substTyVarToTyVar arg_subst tv) - (substTy arg_subst ty) - | (tv,ty) <- raw_eqs ] - in - (univ_tvs, substed_ex_tvs, substed_tvbndrs, substed_eqs, arg_subst) - - | otherwise - -- If the return type of the data constructor doesn't match the parent - -- type constructor, or the arity is wrong, the tcMatchTy will fail - -- e.g data T a b where - -- T1 :: Maybe a -- Wrong tycon - -- T2 :: T [a] -- Wrong arity - -- We are detect that later, in checkValidDataCon, but meanwhile - -- we must do *something*, not just crash. So we do something simple - -- albeit bogus, relying on checkValidDataCon to check the - -- bad-result-type error before seeing that the other fields look odd - -- See Note [rejigConRes] - = (tc_tvs, dc_tvs `minusList` tc_tvs, dc_tvbndrs, [], emptySubst) - where - dc_tvs = binderVars dc_tvbndrs - tc_tvs = binderVars tc_tvbndrs - -{- Note [mkGADTVars] -~~~~~~~~~~~~~~~~~~~~ -Running example: - -data T (k1 :: *) (k2 :: *) (a :: k2) (b :: k2) where - MkT :: forall (x1 : *) (y :: x1) (z :: *). - T x1 * (Proxy (y :: x1), z) z - -We need the rejigged type to be - - MkT :: forall (x1 :: *) (k2 :: *) (a :: k2) (b :: k2). - forall (y :: x1) (z :: *). - (k2 ~ *, a ~ (Proxy x1 y, z), b ~ z) - => T x1 k2 a b - -You might naively expect that z should become a universal tyvar, -not an existential. (After all, x1 becomes a universal tyvar.) -But z has kind * while b has kind k2, so the return type - T x1 k2 a z -is ill-kinded. Another way to say it is this: the universal -tyvars must have exactly the same kinds as the tyConTyVars. - -So we need an existential tyvar and a heterogeneous equality -constraint. (The b ~ z is a bit redundant with the k2 ~ * that -comes before in that b ~ z implies k2 ~ *. I'm sure we could do -some analysis that could eliminate k2 ~ *. But we don't do this -yet.) - -The data con signature has already been fully kind-checked. -The return type - - T x1 * (Proxy (y :: x1), z) z -becomes - qtkvs = [x1 :: *, y :: x1, z :: *] - res_tmpl = T x1 * (Proxy x1 y, z) z - -We start off by matching (T k1 k2 a b) with (T x1 * (Proxy x1 y, z) z). We -know this match will succeed because of the validity check (actually done -later, but laziness saves us -- see Note [rejigConRes]). -Thus, we get - - subst := { k1 |-> x1, k2 |-> *, a |-> (Proxy x1 y, z), b |-> z } - -Now, we need to figure out what the GADT equalities should be. In this case, -we *don't* want (k1 ~ x1) to be a GADT equality: it should just be a -renaming. The others should be GADT equalities. We also need to make -sure that the universally-quantified variables of the datacon match up -with the tyvars of the tycon, as required for Core context well-formedness. -(This last bit is why we have to rejig at all!) - -`choose` walks down the tycon tyvars, figuring out what to do with each one. -It carries two substitutions: - - t_sub's domain is *template* or *tycon* tyvars, mapping them to variables - mentioned in the datacon signature. - - r_sub's domain is *result* tyvars, names written by the programmer in - the datacon signature. The final rejigged type will use these names, but - the subst is still needed because sometimes the printed name of these variables - is different. (See choose_tv_name, below.) - -Before explaining the details of `choose`, let's just look at its operation -on our example: - - choose [] [] {} {} [k1, k2, a, b] - --> -- first branch of `case` statement - choose - univs: [x1 :: *] - eq_spec: [] - t_sub: {k1 |-> x1} - r_sub: {x1 |-> x1} - t_tvs: [k2, a, b] - --> -- second branch of `case` statement - choose - univs: [k2 :: *, x1 :: *] - eq_spec: [k2 ~ *] - t_sub: {k1 |-> x1, k2 |-> k2} - r_sub: {x1 |-> x1} - t_tvs: [a, b] - --> -- second branch of `case` statement - choose - univs: [a :: k2, k2 :: *, x1 :: *] - eq_spec: [ a ~ (Proxy x1 y, z) - , k2 ~ * ] - t_sub: {k1 |-> x1, k2 |-> k2, a |-> a} - r_sub: {x1 |-> x1} - t_tvs: [b] - --> -- second branch of `case` statement - choose - univs: [b :: k2, a :: k2, k2 :: *, x1 :: *] - eq_spec: [ b ~ z - , a ~ (Proxy x1 y, z) - , k2 ~ * ] - t_sub: {k1 |-> x1, k2 |-> k2, a |-> a, b |-> z} - r_sub: {x1 |-> x1} - t_tvs: [] - --> -- end of recursion - ( [x1 :: *, k2 :: *, a :: k2, b :: k2] - , [k2 ~ *, a ~ (Proxy x1 y, z), b ~ z] - , {x1 |-> x1} ) - -`choose` looks up each tycon tyvar in the matching (it *must* be matched!). - -* If it finds a bare result tyvar (the first branch of the `case` - statement), it checks to make sure that the result tyvar isn't yet - in the list of univ_tvs. If it is in that list, then we have a - repeated variable in the return type, and we in fact need a GADT - equality. - -* It then checks to make sure that the kind of the result tyvar - matches the kind of the template tyvar. This check is what forces - `z` to be existential, as it should be, explained above. - -* Assuming no repeated variables or kind-changing, we wish to use the - variable name given in the datacon signature (that is, `x1` not - `k1`), not the tycon signature (which may have been made up by - GHC). So, we add a mapping from the tycon tyvar to the result tyvar - to t_sub. - -* If we discover that a mapping in `subst` gives us a non-tyvar (the - second branch of the `case` statement), then we have a GADT equality - to create. We create a fresh equality, but we don't extend any - substitutions. The template variable substitution is meant for use - in universal tyvar kinds, and these shouldn't be affected by any - GADT equalities. - -This whole algorithm is quite delicate, indeed. I (Richard E.) see two ways -of simplifying it: - -1) The first branch of the `case` statement is really an optimization, used -in order to get fewer GADT equalities. It might be possible to make a GADT -equality for *every* univ. tyvar, even if the equality is trivial, and then -either deal with the bigger type or somehow reduce it later. - -2) This algorithm strives to use the names for type variables as specified -by the user in the datacon signature. If we always used the tycon tyvar -names, for example, this would be simplified. This change would almost -certainly degrade error messages a bit, though. --} - --- ^ From information about a source datacon definition, extract out --- what the universal variables and the GADT equalities should be. --- See Note [mkGADTVars]. -mkGADTVars :: [TyVar] -- ^ The tycon vars - -> [TyVar] -- ^ The datacon vars - -> Subst -- ^ The matching between the template result type - -- and the actual result type - -> ( [TyVar] - , [(TyVar,Type)] -- The un-substituted eq-spec - , Subst ) -- ^ The univ. variables, the GADT equalities, - -- and a subst to apply to the GADT equalities - -- and existentials. -mkGADTVars tmpl_tvs dc_tvs subst - = choose [] [] empty_subst empty_subst tmpl_tvs - where - in_scope = mkInScopeSet (mkVarSet tmpl_tvs `unionVarSet` mkVarSet dc_tvs) - `unionInScope` getSubstInScope subst - empty_subst = mkEmptySubst in_scope - - choose :: [TyVar] -- accumulator of univ tvs, reversed - -> [(TyVar,Type)] -- accumulator of GADT equalities, reversed - -> Subst -- template substitution - -> Subst -- res. substitution - -> [TyVar] -- template tvs (the univ tvs passed in) - -> ( [TyVar] -- the univ_tvs - , [(TyVar,Type)] -- GADT equalities - , Subst ) -- a substitution to fix kinds in ex_tvs - - choose univs eqs _t_sub r_sub [] - = (reverse univs, reverse eqs, r_sub) - choose univs eqs t_sub r_sub (t_tv:t_tvs) - | Just r_ty <- lookupTyVar subst t_tv - = case getTyVar_maybe r_ty of - Just r_tv - | not (r_tv `elem` univs) - , tyVarKind r_tv `eqType` (substTy t_sub (tyVarKind t_tv)) - -> -- simple, well-kinded variable substitution. - -- the name of the universal comes from the result of the ctor - -- see (R2) of Note [DataCon user type variable binders] in GHC.Core.DataCon - choose (r_tv:univs) eqs - (extendTvSubst t_sub t_tv r_ty') - (extendTvSubst r_sub r_tv r_ty') - t_tvs - where - r_tv1 = setTyVarName r_tv (choose_tv_name r_tv t_tv) - r_ty' = mkTyVarTy r_tv1 - - -- Not a simple substitution: make an equality predicate - -- the name of the universal comes from the datatype header - -- see (R2) of Note [DataCon user type variable binders] in GHC.Core.DataCon - _ -> choose (t_tv':univs) eqs' - (extendTvSubst t_sub t_tv (mkTyVarTy t_tv')) - -- We've updated the kind of t_tv, - -- so add it to t_sub (#14162) - r_sub t_tvs - where - tv_kind = tyVarKind t_tv - tv_kind' = substTy t_sub tv_kind - t_tv' = setTyVarKind t_tv tv_kind' - eqs' | isConstraintLikeKind (typeKind tv_kind') = eqs - | otherwise = (t_tv', r_ty) : eqs - - | otherwise - = pprPanic "mkGADTVars" (ppr tmpl_tvs $$ ppr subst) - - -- choose an appropriate name for a univ tyvar. - -- This *must* preserve the Unique of the result tv, so that we - -- can detect repeated variables. It prefers user-specified names - -- over system names. A result variable with a system name can - -- happen with GHC-generated implicit kind variables. - choose_tv_name :: TyVar -> TyVar -> Name - choose_tv_name r_tv t_tv - | isSystemName r_tv_name - = setNameUnique t_tv_name (getUnique r_tv_name) - - | otherwise - = r_tv_name - - where - r_tv_name = getName r_tv - t_tv_name = getName t_tv - -{- -Note [Substitution in template variables kinds] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -data G (a :: Maybe k) where - MkG :: G Nothing - -With explicit kind variables - -data G k (a :: Maybe k) where - MkG :: G k1 (Nothing k1) - -Note how k1 is distinct from k. So, when we match the template -`G k a` against `G k1 (Nothing k1)`, we get a subst -[ k |-> k1, a |-> Nothing k1 ]. Even though this subst has two -mappings, we surely don't want to add (k, k1) to the list of -GADT equalities -- that would be overly complex and would create -more untouchable variables than we need. So, when figuring out -which tyvars are GADT-like and which aren't (the fundamental -job of `choose`), we want to treat `k` as *not* GADT-like. -Instead, we wish to substitute in `a`'s kind, to get (a :: Maybe k1) -instead of (a :: Maybe k). This is the reason for dealing -with a substitution in here. - -However, we do not *always* want to substitute. Consider - -data H (a :: k) where - MkH :: H Int - -With explicit kind variables: - -data H k (a :: k) where - MkH :: H * Int - -Here, we have a kind-indexed GADT. The subst in question is -[ k |-> *, a |-> Int ]. Now, we *don't* want to substitute in `a`'s -kind, because that would give a constructor with the type - -MkH :: forall (k :: *) (a :: *). (k ~ *) -> (a ~ Int) -> H k a - -The problem here is that a's kind is wrong -- it needs to be k, not *! -So, if the matching for a variable is anything but another bare variable, -we drop the mapping from the substitution before proceeding. This -was not an issue before kind-indexed GADTs because this case could -never happen. - -************************************************************************ -* * - Validity checking -* * -************************************************************************ - -Validity checking is done once the mutually-recursive knot has been -tied, so we can look at things freely. --} - -checkValidTyCl :: TyCon -> TcM [TyCon] --- The returned list is either a singleton (if valid) --- or a list of "fake tycons" (if not); the fake tycons --- include any implicits, like promoted data constructors --- See Note [Recover from validity error] -checkValidTyCl tc - = setSrcSpan (getSrcSpan tc) $ - addTyConCtxt tc $ - recoverM recovery_code $ - do { traceTc "Starting validity for tycon" (ppr tc) - ; checkValidTyCon tc - ; traceTc "Done validity for tycon" (ppr tc) - ; return [tc] } - where - recovery_code -- See Note [Recover from validity error] - = do { traceTc "Aborted validity for tycon" (ppr tc) - ; return (map mk_fake_tc $ - tc : child_tycons tc) } - - mk_fake_tc tc - | isClassTyCon tc = tc -- Ugh! Note [Recover from validity error] - | otherwise = makeRecoveryTyCon tc - - child_tycons tc = tyConATs tc ++ map promoteDataCon (tyConDataCons tc) - -{- Note [Recover from validity error] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We recover from a validity error in a type or class, which allows us -to report multiple validity errors. In the failure case we return a -TyCon of the right kind, but with no interesting behaviour -(makeRecoveryTyCon). Why? Suppose we have - type T a = Fun -where Fun is a type family of arity 1. The RHS is invalid, but we -want to go on checking validity of subsequent type declarations. -So we replace T with an abstract TyCon which will do no harm. -See indexed-types/should_fail/BadSock and #10896 - -Some notes: - -* We must make fakes for promoted DataCons too. Consider (#15215) - data T a = MkT ... - data S a = ...T...MkT.... - If there is an error in the definition of 'T' we add a "fake type - constructor" to the type environment, so that we can continue to - typecheck 'S'. But we /were not/ adding a fake anything for 'MkT' - and so there was an internal error when we met 'MkT' in the body of - 'S'. - - Similarly for associated types. - -* Painfully, we *don't* want to do this for classes. - Consider tcfail041: - class (?x::Int) => C a where ... - instance C Int - The class is invalid because of the superclass constraint. But - we still want it to look like a /class/, else the instance bleats - that the instance is mal-formed because it hasn't got a class in - the head. - - This is really bogus; now we have in scope a Class that is invalid - in some way, with unknown downstream consequences. A better - alternative might be to make a fake class TyCon. A job for another day. - -* Previously, we used implicitTyConThings to snaffle out the parts - to add to the context. The problem is that this also grabs data con - wrapper Ids. These could be filtered out. But, painfully, getting - the wrapper Ids checks the DataConRep, and forcing the DataConRep - can panic if there is a representation-polymorphic argument. This is #18534. - We don't need the wrapper Ids here anyway. So the code just takes what - it needs, via child_tycons. --} - -------------------------- --- For data types declared with record syntax, we require --- that each constructor that has a field 'f' --- (a) has the same result type --- (b) has the same type for 'f' --- module alpha conversion of the quantified type variables --- of the constructor. --- --- Note that we allow existentials to match because the --- fields can never meet. E.g --- data T where --- T1 { f1 :: b, f2 :: a, f3 ::Int } :: T --- T2 { f1 :: c, f2 :: c, f3 ::Int } :: T --- Here we do not complain about f1,f2 because they are existential - -checkValidTyCon :: TyCon -> TcM () -checkValidTyCon tc - | isPrimTyCon tc -- Happens when Haddock'ing GHC.Prim - = return () - - | isWiredIn tc -- validity-checking wired-in tycons is a waste of - -- time. More importantly, a wired-in tycon might - -- violate assumptions. Example: (~) has a superclass - -- mentioning (~#), which is ill-kinded in source Haskell - = traceTc "Skipping validity check for wired-in" (ppr tc) - - | otherwise - = do { traceTc "checkValidTyCon" (ppr tc $$ ppr (tyConClass_maybe tc)) - ; if | Just cl <- tyConClass_maybe tc - -> checkValidClass cl - - | Just syn_rhs <- synTyConRhs_maybe tc - -> do { checkValidType syn_ctxt syn_rhs - ; checkTySynRhs syn_ctxt syn_rhs } - - | Just fam_flav <- famTyConFlav_maybe tc - -> case fam_flav of - { ClosedSynFamilyTyCon (Just ax) - -> tcAddClosedTypeFamilyDeclCtxt tc $ - checkValidCoAxiom ax - ; ClosedSynFamilyTyCon Nothing -> return () - ; AbstractClosedSynFamilyTyCon -> - do { hsBoot <- tcIsHsBootOrSig - ; checkTc hsBoot $ mkTcRnUnknownMessage $ mkPlainError noHints $ - text "You may define an abstract closed type family" $$ - text "only in a .hs-boot file" } - ; DataFamilyTyCon {} -> return () - ; OpenSynFamilyTyCon -> return () - ; BuiltInSynFamTyCon _ -> return () } - - | otherwise -> do - { -- Check the context on the data decl - traceTc "cvtc1" (ppr tc) - ; checkValidTheta (DataTyCtxt name) (tyConStupidTheta tc) - - ; traceTc "cvtc2" (ppr tc) - - ; dflags <- getDynFlags - ; existential_ok <- xoptM LangExt.ExistentialQuantification - ; gadt_ok <- xoptM LangExt.GADTs - ; let ex_ok = existential_ok || gadt_ok - -- Data cons can have existential context - ; mapM_ (checkValidDataCon dflags ex_ok tc) data_cons - ; mapM_ (checkPartialRecordField data_cons) (tyConFieldLabels tc) - - -- Check that fields with the same name share a type - ; mapM_ check_fields groups }} - where - syn_ctxt = TySynCtxt name - name = tyConName tc - data_cons = tyConDataCons tc - - groups = equivClasses cmp_fld (concatMap get_fields data_cons) - -- This spot seems OK with non-determinism. cmp_fld is used only in equivClasses - -- which produces equivalence classes. - -- The order of these equivalence classes might conceivably (non-deterministically) - -- depend on the result of this comparison, but that just affects the order in which - -- fields are checked for compatibility. It will not affect the compiled binary. - cmp_fld (f1,_) (f2,_) = field_label (flLabel f1) `uniqCompareFS` field_label (flLabel f2) - get_fields con = dataConFieldLabels con `zip` repeat con - -- dataConFieldLabels may return the empty list, which is fine - - -- See Note [GADT record selectors] in GHC.Tc.TyCl.Utils - -- We must check (a) that the named field has the same - -- type in each constructor - -- (b) that those constructors have the same result type - -- - -- However, the constructors may have differently named type variable - -- and (worse) we don't know how the correspond to each other. E.g. - -- C1 :: forall a b. { f :: a, g :: b } -> T a b - -- C2 :: forall d c. { f :: c, g :: c } -> T c d - -- - -- So what we do is to ust Unify.tcMatchTys to compare the first candidate's - -- result type against other candidates' types BOTH WAYS ROUND. - -- If they magically agrees, take the substitution and - -- apply them to the latter ones, and see if they match perfectly. - check_fields ((label, con1) :| other_fields) - -- These fields all have the same name, but are from - -- different constructors in the data type - = recoverM (return ()) $ mapM_ checkOne other_fields - -- Check that all the fields in the group have the same type - -- NB: this check assumes that all the constructors of a given - -- data type use the same type variables - where - res1 = dataConOrigResTy con1 - fty1 = dataConFieldType con1 lbl - lbl = flLabel label - - checkOne (_, con2) -- Do it both ways to ensure they are structurally identical - = do { checkFieldCompat lbl con1 con2 res1 res2 fty1 fty2 - ; checkFieldCompat lbl con2 con1 res2 res1 fty2 fty1 } - where - res2 = dataConOrigResTy con2 - fty2 = dataConFieldType con2 lbl - -checkPartialRecordField :: [DataCon] -> FieldLabel -> TcM () --- Checks the partial record field selector, and warns. --- See Note [Checking partial record field] -checkPartialRecordField all_cons fld - = setSrcSpan loc $ - warnIf (not is_exhaustive && not (startsWithUnderscore occ_name)) - (mkTcRnUnknownMessage $ mkPlainDiagnostic (WarningWithFlag Opt_WarnPartialFields) noHints $ - sep [text "Use of partial record field selector" <> colon, - nest 2 $ quotes (ppr occ_name)]) - where - loc = getSrcSpan (flSelector fld) - occ_name = occName fld - - (cons_with_field, cons_without_field) = partition has_field all_cons - has_field con = fld `elem` (dataConFieldLabels con) - is_exhaustive = all (dataConCannotMatch inst_tys) cons_without_field - - con1 = assert (not (null cons_with_field)) $ head cons_with_field - inst_tys = dataConResRepTyArgs con1 - -checkFieldCompat :: FieldLabelString -> DataCon -> DataCon - -> Type -> Type -> Type -> Type -> TcM () -checkFieldCompat fld con1 con2 res1 res2 fty1 fty2 - = do { checkTc (isJust mb_subst1) (resultTypeMisMatch fld con1 con2) - ; checkTc (isJust mb_subst2) (fieldTypeMisMatch fld con1 con2) } - where - mb_subst1 = tcMatchTy res1 res2 - mb_subst2 = tcMatchTyX (expectJust "checkFieldCompat" 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))) $ - do { let tc_tvs = tyConTyVars tc - res_ty_tmpl = mkFamilyTyConApp tc (mkTyVarTys tc_tvs) - arg_tys = dataConOrigArgTys con - orig_res_ty = dataConOrigResTy con - - ; traceTc "checkValidDataCon" (vcat - [ ppr con, ppr tc, ppr tc_tvs - , ppr res_ty_tmpl <+> dcolon <+> ppr (typeKind res_ty_tmpl) - , ppr orig_res_ty <+> dcolon <+> ppr (typeKind orig_res_ty)]) - - - -- Check that the return type of the data constructor - -- matches the type constructor; eg reject this: - -- data T a where { MkT :: Bogus a } - -- It's important to do this first: - -- see Note [rejigConRes] - -- and c.f. Note [Check role annotations in a second pass] - - -- Check that the return type of the data constructor is an instance - -- of the header of the header of data decl. This checks for - -- data T a where { MkT :: S a } - -- data instance D [a] where { MkD :: D (Maybe b) } - -- see Note [GADT return types] - ; checkTc (isJust (tcMatchTyKi res_ty_tmpl orig_res_ty)) - (badDataConTyCon con res_ty_tmpl) - -- Note that checkTc aborts if it finds an error. This is - -- critical to avoid panicking when we call dataConDisplayType - -- on an un-rejiggable datacon! - -- Also NB that we match the *kind* as well as the *type* (#18357) - -- However, if the kind is the only thing that doesn't match, the - -- error message is terrible. E.g. test T18357b - -- type family Star where Star = Type - -- newtype T :: Type where MkT :: Int -> (T :: Star) - - ; traceTc "checkValidDataCon 2" (ppr data_con_display_type) - - -- Check that the result type is a *monotype* - -- e.g. reject this: MkT :: T (forall a. a->a) - -- Reason: it's really the argument of an equality constraint - ; checkValidMonoType orig_res_ty - ; checkEscapingKind (dataConWrapperType con) - - -- For /data/ types check that each argument has a fixed runtime rep - -- If we are dealing with a /newtype/, we allow representation - -- polymorphism regardless of whether or not UnliftedNewtypes - -- is enabled. A later check in checkNewDataCon handles this, - -- producing a better error message than checkTypeHasFixedRuntimeRep would. - ; let check_rr = checkTypeHasFixedRuntimeRep FixedRuntimeRepDataConField - ; unless (isNewTyCon tc) $ - checkNoErrs $ - mapM_ (check_rr . scaledThing) arg_tys - -- The checkNoErrs is to prevent a panic in isVanillaDataCon - -- (called a a few lines down), which can fall over if there is a - -- bang on a representation-polymorphic argument. This is #18534, - -- typecheck/should_fail/T18534 - - -- Extra checks for newtype data constructors. Importantly, these - -- checks /must/ come before the call to checkValidType below. This - -- is because checkValidType invokes the constraint solver, and - -- invoking the solver on an ill formed newtype constructor can - -- confuse GHC to the point of panicking. See #17955 for an example. - ; when (isNewTyCon tc) (checkNewDataCon con) - - -- Check all argument types for validity - ; checkValidType ctxt data_con_display_type - - -- Check that existentials are allowed if they are used - ; checkTc (existential_ok || isVanillaDataCon con) - (badExistential con) - - -- Check that the only constraints in signatures of constructors - -- in a "type data" declaration are equality constraints. - -- See Note [Type data declarations] in GHC.Rename.Module, - -- restriction (R4). - ; when (isTypeDataCon con) $ - checkTc (all isEqPred (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 - , not (bang_opt_strict_data bang_opts) - = addErrTc $ mkTcRnUnknownMessage $ mkPlainError noHints $ - (bad_bang n (text "Lazy annotation (~) without StrictData")) - - -- Warn about UNPACK without "!" - -- e.g. data T = MkT {-# UNPACK #-} Int - | HsSrcBang _ want_unpack strict_mark <- bang - , isSrcUnpacked want_unpack, not (is_strict strict_mark) - , not (isUnliftedType orig_arg_ty) - = addDiagnosticTc $ mkTcRnUnknownMessage $ - mkPlainDiagnostic WarningWithoutFlag noHints (bad_bang n (text "UNPACK pragma lacks '!'")) - - -- Warn about a redundant ! on an unlifted type - -- e.g. data T = MkT !Int# - | HsSrcBang _ _ SrcStrict <- bang - , isUnliftedType orig_arg_ty - = addDiagnosticTc $ TcRnBangOnUnliftedType orig_arg_ty - - -- Warn about a ~ on an unlifted type (#21951) - -- e.g. data T = MkT ~Int# - | HsSrcBang _ _ SrcLazy <- bang - , isUnliftedType orig_arg_ty - = addDiagnosticTc $ TcRnLazyBangOnUnliftedType orig_arg_ty - - -- Warn about unusable UNPACK pragmas - -- e.g. data T a = MkT {-# UNPACK #-} !a -- Can't unpack - | HsSrcBang _ want_unpack _ <- bang - - -- See Note [Detecting useless UNPACK pragmas] in GHC.Core.DataCon. - , isSrcUnpacked want_unpack -- this means the user wrote {-# UNPACK #-} - , case rep_bang of { HsUnpack {} -> False; HsStrict True -> False; _ -> True } - - -- When typechecking an indefinite package in Backpack, we - -- may attempt to UNPACK an abstract type. The test here will - -- conclude that this is unusable, but it might become usable - -- when we actually fill in the abstract type. As such, don't - -- 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 $ mkTcRnUnknownMessage $ - mkPlainDiagnostic WarningWithoutFlag noHints (bad_bang n (text "Ignoring unusable UNPACK pragma")) - - | otherwise - = return () - - ; void $ zipWith4M check_bang (map scaledThing $ dataConOrigArgTys con) - (dataConSrcBangs con) (dataConImplBangs con) [1..] - - -- Check the dcUserTyVarBinders invariant - -- See Note [DataCon user type variable binders] in GHC.Core.DataCon - -- checked here because we sometimes build invalid DataCons before - -- erroring above here - ; when debugIsOn $ - massertPpr (checkDataConTyVars con) $ - ppr con $$ ppr (dataConFullSig con) $$ ppr (dataConUserTyVars con) - - ; traceTc "Done validity of data con" $ - vcat [ ppr con - , text "Datacon wrapper type:" <+> ppr (dataConWrapperType 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)) - , case tyConFamInst_maybe (dataConTyCon con) of - Nothing -> text "not family" - Just (f, _) -> ppr (tyConBinders f) ] - } - where - bang_opts = initBangOpts dflags - con_name = dataConName con - con_loc = nameSrcSpan con_name - ctxt = ConArgCtxt con_name - is_strict = \case - NoSrcStrict -> bang_opt_strict_data bang_opts - bang -> isSrcStrict bang - - bad_bang n herald - = hang herald 2 (text "on the" <+> speakNth n - <+> text "argument of" <+> quotes (ppr con)) - - show_linear_types = xopt LangExt.LinearTypes dflags - data_con_display_type = dataConDisplayType show_linear_types con - -------------------------------- -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 --- newtype C = MkC Int# --- But they are caught earlier, by GHC.Tc.Gen.HsType.checkDataKindSig -checkNewDataCon con - = do { show_linear_types <- xopt LangExt.LinearTypes <$> getDynFlags - ; checkNoErrs $ - -- Fail here if the newtype is invalid: subsequent code in - -- checkValidDataCon can fall over if it comes across an invalid newtype. - do { case arg_tys of - [Scaled arg_mult _] -> - unless (ok_mult arg_mult) $ - addErrTc $ - TcRnIllegalNewtype con show_linear_types IsNonLinear - _ -> - addErrTc $ - TcRnIllegalNewtype con show_linear_types (DoesNotHaveSingleField $ length arg_tys) - - -- Add an error if the newtype is a GADt or has existentials. - -- - -- If the newtype is a GADT, the GADT error is enough; - -- we don't need to *also* complain about existentials. - ; if not (null eq_spec) - then addErrTc $ TcRnIllegalNewtype con show_linear_types IsGADT - else unless (null ex_tvs) $ - addErrTc $ - TcRnIllegalNewtype con show_linear_types HasExistentialTyVar - - ; unless (null theta) $ - addErrTc $ - TcRnIllegalNewtype con show_linear_types HasConstructorContext - - ; unless (all ok_bang (dataConSrcBangs con)) $ - addErrTc $ - TcRnIllegalNewtype con show_linear_types HasStrictnessAnnotation } } - where - - (_univ_tvs, ex_tvs, eq_spec, theta, arg_tys, _res_ty) - = dataConFullSig con - - ok_bang (HsSrcBang _ _ SrcStrict) = False - ok_bang (HsSrcBang _ _ SrcLazy) = False - ok_bang _ = True - - ok_mult OneTy = True - ok_mult _ = False - -------------------------------- -checkValidClass :: Class -> TcM () -checkValidClass cls - = do { constrained_class_methods <- xoptM LangExt.ConstrainedClassMethods - ; multi_param_type_classes <- xoptM LangExt.MultiParamTypeClasses - ; nullary_type_classes <- xoptM LangExt.NullaryTypeClasses - ; fundep_classes <- xoptM LangExt.FunctionalDependencies - ; undecidable_super_classes <- xoptM LangExt.UndecidableSuperClasses - - -- Check that the class is unary, unless multiparameter type classes - -- are enabled; also recognize deprecated nullary type classes - -- extension (subsumed by multiparameter type classes, #8993) - ; checkTc (multi_param_type_classes || cls_arity == 1 || - (nullary_type_classes && cls_arity == 0)) - (classArityErr cls_arity cls) - ; checkTc (fundep_classes || null fundeps) (classFunDepsErr cls) - - -- Check the super-classes - ; checkValidTheta (ClassSCCtxt (className cls)) theta - - -- Now check for cyclic superclasses - -- If there are superclass cycles, checkClassCycleErrs bails. - ; unless undecidable_super_classes $ - case checkClassCycles cls of - Just err -> setSrcSpan (getSrcSpan cls) $ - addErrTc (mkTcRnUnknownMessage $ mkPlainError noHints err) - Nothing -> return () - - -- Check the class operations. - -- But only if there have been no earlier errors - -- See Note [Abort when superclass cycle is detected] - ; whenNoErrs $ - mapM_ (check_op constrained_class_methods) op_stuff - - -- Check the associated type defaults are well-formed and instantiated - ; mapM_ check_at at_stuff } - where - (tyvars, fundeps, theta, _, at_stuff, op_stuff) = classExtraBigSig cls - cls_arity = length (tyConVisibleTyVars (classTyCon cls)) - -- Ignore invisible variables - cls_tv_set = mkVarSet tyvars - - check_op constrained_class_methods (sel_id, dm) - = setSrcSpan (getSrcSpan sel_id) $ - 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 - -- Example: tc223 - -- class Error e => Game b mv e | b -> mv e where - -- newBoard :: MonadState b m => m () - -- Here, MonadState has a fundep m->b, so newBoard is fine - - -- NB: we don't check that the class method is not representation-polymorphic here, - -- as GHC.TcGen.TyCl.tcClassSigType already includes a subtype check that guarantees - -- typeclass methods always have kind 'Type'. - -- - -- Test case: rep-poly/RepPolyClassMethod. - - ; unless constrained_class_methods $ - mapM_ check_constraint op_theta - - ; check_dm ctxt sel_id cls_pred tau2 dm - } - where - ctxt = FunSigCtxt op_name (WantRRC (getSrcSpan cls)) -- Report redundant class constraints - op_name = idName sel_id - op_ty = idType sel_id - (_,cls_pred,tau1) = tcSplitMethodTy op_ty - -- See Note [Splitting nested sigma types in class type signatures] - (_,op_theta,tau2) = tcSplitNestedSigmaTys tau1 - - check_constraint :: TcPredType -> TcM () - check_constraint pred -- See Note [Class method constraints] - = when (not (isEmptyVarSet pred_tvs) && - pred_tvs `subVarSet` cls_tv_set) - (addErrTc (badMethPred sel_id pred)) - where - pred_tvs = tyCoVarsOfType pred - - check_at (ATI fam_tc m_dflt_rhs) - = do { traceTc "ati" (ppr fam_tc $$ ppr tyvars $$ ppr fam_tvs) - ; checkTc (cls_arity == 0 || any (`elemVarSet` cls_tv_set) fam_tvs) - (noClassTyVarErr cls fam_tc) - -- Check that the associated type mentions at least - -- one of the class type variables - -- The check is disabled for nullary type classes, - -- since there is no possible ambiguity (#10020) - - -- Check that any default declarations for associated types are valid - ; whenIsJust m_dflt_rhs $ \ (rhs, at_validity_info) -> - case at_validity_info of - NoATVI -> pure () - ATVI loc pats -> - setSrcSpan loc $ - tcAddFamInstCtxt (text "default type instance") (getName fam_tc) $ - do { checkValidAssocTyFamDeflt fam_tc pats - ; checkValidTyFamEqn fam_tc fam_tvs (mkTyVarTys fam_tvs) rhs }} - where - fam_tvs = tyConTyVars fam_tc - - check_dm :: UserTypeCtxt -> Id -> PredType -> Type -> DefMethInfo -> TcM () - -- Check validity of the /top-level/ generic-default type - -- E.g for class C a where - -- default op :: forall b. (a~b) => blah - -- we do not want to do an ambiguity check on a type with - -- a free TyVar 'a' (#11608). See TcType - -- Note [TyVars and TcTyVars during type checking] in GHC.Tc.Utils.TcType - -- Hence the mkDefaultMethodType to close the type. - check_dm ctxt sel_id vanilla_cls_pred vanilla_tau - (Just (dm_name, dm_spec@(GenericDM dm_ty))) - = setSrcSpan (getSrcSpan dm_name) $ do - -- We have carefully set the SrcSpan on the generic - -- default-method Name to be that of the generic - -- default type signature - - -- First, we check that the method's default type signature - -- aligns with the non-default type signature. - -- See Note [Default method type signatures must align] - let cls_pred = mkClassPred cls $ mkTyVarTys $ classTyVars cls - -- Note that the second field of this tuple contains the context - -- of the default type signature, making it apparent that we - -- ignore method contexts completely when validity-checking - -- default type signatures. See the end of - -- Note [Default method type signatures must align] - -- to learn why this is OK. - -- - -- See also - -- Note [Splitting nested sigma types in class type signatures] - -- for an explanation of why we don't use tcSplitSigmaTy here. - (_, _, dm_tau) = tcSplitNestedSigmaTys dm_ty - - -- Given this class definition: - -- - -- class C a b where - -- op :: forall p q. (Ord a, D p q) - -- => a -> b -> p -> (a, b) - -- default op :: forall r s. E r - -- => a -> b -> s -> (a, b) - -- - -- We want to match up two types of the form: - -- - -- Vanilla type sig: C aa bb => aa -> bb -> p -> (aa, bb) - -- Default type sig: C a b => a -> b -> s -> (a, b) - -- - -- Notice that the two type signatures can be quantified over - -- different class type variables! Therefore, it's important that - -- we include the class predicate parts to match up a with aa and - -- b with bb. - vanilla_phi_ty = mkPhiTy [vanilla_cls_pred] vanilla_tau - dm_phi_ty = mkPhiTy [cls_pred] dm_tau - - traceTc "check_dm" $ vcat - [ text "vanilla_phi_ty" <+> ppr vanilla_phi_ty - , text "dm_phi_ty" <+> ppr dm_phi_ty ] - - -- Actually checking that the types align is done with a call to - -- tcMatchTys. We need to get a match in both directions to rule - -- out degenerate cases like these: - -- - -- class Foo a where - -- foo1 :: a -> b - -- default foo1 :: a -> Int - -- - -- foo2 :: a -> Int - -- default foo2 :: a -> b - unless (isJust $ tcMatchTys [dm_phi_ty, vanilla_phi_ty] - [vanilla_phi_ty, dm_phi_ty]) $ addErrTc $ - mkTcRnUnknownMessage $ mkPlainError noHints $ - 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") - - -- Now do an ambiguity check on the default type signature. - checkValidType ctxt (mkDefaultMethodType cls sel_id dm_spec) - check_dm _ _ _ _ _ = return () - -checkFamFlag :: Name -> TcM () --- Check that we don't use families without -XTypeFamilies --- The parser won't even parse them, but I suppose a GHC API --- client might have a go! -checkFamFlag tc_name - = do { idx_tys <- xoptM LangExt.TypeFamilies - ; checkTc idx_tys err_msg } - where - err_msg :: TcRnMessage - err_msg = mkTcRnUnknownMessage $ mkPlainError noHints $ - hang (text "Illegal family declaration for" <+> quotes (ppr tc_name)) - 2 (text "Enable TypeFamilies to allow indexed type families") - -checkResultSigFlag :: Name -> FamilyResultSig GhcRn -> TcM () -checkResultSigFlag tc_name (TyVarSig _ tvb) - = do { ty_fam_deps <- xoptM LangExt.TypeFamilyDependencies - ; checkTc ty_fam_deps $ mkTcRnUnknownMessage $ mkPlainError noHints $ - hang (text "Illegal result type variable" <+> ppr tvb <+> text "for" <+> quotes (ppr tc_name)) - 2 (text "Enable TypeFamilyDependencies to allow result variable names") } -checkResultSigFlag _ _ = return () -- other cases OK - -{- Note [Class method constraints] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Haskell 2010 is supposed to reject - class C a where - op :: Eq a => a -> a -where the method type constrains only the class variable(s). (The extension --XConstrainedClassMethods switches off this check.) But regardless -we should not reject - class C a where - op :: (?x::Int) => a -> a -as pointed out in #11793. So the test here rejects the program if - * -XConstrainedClassMethods is off - * the tyvars of the constraint are non-empty - * all the tyvars are class tyvars, none are locally quantified - -Note [Abort when superclass cycle is detected] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We must avoid doing the ambiguity check for the methods (in -checkValidClass.check_op) when there are already errors accumulated. -This is because one of the errors may be a superclass cycle, and -superclass cycles cause canonicalization to loop. Here is a -representative example: - - class D a => C a where - meth :: D a => () - class C a => D a - -This fixes #9415, #9739 - -Note [Default method type signatures must align] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -GHC enforces the invariant that a class method's default type signature -must "align" with that of the method's non-default type signature, as per -GHC #12918. For instance, if you have: - - class Foo a where - bar :: forall b. Context => a -> b - -Then a default type signature for bar must be alpha equivalent to -(forall b. a -> b). That is, the types must be the same modulo differences in -contexts. So the following would be acceptable default type signatures: - - default bar :: forall b. Context1 => a -> b - default bar :: forall x. Context2 => a -> x - -But the following are NOT acceptable default type signatures: - - default bar :: forall b. b -> a - default bar :: forall x. x - default bar :: a -> Int - -Note that a is bound by the class declaration for Foo itself, so it is -not allowed to differ in the default type signature. - -The default type signature (default bar :: a -> Int) deserves special mention, -since (a -> Int) is a straightforward instantiation of (forall b. a -> b). To -write this, you need to declare the default type signature like so: - - default bar :: forall b. (b ~ Int). a -> b - -As noted in #12918, there are several reasons to do this: - -1. It would make no sense to have a type that was flat-out incompatible with - the non-default type signature. For instance, if you had: - - class Foo a where - bar :: a -> Int - default bar :: a -> Bool - - Then that would always fail in an instance declaration. So this check - nips such cases in the bud before they have the chance to produce - confusing error messages. - -2. Internally, GHC uses TypeApplications to instantiate the default method in - an instance. See Note [Default methods in instances] in GHC.Tc.TyCl.Instance. - Thus, GHC needs to know exactly what the universally quantified type - variables are, and when instantiated that way, the default method's type - must match the expected type. - -3. Aesthetically, by only allowing the default type signature to differ in its - context, we are making it more explicit the ways in which the default type - signature is less polymorphic than the non-default type signature. - -You might be wondering: why are the contexts allowed to be different, but not -the rest of the type signature? That's because default implementations often -rely on assumptions that the more general, non-default type signatures do not. -For instance, in the Enum class declaration: - - class Enum a where - enum :: [a] - default enum :: (Generic a, GEnum (Rep a)) => [a] - enum = map to genum - - class GEnum f where - genum :: [f a] - -The default implementation for enum only works for types that are instances of -Generic, and for which their generic Rep type is an instance of GEnum. But -clearly enum doesn't _have_ to use this implementation, so naturally, the -context for enum is allowed to be different to accommodate this. As a result, -when we validity-check default type signatures, we ignore contexts completely. - -Note that when checking whether two type signatures match, we must take care to -split as many foralls as it takes to retrieve the tau types we which to check. -See Note [Splitting nested sigma types in class type signatures]. - -Extra note: July 22. If we have - class C a b where - op :: op_ty - default op :: def_ty - op = blah - -then we'll generate something like - $gdm_op :: C a b => def_ty - $gdm_op = blah - -We expect to write an instance that looks (in effect) like this: - instance G => C t1 t2 where - op = $gdm_op -- Added when you leave out binding for 'op' - -So we need that - assuming constraints G, and C t1 t2, - we have (def_ty[t1/a,t2/b] <= op_ty[t1/a,t2/b] - -In the validity check, we want to check that there is such a G. -E.g. if we check def_ty <= op_ty, and get an insoluble constraint -(Int~Bool), we know there will never be such a G, and can complain. - -This seems to be a more general way of thinking about the problem. -But no one is complaining, so it'll have to wait for another day - -Note [Splitting nested sigma types in class type signatures] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider this type synonym and class definition: - - type Traversal s t a b = forall f. Applicative f => (a -> f b) -> s -> f t - - class Each s t a b where - each :: Traversal s t a b - default each :: (Traversable g, s ~ g a, t ~ g b) => Traversal s t a b - -It might seem obvious that the tau types in both type signatures for `each` -are the same, but actually getting GHC to conclude this is surprisingly tricky. -That is because in general, the form of a class method's non-default type -signature is: - - forall a. C a => forall d. D d => E a b - -And the general form of a default type signature is: - - forall f. F f => E a f -- The variable `a` comes from the class - -So it you want to get the tau types in each type signature, you might find it -reasonable to call tcSplitSigmaTy twice on the non-default type signature, and -call it once on the default type signature. For most classes and methods, this -will work, but Each is a bit of an exceptional case. The way `each` is written, -it doesn't quantify any additional type variables besides those of the Each -class itself, so the non-default type signature for `each` is actually this: - - forall s t a b. Each s t a b => Traversal s t a b - -Notice that there _appears_ to only be one forall. But there's actually another -forall lurking in the Traversal type synonym, so if you call tcSplitSigmaTy -twice, you'll also go under the forall in Traversal! That is, you'll end up -with: - - (a -> f b) -> s -> f t - -A problem arises because you only call tcSplitSigmaTy once on the default type -signature for `each`, which gives you - - Traversal s t a b - -Or, equivalently: - - forall f. Applicative f => (a -> f b) -> s -> f t - -This is _not_ the same thing as (a -> f b) -> s -> f t! So now tcMatchTy will -say that the tau types for `each` are not equal. - -A solution to this problem is to use tcSplitNestedSigmaTys instead of -tcSplitSigmaTy. tcSplitNestedSigmaTys will always split any foralls that it -sees until it can't go any further, so if you called it on the default type -signature for `each`, it would return (a -> f b) -> s -> f t like we desired. - -Note [Checking partial record field] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -This check checks the partial record field selector, and warns (#7169). - -For example: - - data T a = A { m1 :: a, m2 :: a } | B { m1 :: a } - -The function 'm2' is partial record field, and will fail when it is applied to -'B'. The warning identifies such partial fields. The check is performed at the -declaration of T, not at the call-sites of m2. - -The warning can be suppressed by prefixing the field-name with an underscore. -For example: - - data T a = A { m1 :: a, _m2 :: a } | B { m1 :: a } - -************************************************************************ -* * - Checking role validity -* * -************************************************************************ --} - -checkValidRoleAnnots :: RoleAnnotEnv -> TyCon -> TcM () -checkValidRoleAnnots role_annots tc - | isTypeSynonymTyCon tc = check_no_roles - | isFamilyTyCon tc = check_no_roles - | isAlgTyCon tc = check_roles - | otherwise = return () - where - -- Role annotations are given only on *explicit* variables, - -- but a tycon stores roles for all variables. - -- So, we drop the implicit roles (which are all Nominal, anyway). - name = tyConName tc - roles = tyConRoles tc - (vis_roles, vis_vars) = unzip $ mapMaybe pick_vis $ - zip roles (tyConBinders tc) - role_annot_decl_maybe = lookupRoleAnnot role_annots name - - pick_vis :: (Role, TyConBinder) -> Maybe (Role, TyVar) - pick_vis (role, tvb) - | isVisibleTyConBinder tvb = Just (role, binderVar tvb) - | otherwise = Nothing - - check_roles - = whenIsJust role_annot_decl_maybe $ - \decl@(L loc (RoleAnnotDecl _ _ the_role_annots)) -> - addRoleAnnotCtxt name $ - setSrcSpanA loc $ do - { role_annots_ok <- xoptM LangExt.RoleAnnotations - ; checkTc role_annots_ok $ needXRoleAnnotations tc - ; checkTc (vis_vars `equalLength` the_role_annots) - (wrongNumberOfRoles vis_vars decl) - ; _ <- zipWith3M checkRoleAnnot vis_vars the_role_annots vis_roles - -- Representational or phantom roles for class parameters - -- quickly lead to incoherence. So, we require - -- IncoherentInstances to have them. See #8773, #14292 - ; incoherent_roles_ok <- xoptM LangExt.IncoherentInstances - ; checkTc ( incoherent_roles_ok - || (not $ isClassTyCon tc) - || (all (== Nominal) vis_roles)) - incoherentRoles - - ; lint <- goptM Opt_DoCoreLinting - ; when lint $ checkValidRoles tc } - - check_no_roles - = whenIsJust role_annot_decl_maybe illegalRoleAnnotDecl - -checkRoleAnnot :: TyVar -> LocatedAn NoEpAnns (Maybe Role) -> Role -> TcM () -checkRoleAnnot _ (L _ Nothing) _ = return () -checkRoleAnnot tv (L _ (Just r1)) r2 - = when (r1 /= r2) $ - addErrTc $ badRoleAnnot (tyVarName tv) r1 r2 - --- This is a double-check on the role inference algorithm. It is only run when --- -dcore-lint is enabled. See Note [Role inference] in GHC.Tc.TyCl.Utils -checkValidRoles :: TyCon -> TcM () --- If you edit this function, you may need to update the GHC formalism --- See Note [GHC Formalism] in GHC.Core.Lint -checkValidRoles tc - | isAlgTyCon tc - -- tyConDataCons returns an empty list for data families - = mapM_ check_dc_roles (tyConDataCons tc) - | Just rhs <- synTyConRhs_maybe tc - = check_ty_roles (zipVarEnv (tyConTyVars tc) (tyConRoles tc)) Representational rhs - | otherwise - = return () - where - check_dc_roles datacon - = do { traceTc "check_dc_roles" (ppr datacon <+> ppr (tyConRoles tc)) - ; mapM_ (check_ty_roles role_env Representational) $ - eqSpecPreds eq_spec ++ theta ++ map scaledThing arg_tys } - -- See Note [Role-checking data constructor arguments] in GHC.Tc.TyCl.Utils - where - (univ_tvs, ex_tvs, eq_spec, theta, arg_tys, _res_ty) - = dataConFullSig datacon - univ_roles = zipVarEnv univ_tvs (tyConRoles tc) - -- zipVarEnv uses zipEqual, but we don't want that for ex_tvs - ex_roles = mkVarEnv (map (, Nominal) ex_tvs) - role_env = univ_roles `plusVarEnv` ex_roles - - check_ty_roles env role ty - | Just ty' <- coreView ty -- #14101 - = check_ty_roles env role ty' - - check_ty_roles env role (TyVarTy tv) - = case lookupVarEnv env tv of - Just role' -> unless (role' `ltRole` role || role' == role) $ - report_error $ text "type variable" <+> quotes (ppr tv) <+> - text "cannot have role" <+> ppr role <+> - text "because it was assigned role" <+> ppr role' - Nothing -> report_error $ text "type variable" <+> quotes (ppr tv) <+> - text "missing in environment" - - check_ty_roles env Representational (TyConApp tc tys) - = let roles' = tyConRoles tc in - zipWithM_ (maybe_check_ty_roles env) roles' tys - - check_ty_roles env Nominal (TyConApp _ tys) - = mapM_ (check_ty_roles env Nominal) tys - - check_ty_roles _ Phantom ty@(TyConApp {}) - = pprPanic "check_ty_roles" (ppr ty) - - check_ty_roles env role (AppTy ty1 ty2) - = check_ty_roles env role ty1 - >> check_ty_roles env Nominal ty2 - - check_ty_roles env role (FunTy _ w ty1 ty2) - = check_ty_roles env Nominal w - >> check_ty_roles env role ty1 - >> check_ty_roles env role ty2 - - check_ty_roles env role (ForAllTy (Bndr tv _) ty) - = check_ty_roles env Nominal (tyVarKind tv) - >> check_ty_roles (extendVarEnv env tv Nominal) role ty - - check_ty_roles _ _ (LitTy {}) = return () - - check_ty_roles env role (CastTy t _) - = check_ty_roles env role t - - check_ty_roles _ role (CoercionTy co) - = unless (role == Phantom) $ - report_error $ text "coercion" <+> ppr co <+> text "has bad role" <+> ppr role - - maybe_check_ty_roles env role ty - = when (role == Nominal || role == Representational) $ - check_ty_roles env role ty - - report_error doc - = addErrTc $ mkTcRnUnknownMessage $ mkPlainError noHints $ - vcat [text "Internal error in role inference:", - doc, - text "Please report this as a GHC bug: https://www.haskell.org/ghc/reportabug"] - -{- -************************************************************************ -* * - Error messages -* * -************************************************************************ --} - -tcMkDeclCtxt :: TyClDecl GhcRn -> SDoc -tcMkDeclCtxt decl = hsep [text "In the", pprTyClDeclFlavour decl, - text "declaration for", quotes (ppr (tcdName decl))] - -addVDQNote :: TcTyCon -> TcM a -> TcM a --- See Note [Inferring visible dependent quantification] --- Only types without a signature (CUSK or SAK) here -addVDQNote tycon thing_inside - | assertPpr (isMonoTcTyCon tycon) (ppr tycon $$ ppr tc_kind) - has_vdq - = addLandmarkErrCtxt vdq_warning thing_inside - | otherwise - = thing_inside - where - -- Check whether a tycon has visible dependent quantification. - -- This will *always* be a TcTyCon. Furthermore, it will *always* - -- be an ungeneralised TcTyCon, straight out of kcInferDeclHeader. - -- Thus, all the TyConBinders will be anonymous. Thus, the - -- free variables of the tycon's kind will be the same as the free - -- variables from all the binders. - has_vdq = any is_vdq_tcb (tyConBinders tycon) - tc_kind = tyConKind tycon - kind_fvs = tyCoVarsOfType tc_kind - - 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 - where - ctxt = text "In the equations for closed type family" <+> - quotes (ppr tc) - -resultTypeMisMatch :: FieldLabelString -> DataCon -> DataCon -> TcRnMessage -resultTypeMisMatch field_name con1 con2 - = mkTcRnUnknownMessage $ mkPlainError noHints $ - 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"] - -fieldTypeMisMatch :: FieldLabelString -> DataCon -> DataCon -> TcRnMessage -fieldTypeMisMatch field_name con1 con2 - = mkTcRnUnknownMessage $ mkPlainError noHints $ - sep [text "Constructors" <+> ppr con1 <+> text "and" <+> ppr con2, - text "give different types for field", quotes (ppr field_name)] - -dataConCtxt :: NonEmpty (LocatedN Name) -> SDoc -dataConCtxt cons = text "In the definition of data constructor" <> plural (toList cons) - <+> ppr_cons (toList cons) - -dataConResCtxt :: NonEmpty (LocatedN Name) -> SDoc -dataConResCtxt cons = text "In the result type of data constructor" <> plural (toList cons) - <+> ppr_cons (toList cons) - -ppr_cons :: [LocatedN Name] -> SDoc -ppr_cons [con] = quotes (ppr con) -ppr_cons cons = interpp'SP cons - -classOpCtxt :: Var -> Type -> SDoc -classOpCtxt sel_id tau = sep [text "When checking the class method:", - nest 2 (pprPrefixOcc sel_id <+> dcolon <+> ppr tau)] - -classArityErr :: Int -> Class -> TcRnMessage -classArityErr n cls - | n == 0 = mkErr "No" "no-parameter" - | otherwise = mkErr "Too many" "multi-parameter" - where - mkErr howMany allowWhat = mkTcRnUnknownMessage $ mkPlainError noHints $ - vcat [text (howMany ++ " parameters for class") <+> quotes (ppr cls), - parens (text ("Enable MultiParamTypeClasses to allow " - ++ allowWhat ++ " classes"))] - -classFunDepsErr :: Class -> TcRnMessage -classFunDepsErr cls - = mkTcRnUnknownMessage $ mkPlainError noHints $ - vcat [text "Fundeps in class" <+> quotes (ppr cls), - parens (text "Enable FunctionalDependencies to allow fundeps")] - -badMethPred :: Id -> TcPredType -> TcRnMessage -badMethPred sel_id pred - = mkTcRnUnknownMessage $ mkPlainError noHints $ - vcat [ hang (text "Constraint" <+> quotes (ppr pred) - <+> text "in the type of" <+> quotes (ppr sel_id)) - 2 (text "constrains only the class type variables") - , text "Enable ConstrainedClassMethods to allow it" ] - -noClassTyVarErr :: Class -> TyCon -> TcRnMessage -noClassTyVarErr clas fam_tc - = mkTcRnUnknownMessage $ mkPlainError noHints $ - 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 clas <+> hsep (map ppr (classTyVars clas)))] - -badDataConTyCon :: DataCon -> Type -> TcRnMessage -badDataConTyCon data_con res_ty_tmpl - = mkTcRnUnknownMessage $ mkPlainError noHints $ - 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 - -badGadtDecl :: Name -> TcRnMessage -badGadtDecl tc_name - = mkTcRnUnknownMessage $ mkPlainError noHints $ - vcat [ text "Illegal generalised algebraic data declaration for" <+> quotes (ppr tc_name) - , nest 2 (parens $ text "Enable the GADTs extension to allow this") ] - -badExistential :: DataCon -> TcRnMessage -badExistential con - = mkTcRnUnknownMessage $ mkPlainError noHints $ - 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 (vcat [ ppr con <+> dcolon <+> ppr (dataConDisplayType show_linear_types con) - , parens $ text "Enable ExistentialQuantification or GADTs to allow this" ])) - -badStupidTheta :: Name -> TcRnMessage -badStupidTheta tc_name - = mkTcRnUnknownMessage $ mkPlainError noHints $ - text "A data type declared in GADT style cannot have a context:" <+> quotes (ppr tc_name) - -newtypeConError :: Name -> Int -> TcRnMessage -newtypeConError tycon n - = mkTcRnUnknownMessage $ mkPlainError noHints $ - sep [text "A newtype must have exactly one constructor,", - nest 2 $ text "but" <+> quotes (ppr tycon) <+> text "has" <+> speakN n ] - -badSigTyDecl :: Name -> TcRnMessage -badSigTyDecl tc_name - = mkTcRnUnknownMessage $ mkPlainError noHints $ - vcat [ text "Illegal kind signature" <+> - quotes (ppr tc_name) - , nest 2 (parens $ text "Use KindSignatures to allow kind signatures") ] - -emptyConDeclsErr :: Name -> TcRnMessage -emptyConDeclsErr tycon - = mkTcRnUnknownMessage $ mkPlainError noHints $ - sep [quotes (ppr tycon) <+> text "has no constructors", - nest 2 $ text "(EmptyDataDecls permits this)"] - -wrongKindOfFamily :: TyCon -> TcRnMessage -wrongKindOfFamily family - = mkTcRnUnknownMessage $ mkPlainError noHints $ - text "Wrong category of family instance; declaration was for a" - <+> kindOfFamily - where - kindOfFamily | isTypeFamilyTyCon family = text "type family" - | isDataFamilyTyCon family = text "data family" - | otherwise = pprPanic "wrongKindOfFamily" (ppr family) - --- | Produce an error for oversaturated type family equations with too many --- required arguments. --- See Note [Oversaturated type family equations] in "GHC.Tc.Validity". -wrongNumberOfParmsErr :: Arity -> TcRnMessage -wrongNumberOfParmsErr max_args - = mkTcRnUnknownMessage $ mkPlainError noHints $ - text "Number of parameters must match family declaration; expected" - <+> ppr max_args - -badRoleAnnot :: Name -> Role -> Role -> TcRnMessage -badRoleAnnot var annot inferred - = mkTcRnUnknownMessage $ mkPlainError noHints $ - hang (text "Role mismatch on variable" <+> ppr var <> colon) - 2 (sep [ text "Annotation says", ppr annot - , text "but role", ppr inferred - , text "is required" ]) - -wrongNumberOfRoles :: [a] -> LRoleAnnotDecl GhcRn -> TcRnMessage -wrongNumberOfRoles tyvars d@(L _ (RoleAnnotDecl _ _ annots)) - = mkTcRnUnknownMessage $ mkPlainError noHints $ - hang (text "Wrong number of roles listed in role annotation;" $$ - text "Expected" <+> (ppr $ length tyvars) <> comma <+> - text "got" <+> (ppr $ length annots) <> colon) - 2 (ppr d) - - -illegalRoleAnnotDecl :: LRoleAnnotDecl GhcRn -> TcM () -illegalRoleAnnotDecl (L loc (RoleAnnotDecl _ tycon _)) - = setErrCtxt [] $ - setSrcSpanA loc $ - addErrTc $ mkTcRnUnknownMessage $ mkPlainError noHints $ - (text "Illegal role annotation for" <+> ppr tycon <> char ';' $$ - text "they are allowed only for datatypes and classes.") - -needXRoleAnnotations :: TyCon -> TcRnMessage -needXRoleAnnotations tc - = mkTcRnUnknownMessage $ mkPlainError noHints $ - text "Illegal role annotation for" <+> ppr tc <> char ';' $$ - text "did you intend to use RoleAnnotations?" - -incoherentRoles :: TcRnMessage -incoherentRoles = mkTcRnUnknownMessage $ mkPlainError noHints $ - (text "Roles other than" <+> quotes (text "nominal") <+> - text "for class parameters can lead to incoherence.") $$ - (text "Use IncoherentInstances to allow this; bad role found") - -wrongTyFamName :: Name -> Name -> TcRnMessage -wrongTyFamName fam_tc_name eqn_tc_name - = mkTcRnUnknownMessage $ mkPlainError noHints $ - hang (text "Mismatched type name in type family instance.") - 2 (vcat [ text "Expected:" <+> ppr fam_tc_name - , text " Actual:" <+> ppr eqn_tc_name ]) - -addTyConCtxt :: TyCon -> TcM a -> TcM a -addTyConCtxt tc = addTyConFlavCtxt 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) +-- | Typecheck type and class declarations +module GHC.Tc.TyCl ( + tcTyAndClassDecls, + + -- Functions used by GHC.Tc.TyCl.Instance to check + -- data/type family instance declarations + kcConDecls, tcConDecls, DataDeclInfo(..), + dataDeclChecks, checkValidTyCon, + tcFamTyPats, tcTyFamInstEqn, + tcAddOpenTyFamInstCtxt, tcMkDataFamInstCtxt, tcAddDataFamInstCtxt, + unravelFamInstPats, addConsistencyConstraints, + checkFamTelescope, + + -- Used by GHC.HsToCore.Quote + IsPrefixConGADT(..), unannotatedMultIsLinear + ) where + +import GHC.Prelude + +import GHC.Driver.Env +import GHC.Driver.DynFlags +import GHC.Driver.Config.HsToCore + +import GHC.Hs + +import GHC.Tc.Errors.Types +import GHC.Tc.TyCl.Build +import GHC.Tc.Solver( pushLevelAndSolveEqualities, pushLevelAndSolveEqualitiesX + , reportUnsolvedEqualities ) +import GHC.Tc.Utils.Monad +import GHC.Tc.Utils.Env +import GHC.Tc.Utils.Unify( unifyType, emitResidualTvConstraint ) +import GHC.Tc.Types.Constraint( emptyWC ) +import GHC.Tc.Validity +import GHC.Tc.Zonk.Type +import GHC.Tc.Zonk.TcType +import GHC.Tc.TyCl.Utils +import GHC.Tc.TyCl.Class +import {-# SOURCE #-} GHC.Tc.TyCl.Instance( tcInstDecls1 ) +import {-# SOURCE #-} GHC.Tc.Module( checkBootDeclM ) +import GHC.Tc.Deriv (DerivInfo(..)) +import GHC.Tc.Gen.HsType +import GHC.Tc.Instance.Class( AssocInstInfo(..) ) +import GHC.Tc.Utils.TcMType +import GHC.Tc.Utils.TcType +import GHC.Tc.Instance.Family +import GHC.Tc.Types.ErrCtxt ( TyConInstFlavour(..) ) +import GHC.Tc.Types.LclEnv +import GHC.Tc.Types.Origin + +import GHC.Builtin.Types ( oneDataConTy, unitTy, makeRecoveryTyCon, manyDataConTy ) + +import GHC.Rename.Env( lookupConstructorFields ) + +import GHC.Core.Multiplicity +import GHC.Core.FamInstEnv ( mkBranchedCoAxiom, mkCoAxBranch ) +import GHC.Core.Coercion +import GHC.Core.Type +import GHC.Core.TyCo.Rep -- for checkValidRoles +import GHC.Core.TyCo.Ppr( pprTyVars ) +import GHC.Core.Class +import GHC.Core.Coercion.Axiom +import GHC.Core.TyCon +import GHC.Core.DataCon +import GHC.Core.Unify + +import GHC.Types.Id +import GHC.Types.Id.Make +import GHC.Types.Var +import GHC.Types.Var.Env +import GHC.Types.Var.Set +import GHC.Types.Name +import GHC.Types.Name.Set +import GHC.Types.Name.Env +import GHC.Types.SrcLoc +import GHC.Types.SourceFile +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.Constants (debugIsOn) +import GHC.Utils.Misc + +import Language.Haskell.Syntax.Basic (FieldLabelString(..)) + +import Control.Monad +import Data.Foldable ( toList, traverse_ ) +import Data.Functor.Identity +import Data.List ( partition) +import Data.List.NonEmpty ( NonEmpty(..) ) +import qualified Data.List.NonEmpty as NE +import Data.Traversable ( for ) +import Data.Tuple( swap ) +import qualified Data.Semigroup as S + +{- +************************************************************************ +* * +\subsection{Type checking for type and class declarations} +* * +************************************************************************ + +Note [Grouping of type and class declarations] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +tcTyAndClassDecls is called on a list of `TyClGroup`s. Each group is a strongly +connected component of mutually dependent types and classes. We kind check and +type check each group separately to enhance kind polymorphism. Take the +following example: + + type Id a = a + data X = X (Id Int) + +If we were to kind check the two declarations together, we would give Id the +kind * -> *, since we apply it to an Int in the definition of X. But we can do +better than that, since Id really is kind polymorphic, and should get kind +forall (k::*). k -> k. Since it does not depend on anything else, it can be +kind-checked by itself, hence getting the most general kind. We then kind check +X, which works fine because we then know the polymorphic kind of Id, and simply +instantiate k to *. + +Note [Check role annotations in a second pass] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Role inference potentially depends on the types of all of the datacons declared +in a mutually recursive group. The validity of a role annotation, in turn, +depends on the result of role inference. Because the types of datacons might +be ill-formed (see #7175 and Note [rejigConRes]) we must check +*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]. +-} + +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 $ go mempty tyclds_s + where + 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, 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 + , group_roles = roles + , group_kisigs = kisigs + , group_instds = instds }) + = do { let role_annots = mkRoleAnnotEnv roles + + -- Step 1: Typecheck the standalone kind signatures and type/class declarations + ; traceTc "---- tcTyClGroup ---- {" empty + ; traceTc "Decls for" (ppr (map (tcdName . unLoc) tyclds)) + ; (tyclss_with_validity_infos, data_deriv_info, kindless) <- + tcExtendKindEnv (mkPromotionErrorEnv tyclds) $ -- See Note [Type environment evolution] + do { kisig_env <- mkNameEnv <$> traverse tcStandaloneKindSig kisigs + ; tcTyClDecls tyclds kisig_env role_annots } + ; let tyclss = map fst tyclss_with_validity_infos + -- Step 1.5: Make sure we don't have any type synonym cycles + + ; traceTc "Starting synonym cycle check" (ppr tyclss) + ; home_unit <- hsc_home_unit <$> getTopEnv + ; checkSynCycles (homeUnitAsUnit home_unit) tyclss tyclds + ; traceTc "Done synonym cycle check" (ppr tyclss) + + -- Step 2: Perform the validity check on those types/classes + -- We can do this now because we are done with the recursive knot + -- Do it before Step 3 (adding implicit things) because the latter + -- expects well-formed TyCons + ; traceTc "Starting validity check" (ppr tyclss) + ; tyclss <- tcExtendTyConEnv tyclss $ + -- NB: put the TyCons in the environment for validity checking, + -- 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 { 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 } + + ; traceTc "Done validity check" (ppr tyclss) + ; mapM_ (recoverM (return ()) . checkValidRoleAnnots role_annots) tyclss + -- See Note [Check role annotations in a second pass] + + ; traceTc "---- end tcTyClGroup ---- }" empty + + -- Step 3: Add the implicit things; + -- we want them in the environment because + -- they may be mentioned in interface files + ; (gbl_env, th_bndrs) <- addTyConsToGblEnv tyclss + + -- Step 4: check instance declarations + ; (gbl_env', inst_info, datafam_deriv_info, th_bndrs') <- + setGblEnv gbl_env $ + tcInstDecls1 instds + + ; let deriv_info = datafam_deriv_info ++ data_deriv_info + ; let gbl_env'' = gbl_env' + { tcg_ksigs = tcg_ksigs gbl_env' `unionNameSet` kindless } + ; 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 + +tcTyClDecls + :: [LTyClDecl GhcRn] + -> KindSigEnv + -> RoleAnnotEnv + -> TcM ([(TyCon, [TyFamEqnValidityInfo])], [DerivInfo], NameSet) +tcTyClDecls tyclds kisig_env role_annots + = do { -- Step 1: kind-check this group and returns the final + -- (possibly-polymorphic) kind of each TyCon and Class + -- See Note [Kind checking for type and class decls] + (tc_tycons, kindless) <- checkNoErrs $ + kcTyClGroup kisig_env tyclds + -- checkNoErrs: If the TyCons are ill-kinded, stop now. Else we + -- can get follow-on errors. Example: #23252, where the TyCon + -- had an ill-scoped kind forall (d::k) k (a::k). blah + -- and that ill-scoped kind made role inference fall over. + + ; traceTc "tcTyAndCl generalized kinds" (vcat (map ppr_tc_tycon tc_tycons)) + + -- Step 2: type-check all groups together, returning + -- the final TyCons and Classes + -- + -- NB: We have to be careful here to NOT eagerly unfold + -- type synonyms, as we have not tested for type synonym + -- loops yet and could fall into a black hole. + ; fixM $ \ ~(rec_tyclss_with_validity_infos, _, _) -> do + { tcg_env <- getGblEnv + -- Forced so we don't retain a reference to the TcGblEnv + ; let !src = tcg_src tcg_env + rec_tyclss = map fst rec_tyclss_with_validity_infos + roles = inferRoles src role_annots rec_tyclss + + -- Populate environment with knot-tied ATyCon for TyCons + -- NB: if the decls mention any ill-staged data cons + -- (see Note [Recursion and promoting data constructors]) + -- we will have failed already in kcTyClGroup, so no worries here + ; (tycons, data_deriv_infos) <- + tcExtendRecEnv (zipRecTyClss tc_tycons rec_tyclss) $ + + -- Also extend the local type envt with bindings giving + -- a TcTyCon for each knot-tied TyCon or Class + -- See Note [Type checking recursive type and class declarations] + -- and Note [Type environment evolution] + tcExtendKindEnvWithTyCons tc_tycons $ + + -- Kind and type check declarations for this group + mapAndUnzipM (tcTyClDecl roles) tyclds + ; return (tycons, concat data_deriv_infos, kindless) + } } + where + ppr_tc_tycon tc = parens (sep [ ppr (tyConName tc) <> comma + , ppr (tyConBinders tc) <> comma + , ppr (tyConResKind tc) + , ppr (isTcTyCon tc) ]) + +zipRecTyClss :: [TcTyCon] + -> [TyCon] -- Knot-tied + -> [(Name,TyThing)] +-- Build a name-TyThing mapping for the TyCons bound by decls +-- being careful not to look at the knot-tied [TyThing] +-- The TyThings in the result list must have a visible ATyCon, +-- because typechecking types (in, say, tcTyClDecl) looks at +-- this outer constructor +zipRecTyClss tc_tycons rec_tycons + = [ (name, ATyCon (get name)) | tc_tycon <- tc_tycons, let name = getName tc_tycon ] + where + rec_tc_env :: NameEnv TyCon + rec_tc_env = foldr add_tc emptyNameEnv rec_tycons + + add_tc :: TyCon -> NameEnv TyCon -> NameEnv TyCon + add_tc tc env = foldr add_one_tc env (tc : tyConATs tc) + + add_one_tc :: TyCon -> NameEnv TyCon -> NameEnv TyCon + add_one_tc tc env = extendNameEnv env (tyConName tc) tc + + get name = case lookupNameEnv rec_tc_env name of + Just tc -> tc + other -> pprPanic "zipRecTyClss" (ppr name <+> ppr other) + +{- +************************************************************************ +* * + Kind checking +* * +************************************************************************ + +Note [Kind checking for type and class decls] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Kind checking is done thus: + + 1. Make up a kind variable for each parameter of the declarations, + and extend the kind environment (which is in the TcLclEnv) + + 2. Kind check the declarations + +We need to kind check all types in the mutually recursive group +before we know the kind of the type variables. For example: + + class C a where + op :: D b => a -> b -> b + + class D c where + bop :: (Monad c) => ... + +Here, the kind of the locally-polymorphic type variable "b" +depends on *all the uses of class D*. For example, the use of +Monad c in bop's type signature means that D must have kind Type->Type. + +Note: we don't treat type synonyms specially (we used to, in the past); +in particular, even if we have a type synonym cycle, we still kind check +it normally, and test for cycles later (checkSynCycles). The reason +we can get away with this is because we have more systematic TYPE r +inference, which means that we can do unification between kinds that +aren't lifted (this historically was not true.) + +The downside of not directly reading off the kinds of the RHS of +type synonyms in topological order is that we don't transparently +support making synonyms of types with higher-rank kinds. But +you can always specify a CUSK directly to make this work out. +See tc269 for an example. + +Note [TcTyCon, MonoTcTyCon, and PolyTcTyCon] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +A TcTyCon is one of the variants of TyCon. First, here are its invariants: + +* TcTyCon: a TyCon built with the TcTyCon constructor + A TcTyCon contains TcTyVars in its binders and kind + +* TcTyConBinder: a TyConBinder with a TcTyVar inside (not a TyVar) + +* MonoTcTyCon: a form of TcTyCon + - Flag tcTyConIsPoly = False + + - tyConBinders are TcTyConBinders: they contain TcTyVars, which are + unification variables (TyVarTv), and whose kinds may contain + unification variables. + + - tyConKind: the Monomorphic Recursion Principle: + a MonoTcTyCon has a /monomorphic kind/. + See Note [No polymorphic recursion in type decls]. + But the tyConKind may contain free unification variables. + + - tyConScopedTyVars is important; maps a Name to a TyVarTv unification variable + The order matters: Specified then Required variables. + E.g. in + data T a (b :: k) = ... + the order will be [k, a, b]. + + We do not allow @k-binders in inference mode, so we do not need to worry about + data T a @k (b :: k) = ... + where we would have to put `k` (Specified) after `a` (Required) + + NB: There are no Inferred binders in tyConScopedTyVars; 'a' may + also be poly-kinded, but that kind variable will be added by + generaliseTcTyCon, in the passage to a PolyTcTyCon. + + - tyConBinders are irrelevant; we just use tcTyConScopedTyVars + Well not /quite/ irrelevant: + * its length gives the number of explicit binders, and so allows us to + distinguish between the implicit and explicit elements of + tyConScopedTyVars. + * at construction time (mkTcTyCon) for a MonoTcTyCon (the call to mkTcTyCon + in GHC.Tc.Gen.HsType.kcInferDeclHeader) the tyConBinders are used to + construct the tyConKind; all must have AnonTCB visiblity so we we get + a monokind. + +* PolyTcTyCon: a form of TcTyCon + - Flag tcTyConIsPoly = True; this is used only to short-cut zonking + + - tyConBinders are still TcTyConBinders, but they are /skolem/ TcTyVars, + with fixed kinds, and accurate skolem info: no unification variables here + + tyConBinders includes the Inferred binders if any + + tyConBinders uses the Names from the original, renamed program. + + - tcTyConScopedTyVars is irrelevant: just use (binderVars tyConBinders) + All the types have been swizzled back to use the original Names + See Note [tyConBinders and lexical scoping] in GHC.Core.TyCon + +The main purpose of these TcTyCons is during kind-checking of +type/class declarations (in GHC.Tc.TyCl). During kind checking we +come upon knowledge of the eventual tycon in bits and pieces, and we +use a TcTyCon to record what we know before we are ready to build the +final TyCon. Here is the plan: + +* Step 1 (inferInitialKinds, called from kcTyClGroup + inference only, skipped for checking): + Make a MonoTcTyCon whose binders are TcTyVars, + that may contain free unification variables. + See Note [No polymorphic recursion in type decls] + +* Step 2 (kcTyClDecl, called from kcTyClGroup) + Kind-check the declarations of the group; this step just does + unifications that affect the unification variables created in + Step 1 + +* Step 3 (generaliseTcTyCon, called from kcTyClGroup) + Generalise that MonoTcTyCon to make a PolyTcTyCon + Its binders are skolem TcTyVars, with accurate SkolemInfo + +* Step 4 (tcTyClDecl, called from tcTyClDecls) + Typecheck the type and class decls to produce a final TyCon + Its binders are final TyVars, not TcTyVars + +Note that a MonoTcTyCon can contain unification variables, but a +PolyTcTyCon does not: only skolem TcTyVars. See the invariants above. + +More details about /kind inference/: + +S1) In kcTyClGroup, we use inferInitialKinds to look over the + declaration of any TyCon that lacks a kind signature or + CUSK, to determine its "shape"; for example, the number of + parameters, and any kind signatures. + + We record that shape record that shape in a MonoTcTyCon; it is + "mono" because it has not been been generalised, and its binders + and result kind may have free unification variables. + +S2) Still in kcTyClGroup, we use kcLTyClDecl to kind-check the + body (class methods, data constructors, etc.) of each of + these MonoTcTyCons, which has the effect of filling in the + metavariables in the tycon's initial kind. + +S3) Still in kcTyClGroup, we use generaliseTyClDecl to generalize + each MonoTcTyCon to get a PolyTcTyCon, with skolem TcTyVars in it, + and a final, fixed kind. + +S4) Finally, back in tcTyClDecls, we extend the environment with + the PolyTcTyCons, and typecheck each declaration (regardless + of kind signatures etc) to get final TyCon. + +More details about /kind checking/ + +S5) In kcTyClGroup, we use checkInitialKinds to get the + utterly-final Kind of all TyCons in the group that + (a) have a standalone kind signature or + (b) have a CUSK. + This produces a PolyTcTyCon, that is, a TcTyCon in which the binders + and result kind are full of TyVars (not TcTyVars). No unification + variables here; everything is in its final form. + +Wrinkles: + +(W1) When recovering from a type error in a type declaration, + we want to put the erroneous TyCon in the environment in a + way that won't lead to more errors. We use a PolyTcTyCon for this; + see makeRecoveryTyCon. + +(W2) tyConScopedTyVars. A challenging piece in all of this is that we + end up taking three separate passes over every declaration: + - one in inferInitialKind (this pass look only at the head, not the body) + - one in kcTyClDecls (to kind-check the body) + - a final one in tcTyClDecls (to desugar) + + In the latter two passes, we need to connect the user-written type + variables in an LHsQTyVars with the variables in the tycon's + inferred kind. Because the tycon might not have a CUSK, this + matching up is, in general, quite hard to do. (Look through the + git history between Dec 2015 and Apr 2016 for + GHC.Tc.Gen.HsType.splitTelescopeTvs!) + + Instead of trying, we just store the list of type variables to + bring into scope, in the tyConScopedTyVars field of a MonoTcTyCon. + These tyvars are brought into scope by the calls to + tcExtendNameTyVarEnv (tcTyConScopedTyVars tycon) + in kcTyClDecl. + + In a TcTyCon, why is tyConScopedTyVars :: [(Name,TcTyVar)] rather + than just [TcTyVar]? Consider these mutually-recursive decls + data T (a :: k1) b = MkT (S a b) + data S (c :: k2) d = MkS (T c d) + We start with k1 bound to kappa1, and k2 to kappa2; so initially + in the (Name,TcTyVar) pairs the Name is that of the TcTyVar. But + then kappa1 and kappa2 get unified; so after the zonking in + 'generalise' in 'kcTyClGroup' the Name and TcTyVar may differ. + +See also Note [Type checking recursive type and class declarations]. + +Note [No polymorphic recursion in type decls] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In GHC.Tc.HsType.kcInferDeclHeader we use mkAnonTyConBinders to make +the TyConBinders for the MonoTcTyCon. Here is why. + +Should this kind-check (cf #16344)? + data T ka (a::ka) b = MkT (T Type Int Bool) + (T (Type -> Type) Maybe Bool) + +Notice that T is used at two different kinds in its RHS. No! +This should not kind-check. Polymorphic recursion is known to +be a tough nut. + +Many moons ago, we laboriously (with help from the renamer) tried to give T +the polymorphic kind + T :: forall ka -> ka -> kappa -> Type +where kappa is a unification variable, even in the inferInitialKinds phase +(which is what kcInferDeclHeader is all about). But that is dangerously +fragile (see #16344), because `kappa` might get unified with `ka`, and +depending on just /when/ that unification happens, the instantiation of T's +kind would vary between different call sites of T. + +We encountered similar trickiness with invisible binders in type +declarations: see Note [No inference for invisible binders in type decls] + +Solution: the Monomorphic Recursion Principle: + + A MonoTcTyCon has a monomoprhic kind (no foralls!) + +See the invariants on MonoTcTyCon in Note [TcTyCon, MonoTcTyCon, and PolyTcTyCon]. + +So kcInferDeclHeader gives T a straightforward monomorphic kind, with no +quantification whatsoever. That's why we always use mkAnonTyConBinder for +all arguments when figuring out tc_binders. + +But notice that (#16344 comment:3) + +* Consider this declaration: + data T2 ka (a::ka) = MkT2 (T2 Type a) + + Starting with inferInitialKinds + (Step 1 of Note [TcTyCon, MonoTcTyCon, and PolyTcTyCon]): + MonoTcTyCon binders: + ka[tyv] :: (kappa1[tau] :: Type) + a[tyv] :: (ka[tyv] :: Type) + MonoTcTyCon kind: + T2 :: kappa1[tau] -> ka[tyv] -> Type + + Given this kind for T2, in Step 2 we kind-check (T2 Type a) + from where we see + T2's first arg: (kappa1 ~ Type) + T2's second arg: (ka ~ ka) + These constraints are soluble by (kappa1 := Type) + so generaliseTcTyCon (Step 3) gives + T2 :: forall (k::Type) -> k -> * + + But now the /typechecking/ (Step 4, aka desugaring, tcTyClDecl) + phase fails, because the call (T2 Type a) in the RHS is ill-kinded. + + We'd really prefer all errors to show up in the kind checking phase. + +* This algorithm still accepts (in all phases) + data T3 ka (a::ka) = forall b. MkT3 (T3 Type b) + although T3 is really polymorphic-recursive too. + Perhaps we should somehow reject that. + +Note [No inference for invisible binders in type decls] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we have (#22560): + data T @k (a::k) = MkT (...(T ty)...) +What monokind can we give to T after step 1 of the kind inference +algorithm described in Note [TcTyCon, MonoTcTyCon, and PolyTcTyCon]? +Remember: Step 1 generates a MonoTcTyCon. + +It can't be + T :: kappa1 -> kappa2 -> Type +because the invocation `(T ty)` doesn't have a visible argument for `kappa`. +Nor can it be + T :: forall k. kappa2 -> Type +because that breaks the Monomorphic Recursion Principle: MonoTcTyCons have +monomorphic kinds; see Note [No polymorphic recursion in type decls]. It could be + T :: kappa1 ->. kappa2 -> type +where `->.` is a new kind of arrow in kinds, which (like a type-class argument +in terms) is invisibly instantiated. Or we could fake it with + T :: forall _. kappa2 -> Type +where `_` is a completely fresh variable, but that seems very smelly and makes it +harder to talk about the Monomorphic Recursion Principle. Moreover we'd need +some extra fancy types in TyConBinders to record this extra information. + +Note that in *terms* we do not allow + f @a (x::a) = rhs +unless `f` has a type signature. So we do the same for types: + + We allow `@` binders in data type declarations ONLY if the + type constructor has a standalone kind signature (or a CUSK). + +That means that GHC.Tc.Gen.HsType.kcInferDeclHeader, which is used when we +don't have a kind signature or CUSK, and builds a MonoTcTyCon, we can simply +reject invisible binders outright (GHC.Tc.Gen.HsType.rejectInvisibleBinders); +and continue to use mkAnonTyConBinders as described in +Note [No polymorphic recursion in type decls]. + +If we get cries of pain we can revist this decision. + +Note [CUSKs and PolyKinds] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + + data T (a :: *) = MkT (S a) -- Has CUSK + data S a = MkS (T Int) (S a) -- No CUSK + +Via inferInitialKinds we get + T :: * -> * + S :: kappa -> * + +Then we call kcTyClDecl on each decl in the group, to constrain the +kind unification variables. BUT we /skip/ the RHS of any decl with +a CUSK. Here we skip the RHS of T, so we eventually get + S :: forall k. k -> * + +This gets us more polymorphism than we would otherwise get, similar +(but implemented strangely differently from) the treatment of type +signatures in value declarations. + +However, we only want to do so when we have PolyKinds. +When we have NoPolyKinds, we don't skip those decls, because we have defaulting +(#16609). Skipping won't bring us more polymorphism when we have defaulting. +Consider + + data T1 a = MkT1 T2 -- No CUSK + data T2 = MkT2 (T1 Maybe) -- Has CUSK + +If we skip the rhs of T2 during kind-checking, the kind of a remains unsolved. +With PolyKinds, we do generalization to get T1 :: forall a. a -> *. And the +program type-checks. +But with NoPolyKinds, we do defaulting to get T1 :: * -> *. Defaulting happens +in quantifyTyVars, which is called from generaliseTcTyCon. Then type-checking +(T1 Maybe) will throw a type error. + +Summary: with PolyKinds, we must skip; with NoPolyKinds, we must /not/ skip. + +Open type families +~~~~~~~~~~~~~~~~~~ +This treatment of type synonyms only applies to Haskell 98-style synonyms. +General type functions can be recursive, and hence, appear in `alg_decls'. + +The kind of an open type family is solely determined by its kind signature; +hence, only kind signatures participate in the construction of the initial +kind environment (as constructed by `inferInitialKind'). In fact, we ignore +instances of families altogether in the following. However, we need to include +the kinds of *associated* families into the construction of the initial kind +environment. (This is handled by `allDecls'). + +See also Note [Kind checking recursive type and class declarations] + +Note [Swizzling the tyvars before generaliseTcTyCon] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +This Note only applies when /inferring/ the kind of a TyCon. +If there is a separate kind signature, or a CUSK, we take an entirely +different code path. + +For inference, consider + class C (f :: k) x where + type T f + op :: D f => blah + class D (g :: j) y where + op :: C g => y -> blah + +Here C and D are considered mutually recursive. Neither has a CUSK. +Just before generalisation we have the (un-quantified) kinds + C :: k1 -> k2 -> Constraint + T :: k1 -> Type + D :: k1 -> Type -> Constraint +Notice that f's kind and g's kind have been unified to 'k1'. We say +that k1 is the "representative" of k in C's decl, and of j in D's decl. + +Now when quantifying, we'd like to end up with + C :: forall {k2}. forall k. k -> k2 -> Constraint + T :: forall k. k -> Type + D :: forall j. j -> Type -> Constraint + +That is, we want to swizzle the representative to have the Name given +by the user. Partly this is to improve error messages and the output of +:info in GHCi. But it is /also/ important because the code for a +default method may mention the class variable(s), but at that point +(tcClassDecl2), we only have the final class tyvars available. +(Alternatively, we could record the scoped type variables in the +TyCon, but it's a nuisance to do so.) + +Notes: + +* On the input to generaliseTyClDecl, the mapping between the + user-specified Name and the representative TyVar is recorded in the + tyConScopedTyVars of the TcTyCon. NB: you first need to zonk to see + this representative TyVar. + +* The swizzling is actually performed by swizzleTcTyConBndrs + +* We must do the swizzling across the whole class decl. Consider + class C f where + type S (f :: k) + type T f + Here f's kind k is a parameter of C, and its identity is shared + with S and T. So if we swizzle the representative k at all, we + must do so consistently for the entire declaration. + + Hence the call to check_duplicate_tc_binders is in generaliseTyClDecl, + rather than in generaliseTcTyCon. + +There are errors to catch here. Suppose we had + class E (f :: j) (g :: k) where + op :: SameKind f g -> blah + +Then, just before generalisation we will have the (unquantified) + E :: k1 -> k1 -> Constraint + +That's bad! Two distinctly-named tyvars (j and k) have ended up with +the same representative k1. So when swizzling, we check (in +check_duplicate_tc_binders) that two distinct source names map +to the same representative. + +Here's an interesting case: + class C1 f where + type S (f :: k1) + type T (f :: k2) +Here k1 and k2 are different Names, but they end up mapped to the +same representative TyVar. To make the swizzling consistent (remember +we must have a single k across C1, S and T) we reject the program. + +Another interesting case + class C2 f where + type S (f :: k) (p::Type) + type T (f :: k) (p::Type->Type) + +Here the two k's (and the two p's) get distinct Uniques, because they +are seen by the renamer as locally bound in S and T resp. But again +the two (distinct) k's end up bound to the same representative TyVar. +You might argue that this should be accepted, but it's definitely +rejected (via an entirely different code path) if you add a kind sig: + type C2' :: j -> Constraint + class C2' f where + type S (f :: k) (p::Type) +We get + • Expected kind ‘j’, but ‘f’ has kind ‘k’ + • In the associated type family declaration for ‘S’ + +So we reject C2 too, even without the kind signature. We have +to do a bit of work to get a good error message, since both k's +look the same to the user. + +Another case + class C3 (f :: k1) where + type S (f :: k2) + +This will be rejected too. + + +Note [Type environment evolution] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +As we typecheck a group of declarations the type environment evolves. +Consider for example: + data B (a :: Type) = MkB (Proxy 'MkB) + +We do the following steps: + + 1. Start of tcTyClDecls: use mkPromotionErrorEnv to initialise the + type env with promotion errors + B :-> TyConPE + MkB :-> DataConPE + + 2. kcTyCLGroup + - Do inferInitialKinds, which will signal a promotion + error if B is used in any of the kinds needed to initialise + B's kind (e.g. (a :: Type)) here + + - Extend the type env with these initial kinds (monomorphic for + decls that lack a CUSK) + B :-> TcTyCon + (thereby overriding the B :-> TyConPE binding) + and do kcLTyClDecl on each decl to get equality constraints on + all those initial kinds + + - Generalise the initial kind, making a poly-kinded TcTyCon + + 3. Back in tcTyDecls, extend the envt with bindings of the poly-kinded + TcTyCons, again overriding the promotion-error bindings. + + But note that the data constructor promotion errors are still in place + so that (in our example) a use of MkB will still be signalled as + an error. + + 4. Typecheck the decls. + + 5. In tcTyClGroup, extend the envt with bindings for TyCon and DataCons + + +Note [Missed opportunity to retain higher-rank kinds] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In 'kcTyClGroup', there is a missed opportunity to make kind +inference work in a few more cases. The idea is analogous +to Note [Special case for non-recursive function bindings]: + + * If we have an SCC with a single decl, which is non-recursive, + instead of creating a unification variable representing the + kind of the decl and unifying it with the rhs, we can just + read the type directly of the rhs. + + * Furthermore, we can update our SCC analysis to ignore + dependencies on declarations which have CUSKs: we don't + have to kind-check these all at once, since we can use + the CUSK to initialize the kind environment. + +Unfortunately this requires reworking a bit of the code in +'kcLTyClDecl' so I've decided to punt unless someone shouts about it. + +Note [Don't process associated types in getInitialKind] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Previously, we processed associated types in the thing_inside in getInitialKind, +but this was wrong -- we want to do ATs separately. +The consequence for not doing it this way is #15142: + + class ListTuple (tuple :: Type) (as :: [(k, Type)]) where + type ListToTuple as :: Type + +We assign k a kind kappa[1]. When checking the tuple (k, Type), we try to unify +kappa ~ Type, but this gets deferred because we bumped the TcLevel as we bring +`tuple` into scope. Thus, when we check ListToTuple, kappa[1] still hasn't +unified with Type. And then, when we generalize the kind of ListToTuple (which +indeed has a CUSK, according to the rules), we skolemize the free metavariable +kappa. Note that we wouldn't skolemize kappa when generalizing the kind of ListTuple, +because the solveEqualities in kcInferDeclHeader is at TcLevel 1 and so kappa[1] +will unify with Type. + +Bottom line: as associated types should have no effect on a CUSK enclosing class, +we move processing them to a separate action, run after the outer kind has +been generalized. + +-} + +kcTyClGroup :: KindSigEnv -> [LTyClDecl GhcRn] -> TcM ([PolyTcTyCon], NameSet) + +-- Kind check this group, kind generalize, and return the resulting local env +-- This binds the TyCons and Classes of the group, but not the DataCons +-- See Note [Kind checking for type and class decls] +-- and Note [Inferring kinds for type declarations] +-- +-- The NameSet returned contains kindless tycon names, without CUSK or SAKS. +kcTyClGroup kisig_env decls + = do { mod <- getModule + ; traceTc "---- kcTyClGroup ---- {" + (text "module" <+> ppr mod $$ vcat (map ppr decls)) + + -- Kind checking; + -- 1. Bind kind variables for decls + -- 2. Kind-check decls + -- 3. Generalise the inferred kinds + -- See Note [Kind checking for type and class decls] + + ; cusks_enabled <- xoptM LangExt.CUSKs <&&> xoptM LangExt.PolyKinds + -- See Note [CUSKs and PolyKinds] + ; let (kindless_decls, kinded_decls) = partitionWith get_kind decls + kindless_names = mkNameSet $ map get_name kindless_decls + + get_name d = tcdName (unLoc d) + + get_kind d + | Just ki <- lookupNameEnv kisig_env (get_name d) + = Right (d, SAKS ki) + + | cusks_enabled && hsDeclHasCusk (unLoc d) + = Right (d, CUSK) + + | otherwise = Left d + + ; checked_tcs <- checkNoErrs $ + checkInitialKinds kinded_decls + -- checkNoErrs because we are about to extend + -- the envt with these tycons, and we get + -- knock-on errors if we have tycons with + -- malformed kinds + + ; inferred_tcs + <- tcExtendKindEnvWithTyCons checked_tcs $ + pushLevelAndSolveEqualities unkSkolAnon [] $ + -- We are going to kind-generalise, so unification + -- variables in here must be one level in + do { -- Step 1: Bind kind variables for all decls + mono_tcs <- inferInitialKinds kindless_decls + + ; traceTc "kcTyClGroup: initial kinds" $ + ppr_tc_kinds mono_tcs + + -- Step 2: Set extended envt, kind-check the decls + -- NB: the environment extension overrides the tycon + -- promotion-errors bindings + -- See Note [Type environment evolution] + ; checkNoErrs $ + tcExtendKindEnvWithTyCons mono_tcs $ + mapM_ kcLTyClDecl kindless_decls + + ; return mono_tcs } + + -- Step 3: generalisation + -- Finally, go through each tycon and give it its final kind, + -- with all the required, specified, and inferred variables + -- in order. + ; let inferred_tc_env = mkNameEnv $ + map (\tc -> (tyConName tc, tc)) inferred_tcs + ; generalized_tcs <- concatMapM (generaliseTyClDecl inferred_tc_env) + kindless_decls + + ; let poly_tcs = checked_tcs ++ generalized_tcs + ; traceTc "---- kcTyClGroup end ---- }" (ppr_tc_kinds poly_tcs) + ; return (poly_tcs, kindless_names) } + where + ppr_tc_kinds tcs = vcat (map pp_tc tcs) + pp_tc tc = ppr (tyConName tc) <+> dcolon <+> ppr (tyConKind tc) + +type ScopedPairs = [(Name, TcTyVar)] + -- The ScopedPairs for a TcTyCon are precisely + -- specified-tvs ++ required-tvs + -- You can distinguish them because there are tyConArity required-tvs + +generaliseTyClDecl :: NameEnv MonoTcTyCon -> LTyClDecl GhcRn -> TcM [PolyTcTyCon] +-- See Note [Swizzling the tyvars before generaliseTcTyCon] +generaliseTyClDecl inferred_tc_env (L _ decl) + = do { let names_in_this_decl :: [Name] + names_in_this_decl = tycld_names decl + + ; tc_infos <- liftZonkM $ + do { -- Extract the specified/required binders and skolemise them + ; tc_with_tvs <- mapM skolemise_tc_tycon names_in_this_decl + + -- Zonk, to manifest the side-effects of skolemisation to the swizzler + -- NB: it's important to skolemise them all before this step. E.g. + -- class C f where { type T (f :: k) } + -- We only skolemise k when looking at T's binders, + -- but k appears in f's kind in C's binders. + ; mapM zonk_tc_tycon tc_with_tvs } + + -- Swizzle + ; swizzled_infos <- tcAddDeclCtxt decl (swizzleTcTyConBndrs tc_infos) + + -- And finally generalise + ; mapAndReportM generaliseTcTyCon swizzled_infos } + where + tycld_names :: TyClDecl GhcRn -> [Name] + tycld_names decl = tcdName decl : at_names decl + + at_names :: TyClDecl GhcRn -> [Name] + at_names (ClassDecl { tcdATs = ats }) = map (familyDeclName . unLoc) ats + at_names _ = [] -- Only class decls have associated types + + skolemise_tc_tycon :: Name -> ZonkM (TcTyCon, SkolemInfo, ScopedPairs) + -- Zonk and skolemise the Specified and Required binders + skolemise_tc_tycon tc_name + = do { let tc = lookupNameEnv_NF inferred_tc_env tc_name + -- This lookup should not fail + ; skol_info <- mkSkolemInfo (TyConSkol (tyConFlavour tc) tc_name ) + ; scoped_prs <- mapSndM (zonkAndSkolemise skol_info) (tcTyConScopedTyVars tc) + ; return (tc, skol_info, scoped_prs) } + + zonk_tc_tycon :: (TcTyCon, SkolemInfo, ScopedPairs) + -> ZonkM (TcTyCon, SkolemInfo, ScopedPairs, TcKind) + zonk_tc_tycon (tc, skol_info, scoped_prs) + = do { scoped_prs <- mapSndM zonkTcTyVarToTcTyVar scoped_prs + -- We really have to do this again, even though + -- we have just done zonkAndSkolemise, so that + -- occurrences in the /kinds/ get zonked to the skolem + ; res_kind <- zonkTcType (tyConResKind tc) + ; return (tc, skol_info, scoped_prs, res_kind) } + +swizzleTcTyConBndrs :: [(TcTyCon, SkolemInfo, ScopedPairs, TcKind)] + -> TcM [(TcTyCon, SkolemInfo, ScopedPairs, TcKind)] +swizzleTcTyConBndrs tc_infos + | all no_swizzle swizzle_prs + -- This fast path happens almost all the time + -- See Note [Cloning for type variable binders] in GHC.Tc.Gen.HsType + -- "Almost all the time" means not the case of mutual recursion with + -- polymorphic kinds. + = do { traceTc "Skipping swizzleTcTyConBndrs for" (ppr_infos tc_infos) + ; return tc_infos } + + | otherwise + = do { checkForDuplicateScopedTyVars swizzle_prs + + ; traceTc "swizzleTcTyConBndrs" $ + vcat [ text "before" <+> ppr_infos tc_infos + , text "swizzle_prs" <+> ppr swizzle_prs + , text "after" <+> ppr_infos swizzled_infos ] + + ; return swizzled_infos } + + where + swizzled_infos = [ (tc, skol_info, mapSnd swizzle_var scoped_prs, swizzle_ty kind) + | (tc, skol_info, scoped_prs, kind) <- tc_infos ] + + swizzle_prs :: [(Name,TyVar)] + -- Pairs the user-specified Name with its representative TyVar + -- See Note [Swizzling the tyvars before generaliseTcTyCon] + swizzle_prs = [ pr | (_, _, prs, _) <- tc_infos, pr <- prs ] + + no_swizzle :: (Name,TyVar) -> Bool + no_swizzle (nm, tv) = nm == tyVarName tv + + ppr_infos infos = vcat [ ppr tc <+> pprTyVars (map snd prs) + | (tc, _, prs, _) <- infos ] + + -------------- The swizzler ------------ + -- This does a deep traverse, simply doing a + -- Name-to-Name change, governed by swizzle_env + -- The 'swap' is what gets from the representative TyVar + -- back to the original user-specified Name + swizzle_env = mkVarEnv (map swap swizzle_prs) + + swizzleMapper :: TyCoMapper () Identity + swizzleMapper = TyCoMapper { tcm_tyvar = swizzle_tv + , tcm_covar = swizzle_cv + , tcm_hole = swizzle_hole + , tcm_tycobinder = swizzle_bndr + , tcm_tycon = swizzle_tycon } + swizzle_hole _ hole = pprPanic "swizzle_hole" (ppr hole) + -- These types are pre-zonked + swizzle_tycon tc = pprPanic "swizzle_tc" (ppr tc) + -- TcTyCons can't appear in kinds (yet) + swizzle_tv _ tv = return (mkTyVarTy (swizzle_var tv)) + swizzle_cv _ cv = return (mkCoVarCo (swizzle_var cv)) + + swizzle_bndr :: () + -> TyCoVar + -> ForAllTyFlag + -> (() -> TyCoVar -> Identity r) + -> Identity r + swizzle_bndr _ tcv _ k + = k () (swizzle_var tcv) + + swizzle_var :: Var -> Var + swizzle_var v + | Just nm <- lookupVarEnv swizzle_env v + = updateVarType swizzle_ty (v `setVarName` nm) + | otherwise + = updateVarType swizzle_ty v + + (map_type, _, _, _) = mapTyCo swizzleMapper + swizzle_ty ty = runIdentity (map_type ty) + + +generaliseTcTyCon :: (MonoTcTyCon, SkolemInfo, ScopedPairs, TcKind) -> TcM PolyTcTyCon +generaliseTcTyCon (tc, skol_info, scoped_prs, tc_res_kind) + -- The scoped_prs are fully zonked skolem TcTyVars + -- And tc_res_kind is fully zonked too + -- See Note [Required, Specified, and Inferred for types] + = setSrcSpan (getSrcSpan tc) $ + addTyConCtxt tc $ + do { -- Step 1: Separate Specified from Required variables + -- NB: spec_req_tvs = spec_tvs ++ req_tvs + -- And req_tvs is 1-1 with tyConTyVars + -- See Note [Scoped tyvars in a TcTyCon] in GHC.Core.TyCon + ; let spec_req_tvs = map snd scoped_prs + n_spec = length spec_req_tvs - tyConArity tc + (spec_tvs, req_tvs) = splitAt n_spec spec_req_tvs + sorted_spec_tvs = scopedSort spec_tvs + -- NB: We can't do the sort until we've zonked + -- Maintain the L-R order of scoped_tvs + + -- Step 2a: find all the Inferred variables we want to quantify over + ; dvs1 <- candidateQTyVarsOfKinds $ + (tc_res_kind : map tyVarKind spec_req_tvs) + ; let dvs2 = dvs1 `delCandidates` spec_req_tvs + + -- Step 2b: quantify, mainly meaning skolemise the free variables + -- Returned 'inferred' are scope-sorted and skolemised + ; inferred <- quantifyTyVars skol_info DefaultNonStandardTyVars dvs2 + + ; traceTc "generaliseTcTyCon: pre zonk" + (vcat [ text "tycon =" <+> ppr tc + , text "spec_req_tvs =" <+> pprTyVars spec_req_tvs + , text "tc_res_kind =" <+> ppr tc_res_kind + , text "dvs1 =" <+> ppr dvs1 + , text "inferred =" <+> pprTyVars inferred ]) + + -- Step 3: Final zonk: quantifyTyVars may have done some defaulting + ; (inferred, sorted_spec_tvs,req_tvs,tc_res_kind) <- liftZonkM $ + do { inferred <- zonkTcTyVarsToTcTyVars inferred + ; sorted_spec_tvs <- zonkTcTyVarsToTcTyVars sorted_spec_tvs + ; req_tvs <- zonkTcTyVarsToTcTyVars req_tvs + ; tc_res_kind <- zonkTcType tc_res_kind + ; return (inferred, sorted_spec_tvs, req_tvs, tc_res_kind) } + + ; traceTc "generaliseTcTyCon: post zonk" $ + vcat [ text "tycon =" <+> ppr tc + , text "inferred =" <+> pprTyVars inferred + , text "spec_req_tvs =" <+> pprTyVars spec_req_tvs + , text "sorted_spec_tvs =" <+> pprTyVars sorted_spec_tvs + , text "req_tvs =" <+> ppr req_tvs ] + + -- Step 4: Make the TyConBinders. + ; let dep_fv_set = candidateKindVars dvs1 + inferred_tcbs = mkNamedTyConBinders Inferred inferred + specified_tcbs = mkNamedTyConBinders Specified sorted_spec_tvs + required_tcbs = map (mkRequiredTyConBinder dep_fv_set) req_tvs + + -- Step 5: Assemble the final list. + all_tcbs = concat [ inferred_tcbs + , specified_tcbs + , required_tcbs ] + flav = tyConFlavour tc + + -- Eta expand + ; (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 + tycon = mkTcTyCon (tyConName tc) + final_tcbs tc_res_kind + (mkTyVarNamePairs (sorted_spec_tvs ++ req_tvs)) + True {- it's generalised now -} + flav + + ; traceTc "generaliseTcTyCon done" $ + vcat [ text "tycon =" <+> ppr tc + , text "tc_res_kind =" <+> ppr tc_res_kind + , text "dep_fv_set =" <+> ppr dep_fv_set + , text "inferred_tcbs =" <+> ppr inferred_tcbs + , text "specified_tcbs =" <+> ppr specified_tcbs + , text "required_tcbs =" <+> ppr required_tcbs + , text "final_tcbs =" <+> ppr final_tcbs ] + + -- Step 7: Check for validity. + -- We do this here because we're about to put the tycon into the + -- the environment, and we don't want anything malformed there + ; checkTyConTelescope tycon + + ; return tycon } + +{- Note [Required, Specified, and Inferred for types] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Each forall'd type variable in a type or kind is one of + + * Required: an argument must be provided at every call site + + * Specified: the argument can be inferred at call sites, but + may be instantiated with visible type/kind application + + * Inferred: the argument must be inferred at call sites; it + is unavailable for use with visible type/kind application. + +Why have Inferred at all? Because we just can't make user-facing +promises about the ordering of some variables. These might swizzle +around even between minor released. By forbidding visible type +application, we ensure users aren't caught unawares. + +Go read Note [VarBndrs, ForAllTyBinders, TyConBinders, and visibility] in GHC.Core.TyCo.Rep. + +The question for this Note is this: + given a TyClDecl, how are its quantified type variables classified? +Much of the debate is memorialized in #15743. + +Here is our design choice. When inferring the ordering of variables +for a TyCl declaration (that is, for those variables that the user +has not specified the order with an explicit `forall`), we use the +following order: + + 1. Inferred variables + 2. Specified variables; in the left-to-right order in which + the user wrote them, modified by scopedSort (see below) + to put them in dependency order. + 3. Required variables before a top-level :: + 4. All variables after a top-level :: + +If this ordering does not make a valid telescope, we reject the definition. + +Example: + data SameKind :: k -> k -> * + data Bad a (c :: Proxy b) (d :: Proxy a) (x :: SameKind b d) + +For Bad: + - a, c, d, x are Required; they are explicitly listed by the user + as the positional arguments of Bad + - b is Specified; it appears explicitly in a kind signature + - k, the kind of a, is Inferred; it is not mentioned explicitly at all + +Putting variables in the order Inferred, Specified, Required +gives us this telescope: + Inferred: k + Specified: b : Proxy a + Required : (a : k) (c : Proxy b) (d : Proxy a) (x : SameKind b d) + +But this order is ill-scoped, because b's kind mentions a, which occurs +after b in the telescope. So we reject Bad. + +Associated types +~~~~~~~~~~~~~~~~ +For associated types everything above is determined by the +associated-type declaration alone, ignoring the class header. +Here is an example (#15592) + class C (a :: k) b where + type F (x :: b a) + +In the kind of C, 'k' is Specified. But what about F? +In the kind of F, + + * Should k be Inferred or Specified? It's Specified for C, + but not mentioned in F's declaration. + + * In which order should the Specified variables a and b occur? + It's clearly 'a' then 'b' in C's declaration, but the L-R ordering + in F's declaration is 'b' then 'a'. + +In both cases we make the choice by looking at F's declaration alone, +so it gets the kind + F :: forall {k}. forall b a. b a -> Type + +How it works +~~~~~~~~~~~~ +These design choices are implemented by two completely different code +paths for + + * Declarations with a standalone kind signature or a complete user-specified + kind signature (CUSK). Handled by the kcCheckDeclHeader. + + * Declarations without a kind signature (standalone or CUSK) are handled by + kcInferDeclHeader; see Note [Inferring kinds for type declarations]. + +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 maybeEtaExpandAlgTyCon.) + +We can tell Inferred apart from Specified by looking at the scoped +tyvars; Specified are always included there. + +Design alternatives +~~~~~~~~~~~~~~~~~~~ +* For associated types we considered putting the class variables + before the local variables, in a nod to the treatment for class + methods. But it got too complicated; see #15592, comment:21ff. + +* We rigidly require the ordering above, even though we could be much more + permissive. Relevant musings are at + https://gitlab.haskell.org/ghc/ghc/issues/15743#note_161623 + The bottom line conclusion is that, if the user wants a different ordering, + then can specify it themselves, and it is better to be predictable and dumb + than clever and capricious. + + I (Richard) conjecture we could be fully permissive, allowing all classes + of variables to intermix. We would have to augment ScopedSort to refuse to + reorder Required variables (or check that it wouldn't have). But this would + allow more programs. See #15743 for examples. Interestingly, Idris seems + to allow this intermixing. The intermixing would be fully specified, in that + we can be sure that inference wouldn't change between versions. However, + would users be able to predict it? That I cannot answer. + +Test cases (and tickets) relevant to these design decisions +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + T15591* + T15592* + T15743* + +Note [Inferring kinds for type declarations] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +This note deals with /inference/ for type declarations +that do not have a CUSK or a SAKS. Consider + data T (a :: k1) k2 (x :: k2) = MkT (S a k2 x) + data S (b :: k3) k4 (y :: k4) = MkS (T b k4 y) + +We do kind inference as follows: + +* Step 1: inferInitialKinds, and in particular kcInferDeclHeader. + Make a unification variable for each of the Required and Specified + type variables in the header. + + Record the connection between the Names the user wrote and the + fresh unification variables in the tcTyConScopedTyVars field + of the TcTyCon we are making + [ (a, aa) + , (k1, kk1) + , (k2, kk2) + , (x, xx) ] + (I'm using the convention that double letter like 'aa' or 'kk' + mean a unification variable.) + + These unification variables + - Are TyVarTvs: that is, unification variables that can + unify only with other type variables. + See Note [TyVarTv] in GHC.Tc.Utils.TcMType + + - Have complete fresh Names; see GHC.Tc.Utils.TcMType + Note [Unification variables need fresh Names] + + Assign initial monomorphic kinds to S, T + T :: kk1 -> * -> kk2 -> * + S :: kk3 -> * -> kk4 -> * + +* Step 2: kcTyClDecl. Extend the environment with a TcTyCon for S and + T, with these monomorphic kinds. Now kind-check the declarations, + and solve the resulting equalities. The goal here is to discover + constraints on all these unification variables. + + Here we find that kk1 := kk3, and kk2 := kk4. + + This is why we can't use skolems for kk1 etc; they have to + unify with each other. + +* Step 3: generaliseTcTyCon. Generalise each TyCon in turn. + We find the free variables of the kind, skolemise them, + sort them out into Inferred/Required/Specified (see the above + Note [Required, Specified, and Inferred for types]), + and perform some validity checks. + + This makes the utterly-final TyConBinders for the TyCon. + + All this is very similar at the level of terms: see GHC.Tc.Gen.Bind + Note [Quantified variables in partial type signatures] + + But there are some tricky corners: Note [Tricky scoping in generaliseTcTyCon] + +* Step 4. Extend the type environment with a TcTyCon for S and T, now + with their utterly-final polymorphic kinds (needed for recursive + occurrences of S, T). Now typecheck the declarations, and build the + final AlgTyCon for S and T resp. + +The first three steps are in kcTyClGroup; the fourth is in +tcTyClDecls. + +There are some wrinkles + +* Do not default TyVarTvs. We always want to kind-generalise over + TyVarTvs, and /not/ default them to Type. By definition a TyVarTv is + not allowed to unify with a type; it must stand for a type + variable. Hence the check in GHC.Tc.Solver.defaultTyVarTcS, and + GHC.Tc.Utils.TcMType.defaultTyVar. Here's another example (#14555): + data Exp :: [TYPE rep] -> TYPE rep -> Type where + Lam :: Exp (a:xs) b -> Exp xs (a -> b) + We want to kind-generalise over the 'rep' variable. + #14563 is another example. + +* Duplicate type variables. Consider #11203 + data SameKind :: k -> k -> * + data Q (a :: k1) (b :: k2) c = MkQ (SameKind a b) + Here we will unify k1 with k2, but this time doing so is an error, + because k1 and k2 are bound in the same declaration. + + We spot this during validity checking (checkForDuplicateScopeTyVars), + in generaliseTcTyCon. + +* Required arguments. Even the Required arguments should be made + into TyVarTvs, not skolems. Consider + data T k (a :: k) + Here, k is a Required, dependent variable. For uniformity, it is helpful + to have k be a TyVarTv, in parallel with other dependent variables. + +* Duplicate skolemisation is expected. When generalising in Step 3, + we may find that one of the variables we want to quantify has + already been skolemised. For example, suppose we have already + generalise S. When we come to T we'll find that kk1 (now the same as + kk3) has already been skolemised. + + That's fine -- but it means that + a) when collecting quantification candidates, in + candidateQTyVarsOfKind, we must collect skolems + b) quantifyTyVars should be a no-op on such a skolem + +Note [Tricky scoping in generaliseTcTyCon] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider #16342 + class C (a::ka) x where + cop :: D a x => x -> Proxy a -> Proxy a + cop _ x = x :: Proxy (a::ka) + + class D (b::kb) y where + dop :: C b y => y -> Proxy b -> Proxy b + dop _ x = x :: Proxy (b::kb) + +C and D are mutually recursive, by the time we get to +generaliseTcTyCon we'll have unified kka := kkb. + +But when typechecking the default declarations for 'cop' and 'dop' in +tcDlassDecl2 we need {a, ka} and {b, kb} respectively to be in scope. +But at that point all we have is the utterly-final Class itself. + +Conclusion: the classTyVars of a class must have the same Name as +that originally assigned by the user. In our example, C must have +classTyVars {a, ka, x} while D has classTyVars {a, kb, y}. Despite +the fact that kka and kkb got unified! + +We achieve this sleight of hand in generaliseTcTyCon, using +the specialised function zonkRecTyVarBndrs. We make the call + zonkRecTyVarBndrs [ka,a,x] [kkb,aa,xxx] +where the [ka,a,x] are the Names originally assigned by the user, and +[kkb,aa,xx] are the corresponding (post-zonking, skolemised) TcTyVars. +zonkRecTyVarBndrs builds a recursive ZonkEnv that binds + kkb :-> (ka :: ) + aa :-> (a :: ) + etc +That is, it maps each skolemised TcTyVars to the utterly-final +TyVar to put in the class, with its correct user-specified name. +When generalising D we'll do the same thing, but the ZonkEnv will map + kkb :-> (kb :: ) + bb :-> (b :: ) + etc +Note that 'kkb' again appears in the domain of the mapping, but this +time mapped to 'kb'. That's how C and D end up with differently-named +final TyVars despite the fact that we unified kka:=kkb + +zonkRecTyVarBndrs we need to do knot-tying because of the need to +apply this same substitution to the kind of each. + +Note [Inferring visible dependent quantification] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + + data T k :: k -> Type where + MkT1 :: T Type Int + MkT2 :: T (Type -> Type) Maybe + +This looks like it should work. However, it is polymorphically recursive, +as the uses of T in the constructor types specialize the k in the kind +of T. This trips up our dear users (#17131, #17541), and so we add +a "landmark" context (which cannot be suppressed) whenever we +spot inferred visible dependent quantification (VDQ). + +It's hard to know when we've actually been tripped up by polymorphic recursion +specifically, so we just include a note to users whenever we infer VDQ. The +testsuite did not show up a single spurious inclusion of this message. + +The context is added in addVDQNote, which looks for a visible +TyConBinder that also appears in the TyCon's kind. (I first looked at +the kind for a visible, dependent quantifier, but + Note [No polymorphic recursion in type decls] +in GHC.Tc.Gen.HsType defeats that approach.) addVDQNote is used in +kcTyClDecl, which is used only when inferring the kind of a tycon +(never with a CUSK or SAKS). + +Once upon a time, I (Richard E) thought that the tycon-kind could +not be a forall-type. But this is wrong: data T :: forall k. k -> Type +(with -XNoCUSKs) could end up here. And this is all OK. +-} + +-------------- +tcExtendKindEnvWithTyCons :: [TcTyCon] -> TcM a -> TcM a +tcExtendKindEnvWithTyCons tcs + = tcExtendKindEnvList [ (tyConName tc, ATcTyCon tc) | tc <- tcs ] + +-------------- +mkPromotionErrorEnv :: [LTyClDecl GhcRn] -> TcTypeEnv +-- Maps each tycon/datacon to a suitable promotion error +-- tc :-> APromotionErr TyConPE +-- dc :-> APromotionErr RecDataConPE +-- See Note [Recursion and promoting data constructors] + +mkPromotionErrorEnv decls + = foldr (plusNameEnv . mk_prom_err_env . unLoc) + emptyNameEnv decls + +mk_prom_err_env :: TyClDecl GhcRn -> TcTypeEnv +mk_prom_err_env (ClassDecl { tcdLName = L _ nm, tcdATs = ats }) + = unitNameEnv nm (APromotionErr ClassPE) + `plusNameEnv` + mkNameEnv [ (familyDeclName at, APromotionErr TyConPE) + | L _ at <- ats ] + +mk_prom_err_env (DataDecl { tcdLName = L _ name + , tcdDataDefn = HsDataDefn { dd_cons = cons } }) + = unitNameEnv name (APromotionErr TyConPE) + `plusNameEnv` + mkNameEnv [ (con, APromotionErr conPE) + | L _ con' <- toList cons + , L _ con <- getConNames con' ] + where + -- In a "type data" declaration, the constructors are at the type level. + -- See Note [Type data declarations] in GHC.Rename.Module. + conPE + | isTypeDataDefnCons cons = TyConPE + | otherwise = RecDataConPE + +mk_prom_err_env decl + = unitNameEnv (tcdName decl) (APromotionErr TyConPE) + -- Works for family declarations too + +-------------- +inferInitialKinds :: [LTyClDecl GhcRn] -> TcM [MonoTcTyCon] +-- Returns a TcTyCon for each TyCon bound by the decls, +-- each with its initial kind + +inferInitialKinds decls + = do { traceTc "inferInitialKinds {" $ ppr (map (tcdName . unLoc) decls) + ; tcs <- concatMapM infer_initial_kind decls + ; traceTc "inferInitialKinds done }" empty + ; return tcs } + where + infer_initial_kind = addLocM (getInitialKind InitialKindInfer) + +-- Check type/class declarations against their standalone kind signatures or +-- CUSKs, producing a generalized TcTyCon for each. +checkInitialKinds :: [(LTyClDecl GhcRn, SAKS_or_CUSK)] -> TcM [PolyTcTyCon] +checkInitialKinds decls + = do { traceTc "checkInitialKinds {" $ ppr (mapFst (tcdName . unLoc) decls) + ; tcs <- concatMapM check_initial_kind decls + ; traceTc "checkInitialKinds done }" empty + ; return tcs } + where + check_initial_kind (ldecl, msig) = + addLocM (getInitialKind (InitialKindCheck msig)) ldecl + +-- | Get the initial kind of a TyClDecl, either generalized or non-generalized, +-- depending on the 'InitialKindStrategy'. +getInitialKind :: InitialKindStrategy -> TyClDecl GhcRn -> TcM [TcTyCon] + +-- Allocate a fresh kind variable for each TyCon and Class +-- For each tycon, return a TcTyCon with kind k +-- where k is the kind of tc, derived from the LHS +-- of the definition (and probably including +-- kind unification variables) +-- Example: data T a b = ... +-- return (T, kv1 -> kv2 -> kv3) +-- +-- This pass deals with (ie incorporates into the kind it produces) +-- * The kind signatures on type-variable binders +-- * The result kinds signature on a TyClDecl +-- +-- No family instances are passed to checkInitialKinds/inferInitialKinds +getInitialKind strategy + (ClassDecl { tcdLName = L _ name + , tcdTyVars = ktvs + , tcdATs = ats }) + = do { cls_tc <- kcDeclHeader strategy name ClassFlavour ktvs $ + return (TheKind constraintKind) + -- See Note [Don't process associated types in getInitialKind] + + ; at_tcs <- tcExtendTyVarEnv (tyConTyVars cls_tc) $ + mapM (addLocM (getAssocFamInitialKind cls_tc)) ats + ; return (cls_tc : at_tcs) } + where + getAssocFamInitialKind cls = + case strategy of + InitialKindInfer -> get_fam_decl_initial_kind (Just cls) + InitialKindCheck _ -> check_initial_kind_assoc_fam cls + +getInitialKind strategy + (DataDecl { tcdLName = L _ name + , tcdTyVars = ktvs + , tcdDataDefn = HsDataDefn { dd_kindSig = m_sig, dd_cons = cons } }) + = do { let flav = newOrDataToFlavour (dataDefnConsNewOrData cons) + ctxt = DataKindCtxt name + ; tc <- kcDeclHeader strategy name flav ktvs $ + case m_sig of + Just ksig -> TheKind <$> tcLHsKindSig ctxt ksig + Nothing -> return $ dataDeclDefaultResultKind strategy (dataDefnConsNewOrData cons) + ; return [tc] } + +getInitialKind InitialKindInfer (FamDecl { tcdFam = decl }) + = do { tc <- get_fam_decl_initial_kind Nothing decl + ; return [tc] } + +getInitialKind (InitialKindCheck msig) (FamDecl { tcdFam = + FamilyDecl { fdLName = unLoc -> name + , fdTyVars = ktvs + , fdResultSig = unLoc -> resultSig + , fdInfo = info } } ) + = do { let flav = familyInfoTyConFlavour Nothing info + ctxt = TyFamResKindCtxt name + ; tc <- kcDeclHeader (InitialKindCheck msig) name flav ktvs $ + case famResultKindSignature resultSig of + Just ksig -> TheKind <$> tcLHsKindSig ctxt ksig + Nothing -> + case msig of + CUSK -> return (TheKind liftedTypeKind) + SAKS _ -> return AnyKind + ; return [tc] } + +getInitialKind strategy + (SynDecl { tcdLName = L _ name + , tcdTyVars = ktvs + , tcdRhs = rhs }) + = do { let ctxt = TySynKindCtxt name + ; tc <- kcDeclHeader strategy name TypeSynonymFlavour ktvs $ + case hsTyKindSig rhs of + Just rhs_sig -> TheKind <$> tcLHsKindSig ctxt rhs_sig + Nothing -> return AnyKind + ; return [tc] } + +get_fam_decl_initial_kind + :: Maybe TcTyCon -- ^ Just cls <=> this is an associated family of class cls + -> FamilyDecl GhcRn + -> TcM TcTyCon +get_fam_decl_initial_kind mb_parent_tycon + FamilyDecl { fdLName = L _ name + , fdTyVars = ktvs + , fdResultSig = L _ resultSig + , fdInfo = info } + = kcDeclHeader InitialKindInfer name flav ktvs $ + case resultSig of + 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 + -- by default + | otherwise -> return AnyKind + where + flav = familyInfoTyConFlavour mb_parent_tycon info + ctxt = TyFamResKindCtxt name + +-- See Note [Standalone kind signatures for associated types] +check_initial_kind_assoc_fam + :: TcTyCon -- parent class + -> FamilyDecl GhcRn + -> TcM TcTyCon +check_initial_kind_assoc_fam cls + FamilyDecl + { fdLName = unLoc -> name + , fdTyVars = ktvs + , fdResultSig = unLoc -> resultSig + , fdInfo = info } + = kcDeclHeader (InitialKindCheck CUSK) name flav ktvs $ + case famResultKindSignature resultSig of + Just ksig -> TheKind <$> tcLHsKindSig ctxt ksig + Nothing -> return (TheKind liftedTypeKind) + where + ctxt = TyFamResKindCtxt name + flav = familyInfoTyConFlavour (Just cls) info + +{- Note [Standalone kind signatures for associated types] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +If associated types had standalone kind signatures, would they wear them + +---------------------------+------------------------------ + like this? (OUT) | or like this? (IN) +---------------------------+------------------------------ + type T :: Type -> Type | class C a where + class C a where | type T :: Type -> Type + type T a | type T a + +The (IN) variant is syntactically ambiguous: + + class C a where + type T :: a -- standalone kind signature? + type T :: a -- declaration header? + +The (OUT) variant does not suffer from this issue, but it might not be the +direction in which we want to take Haskell: we seek to unify type families and +functions, and, by extension, associated types with class methods. And yet we +give class methods their signatures inside the class, not outside. Neither do +we have the counterpart of InstanceSigs for StandaloneKindSignatures. + +For now, we dodge the question by using CUSKs for associated types instead of +standalone kind signatures. This is a simple addition to the rule we used to +have before standalone kind signatures: + + old rule: associated type has a CUSK iff its parent class has a CUSK + new rule: associated type has a CUSK iff its parent class has a CUSK or a standalone kind signature + +-} + +-- See Note [Data declaration default result kind] +dataDeclDefaultResultKind :: InitialKindStrategy -> NewOrData -> ContextKind +dataDeclDefaultResultKind strategy new_or_data + | NewType <- new_or_data + = OpenKind -- See Note [Implementation of UnliftedNewtypes], point . + | DataType <- new_or_data + , InitialKindCheck (SAKS _) <- strategy + = OpenKind -- See Note [Implementation of UnliftedDatatypes] + | otherwise + = TheKind liftedTypeKind + +{- Note [Data declaration default result kind] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When the user has not written an inline result kind annotation on a data +declaration, we assume it to be 'Type'. That is, the following declarations +D1 and D2 are considered equivalent: + + data D1 where ... + data D2 :: Type where ... + +The consequence of this assumption is that we reject D3 even though we +accept D4: + + data D3 where + MkD3 :: ... -> D3 param + + data D4 :: Type -> Type where + MkD4 :: ... -> D4 param + +However, there are two twists: + + * For unlifted newtypes, we must relax the assumed result kind to (TYPE r): + + newtype D5 where + MkD5 :: Int# -> D5 + + See Note [Implementation of UnliftedNewtypes], STEP 1 and it's sub-note + . + + * For unlifted datatypes, we must relax the assumed result kind to + (TYPE (BoxedRep l)) in the presence of a SAKS: + + type D6 :: Type -> TYPE (BoxedRep Unlifted) + data D6 a = MkD6 a + + Otherwise, it would be impossible to declare unlifted data types in H98 + syntax (which doesn't allow specification of a result kind). + +-} + +------------------------------------------------------------------------ +kcLTyClDecl :: LTyClDecl GhcRn -> TcM () + -- See Note [Kind checking for type and class decls] + -- Called only for declarations without a signature (no CUSKs or SAKs here) +kcLTyClDecl (L loc decl) + = setSrcSpanA loc $ + do { tycon <- tcLookupTcTyCon tc_name -- Always a MonoTcTyCon + ; traceTc "kcTyClDecl {" (ppr tc_name) + ; addVDQNote tycon $ -- See Note [Inferring visible dependent quantification] + addErrCtxt (tcMkDeclCtxt decl) $ + kcTyClDecl decl tycon + ; traceTc "kcTyClDecl done }" (ppr tc_name) } + where + tc_name = tcdName decl + +kcTyClDecl :: TyClDecl GhcRn -> MonoTcTyCon -> TcM () +-- This function is used solely for its side effect on kind variables +-- NB kind signatures on the type variables and +-- result kind signature have already been dealt with +-- by inferInitialKind, so we can ignore them here. + +-- NB these equations just extend the type environment with carefully constructed +-- TcTyVars rather than create skolemised variables for the bound variables. +-- - inferInitialKinds makes the TcTyCon where the tyvars are TcTyVars +-- - 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 + = 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, + -- and the ones from this bindTyClTyVars are either not mentioned or + -- (conceivably) shadowed. + do { traceTc "kcTyClDecl" (ppr tycon $$ ppr (tyConTyVars tycon) $$ ppr (tyConResKind tycon)) + ; _ <- tcHsContext ctxt + ; kcConDecls (tyConResKind tycon) cons + } + +kcTyClDecl (SynDecl { tcdLName = L _ _name, tcdRhs = rhs }) tycon + = tcExtendNameTyVarEnv (tcTyConScopedTyVars tycon) $ + let res_kind = tyConResKind tycon + in discardResult $ tcCheckLHsTypeInContext rhs (TheKind res_kind) + -- NB: check against the result kind that we allocated + -- in inferInitialKinds. + +kcTyClDecl (ClassDecl { tcdLName = L _ _name + , tcdCtxt = ctxt, tcdSigs = sigs }) tycon + = tcExtendNameTyVarEnv (tcTyConScopedTyVars tycon) $ + do { _ <- tcHsContext ctxt + ; mapM_ (wrapLocMA_ kc_sig) sigs } + where + kc_sig (ClassOpSig _ _ nms op_ty) = kcClassSigType nms op_ty + kc_sig _ = return () + +kcTyClDecl (FamDecl _ (FamilyDecl { fdInfo = fd_info })) fam_tc +-- closed type families look at their equations, but other families don't +-- do anything here + = case fd_info of + ClosedTypeFamily (Just eqns) -> mapM_ (kcTyFamInstEqn fam_tc) eqns + _ -> return () + +------------------- + +-- Kind-check the types of the arguments to a data constructor. +-- 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 :: 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 :: 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 :: 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 :: TcKind -- Result kind of tycon + -- Used only in H98 case + -> DataDefnCons (LConDecl GhcRn) -> TcM () +-- See Note [kcConDecls: kind-checking data type decls] +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 -> 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 + ; 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 + -- 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 (DataConDefCtxt names) $ + -- Not sure this is right, should just extend rather than skolemise but no test + bind_con_tvbs outer_bndrs inner_bndrs $ + do { _ <- tcHsContext cxt + ; traceTc "kcConDecl:GADT {" (ppr names $$ ppr res_ty) + ; con_res_kind <- newOpenTypeKind + ; _ <- tcCheckLHsTypeInContext res_ty (TheKind con_res_kind) + + ; 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. The basic plan is described in +Note [Inferring kinds for type declarations]; here we are doing Step 2. + +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`. + +There are two cases to consider in `kcConDecl` + +* Haskell 98 data constructors, as above. We simply bring `f` and `a` + into scope and kind-check the data constructors. + +* 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. + +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 + + data Proxy a where + MkProxy1 :: forall k (b :: k). Proxy b + MkProxy2 :: forall j (c :: j). Proxy c + +It seems reasonable that this should be accepted. But something very strange +is going on here: when we're kind-checking this declaration, we need to unify +the kind of `a` with k and j -- even though k and j's scopes are local to the type of +MkProxy{1,2}. + +In effect, we are simply gathering constraints on the shape of Proxy's +kind, with no skolemisation or implication constraints involved at all. + +The best approach we've come up with is to use TyVarTvs during the +kind-checking pass, rather than ordinary skolems. This is why we use +the "_Tv" variant, bindOuterSigTKBndrs_Tv. + +Our only goal is to gather constraints on the kind of the type constructor; +we do not certify that the data declaration is well-kinded. For example: + + data SameKind :: k -> k -> Type + data Bad a where + MkBad :: forall k1 k2 (a :: k1) (b :: k2). Bad (SameKind a b) + +which would be accepted by kcConDecl because k1 and k2 are +TyVarTvs. It is correctly rejected in the second pass, tcConDecl. +(Test case: polykinds/TyVarTvKinds3) + +One drawback of this approach is sometimes it will accept a definition that +a (hypothetical) declarative specification would likely reject. As a general +rule, we don't want to allow polymorphic recursion without a CUSK. Indeed, +the whole point of CUSKs is to allow polymorphic recursion. Yet, the TyVarTvs +approach allows a limited form of polymorphic recursion *without* a CUSK. + +To wit: + data T a = forall k (b :: k). MkT (T b) Int + (test case: dependent/should_compile/T14066a) + +Note that this is polymorphically recursive, with the recursive occurrence +of T used at a kind other than a's kind. The approach outlined here accepts +this definition, because this kind is still a kind variable (and so the +TyVarTvs unify). Stepping back, I (Richard) have a hard time envisioning a +way to describe exactly what declarations will be accepted and which will +be rejected (without a CUSK). However, the accepted definitions are indeed +well-kinded and any rejected definitions would be accepted with a CUSK, +and so this wrinkle need not cause anyone to lose sleep. + +Note [Recursion and promoting data constructors] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We don't want to allow promotion in a strongly connected component +when kind checking. + +Consider: + data T f = K (f (K Any)) + +When kind checking the `data T' declaration the local env contains the +mappings: + T -> ATcTyCon + K -> APromotionErr + +APromotionErr is only used for DataCons, and only used during type checking +in tcTyClGroup. + +The same restriction applies constructors in to "type data" declarations. +See Note [Type data declarations] in GHC.Rename.Module. + + +************************************************************************ +* * +\subsection{Type checking} +* * +************************************************************************ + +Note [Type checking recursive type and class declarations] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +At this point we have completed *kind-checking* of a mutually +recursive group of type/class decls (done in kcTyClGroup). However, +we discarded the kind-checked types (eg RHSs of data type decls); +note that kcTyClDecl returns (). There are two reasons: + + * It's convenient, because we don't have to rebuild a + kinded HsDecl (a fairly elaborate type) + + * It's necessary, because after kind-generalisation, the + TyCons/Classes may now be kind-polymorphic, and hence need + to be given kind arguments. + +Example: + data T f a = MkT (f a) (T f a) +During kind-checking, we give T the kind T :: k1 -> k2 -> * +and figure out constraints on k1, k2 etc. Then we generalise +to get T :: forall k. (k->*) -> k -> * +So now the (T f a) in the RHS must be elaborated to (T k f a). + +However, during tcTyClDecl of T (above) we will be in a recursive +"knot". So we aren't allowed to look at the TyCon T itself; we are only +allowed to put it (lazily) in the returned structures. But when +kind-checking the RHS of T's decl, we *do* need to know T's kind (so +that we can correctly elaborate (T k f a). How can we get T's kind +without looking at T? Delicate answer: during tcTyClDecl, we extend + + *Global* env with T -> ATyCon (the (not yet built) final TyCon for T) + *Local* env with T -> ATcTyCon (TcTyCon with the polymorphic kind of T) + +Then: + + * During GHC.Tc.Gen.HsType.tcTyVar we look in the *local* env, to get the + fully-known, not knot-tied TcTyCon for T. + + * Then, in GHC.Tc.Zonk.Type.zonkTcTypeToType (and zonkTcTyCon in particular) + we look in the *global* env to get the TyCon. + +This fancy footwork (with two bindings for T) is only necessary for the +TyCons or Classes of this recursive group. Earlier, finished groups, +live in the global env only. + +See also Note [Kind checking recursive type and class declarations] + +Note [Kind checking recursive type and class declarations] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Before we can type-check the decls, we must kind check them. This +is done by establishing an "initial kind", which is a rather uninformed +guess at a tycon's kind (by counting arguments, mainly) and then +using this initial kind for recursive occurrences. + +The initial kind is stored in exactly the same way during +kind-checking as it is during type-checking (Note [Type checking +recursive type and class declarations]): in the *local* environment, +with ATcTyCon. But we still must store *something* in the *global* +environment. Even though we discard the result of kind-checking, we +sometimes need to produce error messages. These error messages will +want to refer to the tycons being checked, except that they don't +exist yet, and it would be Terribly Annoying to get the error messages +to refer back to HsSyn. So we create a TcTyCon and put it in the +global env. This tycon can print out its name and knows its kind, but +any other action taken on it will panic. Note that TcTyCons are *not* +knot-tied, unlike the rather valid but knot-tied ones that occur +during type-checking. + +Note [Declarations for wired-in things] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +For wired-in things we simply ignore the declaration +and take the wired-in information. That avoids complications. +e.g. the need to make the data constructor worker name for + a constraint tuple match the wired-in one + +Note [Datatype return kinds] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +There are several poorly lit corners around datatype/newtype return kinds. +This Note explains these. We cover data/newtype families and instances +in Note [Data family/instance return kinds]. + +data T a :: where ... -- See Point DT4 +newtype T a :: where ... -- See Point DT5 + +DT1 Where this applies: Only GADT syntax for data/newtype/instance declarations + can have declared return kinds. This Note does not apply to Haskell98 + syntax. + +DT2 Where these kinds come from: The return kind is part of the TyCon kind, gotten either + by checkInitialKind (standalone kind signature / CUSK) or + inferInitialKind. It is extracted by bindTyClTyVars in tcTyClDecl1. It is + then passed to tcDataDefn. + +DT3 Eta-expansion: Any forall-bound variables and function arguments in a result kind + become parameters to the type. That is, when we say + + 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 maybeEtaExpandAlgTyCon, + called in tcDataDefn. + + See also Note [splitTyConKind] in GHC.Tc.Gen.HsType. + +DT4 Datatype return kind restriction: A data type return kind must end + in a type that, after type-synonym expansion, yields `TYPE LiftedRep`. By + "end in", we mean we strip any foralls and function arguments off before + checking. + + Examples: + data T1 :: Type -- good + data T2 :: Bool -> Type -- good + data T3 :: Bool -> forall k. Type -- strange, but still accepted + data T4 :: forall k. k -> Type -- good + data T5 :: Bool -- bad + data T6 :: Type -> Bool -- bad + + Exactly the same applies to data instance (but not data family) + declarations. Examples + data instance D1 :: Type -- good + data instance D2 :: Bool -> Type -- good + + We can "look through" type synonyms + type Star = Type + data T7 :: Bool -> Star -- good (synonym expansion ok) + type Arrow = (->) + data T8 :: Arrow Bool Type -- good (ditto) + + But we specifically do *not* do type family reduction here. + type family ARROW where + ARROW = (->) + data T9 :: ARROW Bool Type -- bad + + type family F a where + F Int = Bool + F Bool = Type + data T10 :: Bool -> F Bool -- bad + + The /principle/ here is that in the TyCon for a data type or data instance, + we must be able to lay out all the type-variable binders, one by one, until + we reach (TYPE xx). There is no place for a cast here. We could add one, + but let's not! + + This check is done in checkDataKindSig. For data declarations, this + call is in tcDataDefn; for data instances, this call is in tcDataFamInstDecl. + +DT5 Newtype return kind restriction. + If -XUnliftedNewtypes is not on, then newtypes are treated just + like datatypes --- see (4) above. + + If -XUnliftedNewtypes is on, then a newtype return kind must end in + TYPE xyz, for some xyz (after type synonym expansion). The "xyz" + may include type families, but the TYPE part must be visible + /without/ expanding type families (only synonyms). + + This kind is unified with the kind of the representation type (the + type of the one argument to the one constructor). See also steps + (2) and (3) of Note [Implementation of UnliftedNewtypes]. + + The checks are done in the same places as for datatypes. + Examples (assume -XUnliftedNewtypes): + + newtype N1 :: Type -- good + newtype N2 :: Bool -> Type -- good + newtype N3 :: forall r. Bool -> TYPE r -- good + + type family F (t :: Type) :: RuntimeRep + newtype N4 :: forall t -> TYPE (F t) -- good + + type family STAR where + STAR = Type + newtype N5 :: Bool -> STAR -- bad + +Note [Data family/instance return kinds] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Within this note, understand "instance" to mean data or newtype +instance, and understand "family" to mean data family. No type +families or classes here. Some examples: + +data family T a :: -- See Point DF56 + +data instance T [a] :: where ... -- See Point DF2 +newtype instance T [a] :: where ... -- See Point DF2 + +Here is the Plan for Data Families: + +DF0 Where these kinds come from: + + Families: The return kind is either written in a standalone signature + or extracted from a family declaration in getInitialKind. + If a family declaration is missing a result kind, it is assumed to be + Type. This assumption is in getInitialKind for CUSKs or + get_fam_decl_initial_kind for non-signature & non-CUSK cases. + + 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 + TyCon. For example: + data family T1 :: Type -> Type -> Type + data instance T1 Int :: F Bool -> Type where ... + The "master kind" for the representation TyCon R:T1Int comes + from T1, not from the signature on the data instance. It is as + if we declared + data R:T1Int :: Type -> Type where ... + See Note [Liberalising data family return kinds] for an alternative + plan. But this current plan is simple, and ensures that all instances + are simple instantiations of the master, without strange casts. + + An example with non-trivial instantiation: + data family T2 :: forall k. Type -> k + data instance T2 :: Type -> Type -> Type where ... + Here 'k' gets instantiated with (Type -> Type), driven by + the signature on the 'data instance'. (See also DT3 of + Note [Datatype return kinds] about eta-expansion, which applies here, + too; see tcDataFamInstDecl's call of etaExpandAlgTyCon.) + + A newtype example: + + data Color = Red | Blue + type family Interpret (x :: Color) :: RuntimeRep where + Interpret 'Red = 'IntRep + Interpret 'Blue = 'WordRep + data family Foo (x :: Color) :: TYPE (Interpret x) + newtype instance Foo 'Red :: TYPE IntRep where + FooRedC :: Int# -> Foo 'Red + + Here we get that Foo 'Red :: TYPE (Interpret Red), and our + representation newtype looks like + newtype R:FooRed :: TYPE (Interpret Red) where + FooRedC :: Int# -> R:FooRed + Remember: the master kind comes from the /family/ tycon. + +DF2 /After/ this instantiation, the return kind of the master kind + must obey the usual rules for data/newtype return kinds (DT4, DT5) + of Note [Datatype return kinds]. Examples: + data family T3 k :: k + data instance T3 Type where ... -- OK + data instance T3 (Type->Type) where ... -- OK + data instance T3 (F Int) where ... -- Not OK + +DF3 Any kind signatures on the data/newtype instance are checked for + equality with the master kind (and hence may guide instantiation) + but are otherwise ignored. So in the T1 example above, we check + that (F Int ~ Type) by unification; but otherwise ignore the + user-supplied signature from the /family/ not the /instance/. + + We must be sure to instantiate any trailing invisible binders + before doing this unification. See the call to tcInstInvisibleBinders + in tcDataFamInstHeader. For example: + data family D :: forall k. k + data instance D :: Type -- forall k. k <: Type + data instance D :: Type -> Type -- forall k. k <: Type -> Type + -- NB: these do not overlap + we must instantiate D before unifying with the signature in the + data instance declaration + +DF4 We also (redundantly) check that any user-specified return kind + signature in the data instance also obeys DT4/DT5. For example we + reject + data family T1 :: Type -> Type -> Type + data instance T1 Int :: Type -> F Int + even if (F Int ~ Type). We could omit this check, because we + use the master kind; but it seems more uniform to check it, again + with checkDataKindSig. + +DF5 Data /family/ return kind restrictions. Consider + data family D8 a :: F a + where F is a type family. No data/newtype instance can instantiate + this so that it obeys the rules of DT4 or DT5. So GHC proactively + rejects the data /family/ declaration if it can never satisfy (DT4)/(DT5). + Remember that a data family supports both data and newtype instances. + + More precisely, the return kind of a data family must be either + * TYPE xyz (for some type xyz) or + * a kind variable + Only in these cases can a data/newtype instance possibly satisfy (DT4)/(DT5). + This is checked by the call to checkDataKindSig in tcFamDecl1. Examples: + + data family D1 :: Type -- good + data family D2 :: Bool -> Type -- good + data family D3 k :: k -- good + data family D4 :: forall k -> k -- good + data family D5 :: forall k. k -> k -- good + data family D6 :: forall r. TYPE r -- good + data family D7 :: Bool -> STAR -- bad (see STAR from point 5) + +DF6 Two return kinds for instances: If an instance has two return kinds, + one from the family declaration and one from the instance declaration + (see point DF3 above), they are unified. More accurately, we make sure + that the kind of the applied data family is a subkind of the user-written + kind. GHC.Tc.Gen.HsType.checkExpectedKind normally does this check for types, but + that's overkill for our needs here. Instead, we just instantiate any + invisible binders in the (instantiated) kind of the data family + (called lhs_kind in tcDataFamInstHeader) with tcInstInvisibleTyBinders + and then unify the resulting kind with the kind written by the user. + This unification naturally produces a coercion, which we can drop, as + the kind annotation on the instance is redundant (except perhaps for + effects of unification). + + This all is Wrinkle (3) in Note [Implementation of UnliftedNewtypes]. + +Note [Liberalising data family return kinds] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Could we allow this? + type family F a where { F Int = Type } + data family T a :: F a + data instance T Int where + MkT :: T Int + +In the 'data instance', T Int :: F Int, and F Int = Type, so all seems +well. But there are lots of complications: + +* The representation constructor R:TInt presumably has kind Type. + So the axiom connecting the two would have to look like + axTInt :: T Int ~ R:TInt |> sym axFInt + and that doesn't match expectation in DataFamInstTyCon + in AlgTyConFlav + +* The wrapper can't have type + $WMkT :: Int -> T Int + because T Int has the wrong kind. It would have to be + $WMkT :: Int -> (T Int) |> axFInt + +* The code for $WMkT would also be more complicated, needing + two coherence coercions. Try it! + +* Code for pattern matching would be complicated in an + exactly dual way. + +So yes, we could allow this, but we currently do not. That's +why we have DF2 in Note [Data family/instance return kinds]. + +Note [Implementation of UnliftedNewtypes] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Expected behavior of UnliftedNewtypes: + +* Proposal: https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0013-unlifted-newtypes.rst +* Discussion: https://github.com/ghc-proposals/ghc-proposals/pull/98 + +What follows is a high-level overview of the implementation of the +proposal. + +STEP 1: Getting the initial kind, as done by inferInitialKind. We have +two sub-cases: + +* With a SAK/CUSK: no change in kind-checking; the tycon is given the kind + the user writes, whatever it may be. + +* Without a SAK/CUSK: If there is no kind signature, the tycon is given + a kind `TYPE r`, for a fresh unification variable `r`. We do this even + when -XUnliftedNewtypes is not on; see , below. + +STEP 2: Kind-checking, as done by kcTyClDecl. This step is skipped for CUSKs. +The key function here is kcConDecl, which looks at an individual constructor +declaration. When we are processing a newtype (but whether or not -XUnliftedNewtypes +is enabled; see , below), we generate a correct ContextKind +for the checking argument types: see getArgExpKind. + +Examples of newtypes affected by STEP 2, assuming -XUnliftedNewtypes is +enabled (we use r0 to denote a unification variable): + +newtype Foo rep = MkFoo (forall (a :: TYPE rep). a) ++ kcConDecl unifies (TYPE r0) with (TYPE rep), where (TYPE r0) + is the kind that inferInitialKind invented for (Foo rep). + +data Color = Red | Blue +type family Interpret (x :: Color) :: RuntimeRep where + Interpret 'Red = 'IntRep + Interpret 'Blue = 'WordRep +data family Foo (x :: Color) :: TYPE (Interpret x) +newtype instance Foo 'Red = FooRedC Int# ++ kcConDecl unifies TYPE (Interpret 'Red) with TYPE 'IntRep + +Note that, in the GADT case, we might have a kind signature with arrows +(newtype XYZ a b :: Type -> Type where ...). We want only the final +component of the kind for checking in kcConDecl, so we call etaExpanAlgTyCon +in kcTyClDecl. + +STEP 3: Type-checking (desugaring), as done by tcTyClDecl. The key function +here is tcConDecl. Once again, we must use getArgExpKind to ensure that the +representation type's kind matches that of the newtype, for two reasons: + + A. It is possible that a GADT has a CUSK. (Note that this is *not* + possible for H98 types.) Recall that CUSK types don't go through + kcTyClDecl, so we might not have done this kind check. + B. We need to produce the coercion to put on the argument type + if the kinds are different (for both H98 and GADT). + +Example of (B): + +type family F a where + F Int = LiftedRep + +newtype N :: TYPE (F Int) where + MkN :: Int -> N + +We really need to have the argument to MkN be (Int |> TYPE (sym axF)), where +axF :: F Int ~ LiftedRep. That way, the argument kind is the same as the +newtype kind, which is the principal correctness condition for newtypes. + +Wrinkle: Consider (#17021, typecheck/should_fail/T17021) + + type family Id (x :: a) :: a where + Id x = x + + newtype T :: TYPE (Id LiftedRep) where + MkT :: Int -> T + + In the type of MkT, we must end with (Int |> TYPE (sym axId)) -> T, + never Int -> (T |> TYPE axId); otherwise, the result type of the + constructor wouldn't match the datatype. However, type-checking the + HsType T might reasonably result in (T |> hole). We thus must ensure + that this cast is dropped, forcing the type-checker to add one to + the Int instead. + + Why is it always safe to drop the cast? This result type is type-checked by + tcHsOpenType, so its kind definitely looks like TYPE r, for some r. It is + important that even after dropping the cast, the type's kind has the form + TYPE r. This is guaranteed by restrictions on the kinds of datatypes. + For example, a declaration like `newtype T :: Id Type` is rejected: a + newtype's final kind always has the form TYPE r, just as we want. + +Note that this is possible in the H98 case only for a data family, because +the H98 syntax doesn't permit a kind signature on the newtype itself. + +There are also some changes for dealing with families: + +1. In tcFamDecl1, we suppress a tcIsLiftedTypeKind check if + UnliftedNewtypes is on. This allows us to write things like: + data family Foo :: TYPE 'IntRep + +2. In a newtype instance (with -XUnliftedNewtypes), if the user does + not write a kind signature, we want to allow the possibility that + the kind is not Type, so we use newOpenTypeKind instead of liftedTypeKind. + This is done in tcDataFamInstHeader in GHC.Tc.TyCl.Instance. Example: + + data family Bar (a :: RuntimeRep) :: TYPE a + newtype instance Bar 'IntRep = BarIntC Int# + newtype instance Bar 'WordRep :: TYPE 'WordRep where + BarWordC :: Word# -> Bar 'WordRep + + The data instance corresponding to IntRep does not specify a kind signature, + so tc_kind_sig just returns `TYPE r0` (where `r0` is a fresh metavariable). + The data instance corresponding to WordRep does have a kind signature, so + we use that kind signature. + +3. A data family and its newtype instance may be declared with slightly + different kinds. See point DF6 in Note [Data family/instance return kinds] + +There's also a change in the renamer: + +* In GHC.RenameSource.rnTyClDecl, enabling UnliftedNewtypes changes what is means + for a newtype to have a CUSK. This is necessary since UnliftedNewtypes + means that, for newtypes without kind signatures, we must use the field + inside the data constructor to determine the result kind. + See Note [Unlifted Newtypes and CUSKs] for more detail. + +For completeness, it was also necessary to make coerce work on +unlifted types, resolving #13595. + +: It's tempting to think that the expected kind for a newtype +constructor argument when -XUnliftedNewtypes is *not* enabled should just be Type. +But this leads to difficulty in suggesting to enable UnliftedNewtypes. Here is +an example: + + newtype A = MkA Int# + +If we expect the argument to MkA to have kind Type, then we get a kind-mismatch +error. The problem is that there is no way to connect this mismatch error to +-XUnliftedNewtypes, and suggest enabling the extension. So, instead, we allow +the A to type-check, but then find the problem when doing validity checking (and +where we get make a suitable error message). One potential worry is + + {-# LANGUAGE PolyKinds #-} + newtype B a = MkB a + +This turns out OK, because unconstrained RuntimeReps default to LiftedRep, just +as we would like. Another potential problem comes in a case like + + -- no UnliftedNewtypes + + data family D :: k + newtype instance D = MkD Any + +Here, we want inference to tell us that k should be instantiated to Type in +the instance. With the approach described here (checking for Type only in +the validity checker), that will not happen. But I cannot think of a non-contrived +example that will notice this lack of inference, so it seems better to improve +error messages than be able to infer this instantiation. + +Note [Implementation of UnliftedDatatypes] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Expected behavior of UnliftedDatatypes: + +* Proposal: https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0265-unlifted-datatypes.rst +* Discussion: https://github.com/ghc-proposals/ghc-proposals/pull/265 + +The implementation heavily leans on Note [Implementation of UnliftedNewtypes]. + +In the frontend, the following tweaks have been made in the typechecker: + +* STEP 1: In the inferInitialKinds phase, newExpectedKind gives data type + constructors a result kind of `TYPE r` with a fresh unification variable + `r :: RuntimeRep` when there is a SAKS. (Same as for UnliftedNewtypes.) + Not needed with a CUSK, because it can't specify result kinds. + If there's a GADTSyntax result kind signature, we keep on using that kind. + + Similarly, for data instances without a kind signature, we use + `TYPE r` as the result kind, to support the following code: + + data family F a :: UnliftedType + data instance F Int = TInt + + The omission of a kind signature for `F` should not mean a result kind + of `Type` (and thus a kind error) here. + +* STEP 2: No change to kcTyClDecl. + +* STEP 3: In GHC.Tc.Gen.HsType.checkDataKindSig, we make sure that the result + kind of the data declaration is actually `Type` or `TYPE (BoxedRep l)`, + for some `l`. If UnliftedDatatypes is not activated, we emit an error with a + suggestion in the latter case. + + Why not start out with `TYPE (BoxedRep l)` in the first place? Because then + we get worse kind error messages in e.g. saks_fail010: + + - Couldn't match expected kind: TYPE ('GHC.Types.BoxedRep t0) + - with actual kind: * -> * + + Expected a type, but found something with kind ‘* -> *’ + In the data type declaration for ‘T’ + + It seems `TYPE r` already has appropriate pretty-printing support. + +The changes to Core, STG and Cmm are of rather cosmetic nature. +The IRs are already well-equipped to handle unlifted types, and unlifted +datatypes are just a new sub-class thereof. +-} + +tcTyClDecl :: RolesInfo -> LTyClDecl GhcRn -> TcM ((TyCon, [TyFamEqnValidityInfo]), [DerivInfo]) +tcTyClDecl roles_info (L loc decl) + | Just thing <- wiredInNameTyThing_maybe (tcdName decl) + = case thing of -- See Note [Declarations for wired-in things] + ATyCon tc -> return ((tc, []), wiredInDerivInfo tc decl) + _ -> pprPanic "tcTyClDecl" (ppr thing) + + | otherwise + = setSrcSpanA loc $ tcAddDeclCtxt decl $ + do { traceTc "---- tcTyClDecl ---- {" (ppr decl) + ; (tc_vi@(tc, _), deriv_infos) <- tcTyClDecl1 Nothing roles_info decl + ; traceTc "---- tcTyClDecl end ---- }" (ppr tc) + ; return (tc_vi, deriv_infos) } + +noDerivInfos :: a -> (a, [DerivInfo]) +noDerivInfos a = (a, []) + +noEqnValidityInfos :: a -> (a, [TyFamEqnValidityInfo]) +noEqnValidityInfos a = (a, []) + +wiredInDerivInfo :: TyCon -> TyClDecl GhcRn -> [DerivInfo] +wiredInDerivInfo tycon decl + | DataDecl { tcdDataDefn = dataDefn } <- decl + , HsDataDefn { dd_derivs = derivs } <- dataDefn + = [ DerivInfo { di_rep_tc = tycon + , di_scoped_tvs = + if isPrimTyCon tycon + then [] -- no tyConTyVars + else mkTyVarNamePairs (tyConTyVars tycon) + , di_clauses = derivs + , di_ctxt = tcMkDeclCtxt decl } ] +wiredInDerivInfo _ _ = [] + + -- "type family" declarations +tcTyClDecl1 :: Maybe Class -> RolesInfo -> TyClDecl GhcRn -> TcM ((TyCon, [TyFamEqnValidityInfo]), [DerivInfo]) +tcTyClDecl1 parent _roles_info (FamDecl { tcdFam = fd }) + = fmap noDerivInfos $ + tcFamDecl1 parent fd + + -- "type" synonym declaration +tcTyClDecl1 _parent roles_info + (SynDecl { tcdLName = L _ tc_name + , tcdRhs = rhs }) + = assert (isNothing _parent ) + fmap ( noDerivInfos . noEqnValidityInfos ) $ + tcTySynRhs roles_info tc_name rhs + + -- "data/newtype" declaration +tcTyClDecl1 _parent roles_info + decl@(DataDecl { tcdLName = L _ tc_name + , tcdDataDefn = defn }) + = assert (isNothing _parent) $ + fmap (\(tc, deriv_info) -> ((tc, []), deriv_info)) $ + tcDataDefn (tcMkDeclCtxt decl) roles_info tc_name defn + +tcTyClDecl1 _parent roles_info + (ClassDecl { tcdLName = L _ class_name + , tcdCtxt = hs_ctxt + , tcdMeths = meths + , tcdFDs = fundeps + , tcdSigs = sigs + , tcdATs = ats + , tcdATDefs = at_defs }) + = assert (isNothing _parent) $ + do { clas <- tcClassDecl1 roles_info class_name hs_ctxt + meths fundeps sigs ats at_defs + ; return (noDerivInfos $ noEqnValidityInfos (classTyCon clas)) } + + +{- ********************************************************************* +* * + Class declarations +* * +********************************************************************* -} + +tcClassDecl1 :: RolesInfo -> Name -> Maybe (LHsContext GhcRn) + -> LHsBinds GhcRn -> [LHsFunDep GhcRn] -> [LSig GhcRn] + -> [LFamilyDecl GhcRn] -> [LTyFamDefltDecl GhcRn] + -> TcM Class +tcClassDecl1 roles_info class_name hs_ctxt meths fundeps sigs ats at_defs + = fixM $ \ clas -> -- We need the knot because 'clas' is passed into tcClassATs + bindTyClTyVars class_name $ \ tc_bndrs res_kind -> + do { checkClassKindSig res_kind + ; traceTc "tcClassDecl 1" (ppr class_name $$ ppr tc_bndrs) + ; let tycon_name = class_name -- We use the same name + roles = roles_info tycon_name -- for TyCon and Class + + ; (ctxt, fds, sig_stuff, at_stuff) + <- pushLevelAndSolveEqualities skol_info tc_bndrs $ + -- 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 (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) } + + -- See Note [Error on unconstrained meta-variables] in GHC.Tc.Utils.TcMType + -- Example: (typecheck/should_fail/T17562) + -- type C :: Type -> Type -> Constraint + -- class (forall a. a b ~ a c) => C b c + -- The kind of `a` is unconstrained. + ; dvs <- candidateQTyVarsOfTypes ctxt + ; let err_ctx tidy_env = do { (tidy_env2, ctxt) <- zonkTidyTcTypes tidy_env ctxt + ; return (tidy_env2, UninfTyCtx_ClassContext ctxt) } + ; doNotQuantifyTyVars dvs err_ctx + + -- The pushLevelAndSolveEqualities will report errors for any + -- unsolved equalities, so these zonks should not encounter + -- any unfilled coercion variables unless there is such an error + -- The zonk also squeeze out the TcTyCons, and converts + -- Skolems to tyvars. + ; (bndrs, ctxt, sig_stuff) <- initZonkEnv NoFlexi $ + runZonkBndrT (zonkTyVarBindersX tc_bndrs) $ \ bndrs -> + do { ctxt <- zonkTcTypesToTypesX ctxt + ; sig_stuff <- mapM zonkTcMethInfoToMethInfoX sig_stuff + -- ToDo: do we need to zonk at_stuff? + ; return (bndrs, ctxt, sig_stuff) } + + -- TODO: Allow us to distinguish between abstract class, + -- and concrete class with no methods (maybe by + -- specifying a trailing where or not + + ; mindef <- tcClassMinimalDef class_name sigs sig_stuff + ; is_boot <- tcIsHsBootOrSig + ; 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: + -- + -- class () => C a b | a -> b + -- + -- is not considered abstract; it's sometimes useful + -- to be able to declare such empty classes in hs-boot files. + -- See #20661. + + 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 } + where + skol_info = TyConSkol ClassFlavour class_name + + tc_fundep :: GHC.Hs.FunDep GhcRn -> TcM ([Var],[Var]) + tc_fundep (FunDep _ tvs1 tvs2) + = do { tvs1' <- mapM (tcLookupTyVar . unLoc) tvs1 ; + ; tvs2' <- mapM (tcLookupTyVar . unLoc) tvs2 ; + ; return (tvs1',tvs2') } + + +{- Note [Associated type defaults] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The following is an example of associated type defaults: + + class C a where + data D a + + type F a b :: * + type F a b = [a] -- Default + +Note that we can get default definitions only for type families, not data +families. +-} + +tcClassATs :: Name -- The class name (not knot-tied) + -> Class -- The class parent of this associated type + -> [LFamilyDecl GhcRn] -- Associated types. + -> [LTyFamDefltDecl GhcRn] -- Associated type defaults. + -> TcM [ClassATItem] +tcClassATs class_name cls ats at_defs + = do { -- Complain about associated type defaults for non associated-types + sequence_ [ failWithTc $ TcRnIllegalInstance + $ IllegalFamilyInstance $ InvalidAssoc + $ InvalidAssocDefault + $ AssocDefaultNotAssoc class_name n + | n <- map at_def_tycon at_defs + , not (n `elemNameSet` at_names) ] + ; mapM tc_at ats } + where + at_def_tycon :: LTyFamDefltDecl GhcRn -> Name + at_def_tycon = tyFamInstDeclName . unLoc + + at_fam_name :: LFamilyDecl GhcRn -> Name + at_fam_name = familyDeclName . unLoc + + at_names = mkNameSet (map at_fam_name ats) + + at_defs_map :: NameEnv [LTyFamDefltDecl GhcRn] + -- Maps an AT in 'ats' to a list of all its default defs in 'at_defs' + at_defs_map = foldr (\at_def nenv -> extendNameEnv_C (++) nenv + (at_def_tycon at_def) [at_def]) + emptyNameEnv at_defs + + 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` [] + ; atd <- tcDefaultAssocDecl fam_tc at_defs + ; return (ATI fam_tc atd) } + +------------------------- +tcDefaultAssocDecl :: + TyCon -- ^ Family TyCon (not knot-tied) + -> [LTyFamDefltDecl GhcRn] -- ^ Defaults + -> TcM (Maybe (KnotTied Type, TyFamEqnValidityInfo)) -- ^ Type checked RHS +tcDefaultAssocDecl _ [] + = return Nothing -- No default declaration + +tcDefaultAssocDecl _ (d1:_:_) + = failWithTc $ TcRnIllegalInstance $ IllegalFamilyInstance + $ InvalidAssoc $ InvalidAssocDefault $ + AssocMultipleDefaults (tyFamInstDeclName (unLoc d1)) + +tcDefaultAssocDecl fam_tc + [L loc (TyFamInstDecl { tfid_eqn = + FamEqn { feqn_tycon = L _ tc_name + , feqn_bndrs = outer_bndrs + , 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 inst_flav tc_name $ + do { traceTc "tcDefaultAssocDecl 1" (ppr tc_name) + ; let fam_tc_name = tyConName fam_tc + vis_arity = length (tyConVisibleTyVars fam_tc) + vis_pats = numVisibleArgs hs_pats + + -- Kind of family check + ; assert (fam_tc_name == tc_name) $ + checkTc (isTypeFamilyTyCon fam_tc) $ + TcRnIllegalInstance $ IllegalFamilyInstance $ + FamilyCategoryMismatch fam_tc + + -- Arity check + ; checkTc (vis_pats == vis_arity) $ + TcRnIllegalInstance $ IllegalFamilyInstance $ + FamilyArityMismatch fam_tc vis_arity + + -- Typecheck RHS + -- + -- You might think we should pass in some AssocInstInfo, as we're looking + -- at an associated type. But this would be wrong, because an associated + -- type default LHS can mention *different* type variables than the + -- enclosing class. So it's treated more as a freestanding beast. + ; (qtvs, non_user_tvs, pats, rhs_ty) + <- tcTyFamInstEqnGuts fam_tc NotAssociated + outer_bndrs hs_pats hs_rhs_ty + + ; let fam_tvs = tyConTyVars fam_tc + ; traceTc "tcDefaultAssocDecl 2" (vcat + [ text "hs_pats" <+> ppr hs_pats + , text "hs_rhs_ty" <+> ppr hs_rhs_ty + , text "fam_tvs" <+> ppr fam_tvs + , text "qtvs" <+> ppr qtvs + -- NB: Do *not* print `pats` or rhs_ty here, as they can mention + -- knot-tied TyCons. See #18648. + ]) + ; let subst = case traverse getTyVar_maybe pats of + Just cpt_tvs -> zipTvSubst cpt_tvs (mkTyVarTys fam_tvs) + Nothing -> emptySubst + -- The Nothing case can only be reached in invalid + -- associated type family defaults. In such cases, we + -- simply create an empty substitution and let GHC fall + -- over later, in GHC.Tc.Validity.checkValidAssocTyFamDeflt. + -- See Note [Type-checking default assoc decls]. + + ; pure $ Just ( substTyUnchecked subst rhs_ty + , VI { vi_loc = locA loc + , vi_qtvs = qtvs + , vi_non_user_tvs = non_user_tvs + , vi_pats = pats + , vi_rhs = rhs_ty } ) + -- We perform checks for well-formedness and validity later, in + -- GHC.Tc.Validity.checkValidAssocTyFamDeflt. + } + +{- Note [Type-checking default assoc decls] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this default declaration for an associated type + + class C a where + type F (a :: k) b :: Type + type F (x :: j) y = Proxy x -> y + +Note that the class variable 'a' doesn't scope over the default assoc +decl, nor do the type variables `k` and `b`. Instead, the default decl is +treated more like a top-level type instance. However, we store the default rhs +(Proxy x -> y) in F's TyCon, using F's own type variables, so we need to +convert it to (Proxy a -> b). We do this in the tcDefaultAssocDecl function by +creating a substitution [j |-> k, x |-> a, b |-> y] and applying this +substitution to the RHS. + +In order to create this substitution, we must first ensure that all of +the arguments in the default instance consist of distinct type variables. +Checking for this property proves surprisingly tricky. Three potential places +where GHC could check for this property include: + +1. Before typechecking (in the parser or renamer) +2. During typechecking (in tcDefaultAssocDecl) +3. After typechecking (using GHC.Tc.Validity) + +Currently, GHC picks option (3) and implements this check using +GHC.Tc.Validity.checkValidAssocTyFamDeflt. GHC previously used options (1) and +(2), but neither option quite worked out for reasons that we will explain +shortly. + +The first thing that checkValidAssocTyFamDeflt does is check that all arguments +in an associated type family default are type variables. As a motivating +example, consider this erroneous program (inspired by #11361): + + class C a where + type F (a :: k) b :: Type + type F x b = x + +If you squint, you'll notice that the kind of `x` is actually Type. However, +we cannot substitute from [Type |-> k], so we reject this default. This also +explains why GHC no longer implements option (1) above, since figuring out that +`x`'s kind is Type would be much more difficult without the knowledge that the +typechecker provides. + +Next, checkValidAssocTyFamDeflt checks that all arguments are distinct. Here is +another offending example, this time taken from #13971: + + class C2 (a :: j) where + type F2 (a :: j) (b :: k) + type F2 (x :: z) y = SameKind x y + data SameKind :: k -> k -> Type + +All of the arguments in the default equation for `F2` are type variables, so +that passes the first check. However, if we were to build this substitution, +then both `j` and `k` map to `z`! In terms of visible kind application, it's as +if we had written `type F2 @z @z x y = SameKind @z x y`, which makes it clear +that we have duplicated a use of `z` on the LHS. Therefore, `F2`'s default is +also rejected. + +There is one more design consideration in play here: what error message should +checkValidAssocTyFamDeflt produce if one of its checks fails? Ideally, it would +be something like this: + + Illegal duplicate variable ‘z’ in: + ‘type F2 @z @z x y = ...’ + The arguments to ‘F2’ must all be distinct type variables + +This requires printing out the arguments to the associated type family. This +can be dangerous, however. Consider this example, adapted from #18648: + + class C3 a where + type F3 a + type F3 (F3 a) = a + +F3's default is illegal, since its argument is not a bare type variable. But +note that when we typecheck F3's default, the F3 type constructor is knot-tied. +Therefore, if we print the type `F3 a` in an error message, GHC will diverge! +This is the reason why GHC no longer implements option (2) above and instead +waits until /after/ typechecking has finished, at which point the typechecker +knot has been worked out. + +As one final point, one might worry that the typechecker knot could cause the +substitution that tcDefaultAssocDecl creates to diverge, but this is not the +case. Since the LHS of a valid associated type family default is always just +variables, it won't contain any tycons. Accordingly, the patterns used in the +substitution won't actually be knot-tied, even though we're in the knot. (This +is too delicate for my taste, but it works.) If we're dealing with /invalid/ +default, such as F3's above, then we simply create an empty substitution and +rely on checkValidAssocTyFamDeflt throwing an error message afterwards before +any damage is done. +-} + +{- ********************************************************************* +* * + Type family declarations +* * +********************************************************************* -} + +tcFamDecl1 :: Maybe Class -> FamilyDecl GhcRn -> TcM (TyCon, [TyFamEqnValidityInfo]) +tcFamDecl1 parent (FamilyDecl { fdInfo = fam_info + , fdLName = tc_lname@(L _ tc_name) + , fdResultSig = L _ sig + , fdInjectivityAnn = inj }) + | DataFamily <- fam_info + = bindTyClTyVarsAndZonk tc_name $ \ tc_bndrs res_kind -> do + { traceTc "tcFamDecl1 data family:" (ppr tc_name) + ; checkFamFlag tc_name + + -- Check that the result kind is OK + -- We allow things like + -- data family T (a :: Type) :: forall k. k -> Type + -- We treat T as having arity 1, but result kind forall k. k -> Type + -- But we want to check that the result kind finishes in + -- Type or a kind-variable + -- For the latter, consider + -- data family D a :: forall k. Type -> k + -- When UnliftedNewtypes is enabled, we loosen this restriction + -- on the return kind. See Note [Implementation of UnliftedNewtypes], wrinkle (1). + -- See also Note [Datatype return kinds] + ; checkDataKindSig DataFamilySort res_kind + ; tc_rep_name <- newTyConRepName tc_name + ; let inj = Injective $ replicate (length tc_bndrs) True + tycon = mkFamilyTyCon tc_name tc_bndrs + res_kind + (resultVariableName sig) + (DataFamilyTyCon tc_rep_name) + parent inj + ; return (tycon, []) } + + | OpenTypeFamily <- fam_info + = bindTyClTyVarsAndZonk tc_name $ \ tc_bndrs res_kind -> do + { traceTc "tcFamDecl1 open type family:" (ppr tc_name) + ; checkFamFlag tc_name + ; inj' <- tcInjectivity tc_bndrs inj + ; checkResultSigFlag tc_name sig -- check after injectivity for better errors + ; let tycon = mkFamilyTyCon tc_name tc_bndrs res_kind + (resultVariableName sig) OpenSynFamilyTyCon + parent inj' + ; return (tycon, []) } + + | ClosedTypeFamily mb_eqns <- fam_info + = -- Closed type families are a little tricky, because they contain the definition + -- of both the type family and the equations for a CoAxiom. + do { traceTc "tcFamDecl1 Closed type family:" (ppr tc_name) + -- the variables in the header scope only over the injectivity + -- declaration but this is not involved here + ; (inj', tc_bndrs, res_kind) + <- bindTyClTyVarsAndZonk tc_name $ \ tc_bndrs res_kind -> + do { inj' <- tcInjectivity tc_bndrs inj + ; return (inj', tc_bndrs, res_kind) } + + ; checkFamFlag tc_name -- make sure we have -XTypeFamilies + ; checkResultSigFlag tc_name sig + + -- If Nothing, this is an abstract family in a hs-boot file; + -- but eqns might be empty in the Just case as well + ; case mb_eqns of + Nothing -> + let tc = mkFamilyTyCon tc_name tc_bndrs res_kind + (resultVariableName sig) + AbstractClosedSynFamilyTyCon parent + inj' + in return (tc, []) + Just eqns -> do { + + -- Process the equations, creating CoAxBranches + ; let tc_fam_tc = mkTcTyCon tc_name tc_bndrs res_kind + noTcTyConScopedTyVars + False {- this doesn't matter here -} + ClosedTypeFamilyFlavour + + ; (branches, axiom_validity_infos) <- + unzip <$> mapAndReportM (tcTyFamInstEqn tc_fam_tc NotAssociated) eqns + -- Do not attempt to drop equations dominated by earlier + -- ones here; in the case of mutual recursion with a data + -- type, we get a knot-tying failure. Instead we check + -- for this afterwards, in GHC.Tc.Validity.checkValidCoAxiom + -- Example: tc265 + + -- Create a CoAxiom, with the correct src location. + ; co_ax_name <- newFamInstAxiomName tc_lname [] + + ; let mb_co_ax + | null eqns = Nothing -- mkBranchedCoAxiom fails on empty list + | otherwise = Just (mkBranchedCoAxiom co_ax_name fam_tc branches) + + fam_tc = mkFamilyTyCon tc_name tc_bndrs res_kind (resultVariableName sig) + (ClosedSynFamilyTyCon mb_co_ax) parent inj' + + -- We check for instance validity later, when doing validity + -- checking for the tycon. Exception: checking equations + -- overlap done by dropDominatedAxioms + ; return (fam_tc, axiom_validity_infos) } } + +-- | 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). +-- True on position +-- N means that a function is injective in its Nth argument. False means it is +-- not. +tcInjectivity :: [TyConBinder] -> Maybe (LInjectivityAnn GhcRn) + -> TcM Injectivity +tcInjectivity _ Nothing + = return NotInjective + + -- User provided an injectivity annotation, so for each tyvar argument we + -- check whether a type family was declared injective in that argument. We + -- return a list of Bools, where True means that corresponding type variable + -- was mentioned in lInjNames (type family is injective in that argument) and + -- False means that it was not mentioned in lInjNames (type family is not + -- injective in that type variable). We also extend injectivity information to + -- kind variables, so if a user declares: + -- + -- type family F (a :: k1) (b :: k2) = (r :: k3) | r -> a + -- + -- then we mark both `a` and `k1` as injective. + -- NB: the return kind is considered to be *input* argument to a type family. + -- Since injectivity allows to infer input arguments from the result in theory + -- we should always mark the result kind variable (`k3` in this example) as + -- injective. The reason is that result type has always an assigned kind and + -- therefore we can always infer the result kind if we know the result type. + -- But this does not seem to be useful in any way so we don't do it. (Another + -- reason is that the implementation would not be straightforward.) +tcInjectivity tcbs (Just (L loc (InjectivityAnn _ _ lInjNames))) + = setSrcSpanA loc $ + do { let tvs = binderVars tcbs + ; dflags <- getDynFlags + -- Fail eagerly to avoid reporting injectivity errors when + -- TypeFamilyDependencies is not enabled. + ; checkTc (xopt LangExt.TypeFamilyDependencies dflags) + TcRnTyFamDepsDisabled + ; inj_tvs <- mapM (tcLookupTyVar . unLoc) lInjNames + ; inj_tvs <- liftZonkM $ zonkTcTyVarsToTcTyVars inj_tvs -- zonk the kinds + ; let inj_ktvs = filterVarSet isTyVar $ -- no injective coercion vars + closeOverKinds (mkVarSet inj_tvs) + ; let inj_bools = map (`elemVarSet` inj_ktvs) tvs + ; traceTc "tcInjectivity" (vcat [ ppr tvs, ppr lInjNames, ppr inj_tvs + , ppr inj_ktvs, ppr inj_bools ]) + ; return $ Injective inj_bools } + +tcTySynRhs :: RolesInfo -> Name + -> LHsType GhcRn -> TcM TyCon +tcTySynRhs roles_info tc_name hs_ty + = bindTyClTyVars tc_name $ \ tc_bndrs res_kind -> + do { env <- getLclEnv + ; traceTc "tc-syn" (ppr tc_name $$ ppr (getLclEnvRdrEnv env)) + ; rhs_ty <- pushLevelAndSolveEqualities skol_info tc_bndrs $ + tcCheckLHsTypeInContext hs_ty (TheKind res_kind) + + -- See Note [Error on unconstrained meta-variables] in GHC.Tc.Utils.TcMType + -- Example: (typecheck/should_fail/T17567) + -- type T = forall a. Proxy a + -- The kind of `a` is unconstrained. + ; dvs <- candidateQTyVarsOfType rhs_ty + ; let err_ctx tidy_env = do { (tidy_env2, rhs_ty) <- zonkTidyTcType tidy_env rhs_ty + ; return (tidy_env2, UninfTyCtx_TySynRhs rhs_ty) } + ; doNotQuantifyTyVars dvs err_ctx + + ; (bndrs, rhs_ty) <- initZonkEnv NoFlexi $ + runZonkBndrT (zonkTyVarBindersX tc_bndrs) $ \ bndrs -> + do { rhs_ty <- zonkTcTypeToTypeX rhs_ty + ; return (bndrs, rhs_ty) } + ; let roles = roles_info tc_name + ; return (buildSynTyCon tc_name bndrs res_kind roles rhs_ty) } + where + skol_info = TyConSkol TypeSynonymFlavour tc_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 + (HsDataDefn { dd_cType = cType + , dd_ctxt = ctxt + , dd_kindSig = mb_ksig -- Already in tc's kind + -- via inferInitialKinds + , dd_cons = cons + , dd_derivs = derivs }) + = bindTyClTyVars tc_name $ \ tc_bndrs res_kind -> + -- The TyCon tyvars must scope over + -- - the stupid theta (dd_ctxt) + -- - for H98 constructors only, the ConDecl + -- But it does no harm to bring them into scope + -- over GADT ConDecls as well; and it's awkward not to + do { gadt_syntax <- dataDeclChecks tc_name ctxt cons + + ; tcg_env <- getGblEnv + ; let hsc_src = tcg_src tcg_env + ; unless (mk_permissive_kind hsc_src cons) $ + checkDataKindSig (DataDeclSort (dataDefnConsNewOrData cons)) res_kind + + ; stupid_tc_theta <- pushLevelAndSolveEqualities skol_info tc_bndrs $ + tcHsContext ctxt + + -- See Note [Error on unconstrained meta-variables] in GHC.Tc.Utils.TcMType + -- Example: (typecheck/should_fail/T17567StupidTheta) + -- data (forall a. a b ~ a c) => T b c + -- The kind of 'a' is unconstrained. + ; dvs <- candidateQTyVarsOfTypes stupid_tc_theta + ; let err_ctx tidy_env + = do { (tidy_env2, theta) <- zonkTidyTcTypes tidy_env stupid_tc_theta + ; return (tidy_env2, UninfTyCtx_DataContext theta) } + ; doNotQuantifyTyVars dvs err_ctx + + -- Check that we don't use kind signatures without the extension + ; kind_signatures <- xoptM LangExt.KindSignatures + ; case mb_ksig of + Just (L _ ksig) + | not kind_signatures + -> addErrTc $ TcRnKindSignaturesDisabled (Right (tc_name, ksig)) + _ -> return () + + ; (bndrs, stupid_theta, res_kind) <- initZonkEnv NoFlexi $ + runZonkBndrT (zonkTyVarBindersX tc_bndrs) $ \ bndrs -> + do { stupid_theta <- zonkTcTypesToTypesX stupid_tc_theta + ; res_kind <- zonkTcTypeToTypeX res_kind + ; return (bndrs, stupid_theta, res_kind) } + + ; tycon <- fixM $ \ rec_tycon -> do + { data_cons <- tcConDecls DDataType rec_tycon tc_bndrs res_kind cons + ; tc_rhs <- mk_tc_rhs hsc_src rec_tycon data_cons + ; tc_rep_nm <- newTyConRepName tc_name + + ; return (mkAlgTyCon tc_name + bndrs + res_kind + (roles_info tc_name) + (fmap unLoc cType) + stupid_theta tc_rhs + (VanillaAlgTyCon tc_rep_nm) + gadt_syntax) + } + + ; let scoped_tvs = mkTyVarNamePairs (binderVars tc_bndrs) + -- scoped_tvs: still the skolem TcTyVars + deriv_info = DerivInfo { di_rep_tc = tycon + , di_scoped_tvs = scoped_tvs + , di_clauses = derivs + , di_ctxt = err_ctxt } + ; traceTc "tcDataDefn" (ppr tc_name $$ ppr tc_bndrs) + ; return (tycon, [deriv_info]) } + where + skol_info = TyConSkol flav tc_name + flav = newOrDataToFlavour (dataDefnConsNewOrData cons) + + -- Abstract data types in hsig files can have arbitrary kinds, + -- because they may be implemented by type synonyms + -- (which themselves can have arbitrary kinds, not just *). See #13955. + -- + -- Note that this is only a property that data type declarations possess, + -- so one could not have, say, a data family instance in an hsig file that + -- has kind `Bool`. Therefore, this check need only occur in the code that + -- typechecks data type declarations. + mk_permissive_kind HsigFile (DataTypeCons _ []) = True + mk_permissive_kind _ _ = False + + -- In an hs-boot or a signature file, + -- a 'data' declaration with no constructors + -- indicates a nominally distinct abstract data type. + mk_tc_rhs (isHsBootOrSig -> True) _ (DataTypeCons _ []) + = return AbstractTyCon + + mk_tc_rhs _ tycon data_cons = case data_cons of + DataTypeCons is_type_data data_cons -> return $ + mkLevPolyDataTyConRhs + (isFixedRuntimeRepKind (tyConResKind tycon)) + is_type_data + data_cons + NewTypeCon data_con -> mkNewTyConRhs tc_name tycon data_con + +------------------------- +kcTyFamInstEqn :: TcTyCon -> LTyFamInstEqn GhcRn -> TcM () +-- Used for the equations of a closed type family only +-- Not used for data/type instances +kcTyFamInstEqn tc_fam_tc + (L loc (FamEqn { feqn_tycon = L _ eqn_tc_name + , feqn_bndrs = outer_bndrs + , feqn_pats = hs_pats + , feqn_rhs = hs_rhs_ty })) + = setSrcSpanA loc $ + do { traceTc "kcTyFamInstEqn" (vcat + [ text "tc_name =" <+> ppr eqn_tc_name + , text "fam_tc =" <+> ppr tc_fam_tc <+> dcolon <+> ppr (tyConKind tc_fam_tc) + , text "feqn_bndrs =" <+> ppr outer_bndrs + , text "feqn_pats =" <+> ppr hs_pats ]) + + ; checkTyFamInstEqn tc_fam_tc eqn_tc_name hs_pats + + ; discardResult $ + bindOuterFamEqnTKBndrs_Q_Tv outer_bndrs $ + do { (_fam_app, res_kind) <- tcFamTyPats tc_fam_tc hs_pats + ; tcCheckLHsTypeInContext hs_rhs_ty (TheKind res_kind) } + -- Why "_Tv" here? Consider (#14066) + -- type family Bar x y where + -- Bar (x :: a) (y :: b) = Int + -- Bar (x :: c) (y :: d) = Bool + -- During kind-checking, a,b,c,d should be TyVarTvs and unify appropriately + } + +-------------------------- +tcTyFamInstEqn :: TcTyCon -> AssocInstInfo -> LTyFamInstEqn GhcRn + -> TcM (KnotTied CoAxBranch, TyFamEqnValidityInfo) +-- Needs to be here, not in GHC.Tc.TyCl.Instance, because closed families +-- (typechecked here) have TyFamInstEqns + +tcTyFamInstEqn fam_tc mb_clsinfo + (L loc (FamEqn { feqn_tycon = L _ eqn_tc_name + , feqn_bndrs = outer_bndrs + , feqn_pats = hs_pats + , feqn_rhs = hs_rhs_ty })) + = setSrcSpanA loc $ + do { traceTc "tcTyFamInstEqn" $ + vcat [ ppr loc, ppr fam_tc <+> ppr hs_pats + , text "fam tc bndrs" <+> pprTyVars (tyConTyVars fam_tc) + , case mb_clsinfo of + NotAssociated {} -> empty + InClsInst { ai_class = cls } -> text "class" <+> ppr cls <+> pprTyVars (classTyVars cls) ] + + ; checkTyFamInstEqn fam_tc eqn_tc_name hs_pats + + ; (qtvs, non_user_tvs, pats, rhs_ty) + <- tcTyFamInstEqnGuts fam_tc mb_clsinfo + outer_bndrs hs_pats hs_rhs_ty + -- Don't print results they may be knot-tied + -- (tcFamInstEqnGuts zonks to Type) + + ; let ax = mkCoAxBranch qtvs [] [] pats rhs_ty + (map (const Nominal) qtvs) + (locA loc) + vi = VI { vi_loc = locA loc + , vi_qtvs = qtvs + , vi_non_user_tvs = non_user_tvs + , vi_pats = pats + , vi_rhs = rhs_ty } + + ; return (ax, vi) } + +checkTyFamInstEqn :: TcTyCon -> Name -> [HsArg p tm ty] -> TcM () +checkTyFamInstEqn tc_fam_tc eqn_tc_name hs_pats = + do { -- Ensure that each equation's type constructor is for the right + -- type family. E.g. barf on + -- type family F a where { G Int = Bool } + let tc_fam_tc_name = getName tc_fam_tc + ; checkTc (tc_fam_tc_name == eqn_tc_name) $ + TcRnIllegalInstance $ IllegalFamilyInstance $ + TyFamNameMismatch tc_fam_tc_name eqn_tc_name + + -- Check the arity of visible arguments + -- If we wait until validity checking, we'll get kind errors + -- below when an arity error will be much easier to understand. + ; let vis_arity = length (tyConVisibleTyVars tc_fam_tc) + vis_pats = numVisibleArgs hs_pats + ; checkTc (vis_pats == vis_arity) $ + TcRnIllegalInstance $ IllegalFamilyInstance $ + FamilyArityMismatch tc_fam_tc vis_arity + } + +{- Note [Instantiating a family tycon] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +It's possible that kind-checking the result of a family tycon applied to +its patterns will instantiate the tycon further. For example, we might +have + + type family F :: k where + F = Int + F = Maybe + +After checking (F :: forall k. k) (with no visible patterns), we still need +to instantiate the k. With data family instances, this problem can be even +more intricate, due to Note [Arity of data families] in GHC.Core.FamInstEnv. See +indexed-types/should_compile/T12369 for an example. + +So, the kind-checker must return the new skolems and args (that is, Type +or (Type -> Type) for the equations above) and the instantiated kind. + +Note [Generalising in tcTyFamInstEqnGuts] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we have something like + type instance forall (a::k) b. F (Proxy t1) _ = rhs + +Then imp_vars = [k], exp_bndrs = [a::k, b] + +We want to quantify over all the free vars of the LHS including + * any invisible kind variables arising from instantiating tycons, + such as Proxy + * wildcards such as '_' above + +The wildcards are particularly awkward: they may need to be quantified + - before the explicit variables k,a,b + - after them + - or even interleaved with them + c.f. Note [Naughty quantification candidates] in GHC.Tc.Utils.TcMType + +So, we use bindOuterFamEqnTKBndrs (which does not create an implication for +the telescope), and generalise over /all/ the variables in the LHS, +without treating the explicitly-quantified ones specially. Wrinkles: + + - When generalising, include the explicit user-specified forall'd + variables, so that we get an error from Validity.checkFamPatBinders + if a forall'd variable is not bound on the LHS + + - We still want to complain about a bad telescope among the user-specified + variables. So in checkFamTelescope we emit an implication constraint + quantifying only over them, purely so that we get a good telescope error. + + - Note that, unlike a type signature like + f :: forall (a::k). blah + we do /not/ care about the Inferred/Specified designation or order for + the final quantified tyvars. Type-family instances are not invoked + directly in Haskell source code, so visible type application etc plays + no role. + +See also Note [Re-quantify type variables in rules] in +GHC.Tc.Gen.Sig, which explains a /very/ similar design when +generalising over the type of a rewrite rule. + +-} + +-------------------------- + +tcTyFamInstEqnGuts :: TyCon -> AssocInstInfo + -> HsOuterFamEqnTyVarBndrs GhcRn -- Implicit and explicit binders + -> HsFamEqnPats GhcRn -- Patterns + -> LHsType GhcRn -- RHS + -> TcM ([TyVar], TyVarSet, [TcType], TcType) + -- (tyvars, non_user_tvs, pats, rhs) +-- Used only for type families, not data families +tcTyFamInstEqnGuts fam_tc mb_clsinfo outer_hs_bndrs hs_pats hs_rhs_ty + = do { traceTc "tcTyFamInstEqnGuts {" (ppr fam_tc $$ ppr outer_hs_bndrs $$ ppr hs_pats) + + -- By now, for type families (but not data families) we should + -- have checked that the number of patterns matches tyConArity + ; skol_info <- mkSkolemInfo FamInstSkol + + -- This code is closely related to the code + -- in GHC.Tc.Gen.HsType.kcCheckDeclHeader_cusk + ; (tclvl, wanted, (outer_bndrs, (lhs_ty, rhs_ty))) + <- pushLevelAndSolveEqualitiesX "tcTyFamInstEqnGuts" $ + bindOuterFamEqnTKBndrs skol_info outer_hs_bndrs $ + do { (lhs_ty, rhs_kind) <- tcFamTyPats fam_tc hs_pats + -- Ensure that the instance is consistent with its + -- parent class (#16008) + ; addConsistencyConstraints mb_clsinfo lhs_ty + ; rhs_ty <- tcCheckLHsTypeInContext hs_rhs_ty (TheKind rhs_kind) + ; return (lhs_ty, rhs_ty) } + + ; outer_bndrs <- scopedSortOuter outer_bndrs + ; let outer_tvs = outerTyVars outer_bndrs + ; checkFamTelescope tclvl outer_hs_bndrs outer_tvs + + ; traceTc "tcTyFamInstEqnGuts 1" (pprTyVars outer_tvs $$ ppr skol_info) + + -- This code (and the stuff immediately above) is very similar + -- to that in tcDataFamInstHeader. Maybe we should abstract the + -- common code; but for the moment I concluded that it's + -- clearer to duplicate it. Still, if you fix a bug here, + -- check there too! + + -- See Note [Generalising in tcTyFamInstEqnGuts] + ; dvs <- candidateQTyVarsWithBinders outer_tvs lhs_ty + ; qtvs <- quantifyTyVars skol_info TryNotToDefaultNonStandardTyVars dvs + ; let final_tvs = scopedSort (qtvs ++ outer_tvs) + -- This scopedSort is important: the qtvs may be /interleaved/ with + -- the outer_tvs. See Note [Generalising in tcTyFamInstEqnGuts] + ; reportUnsolvedEqualities skol_info final_tvs tclvl wanted + + ; traceTc "tcTyFamInstEqnGuts 2" $ + vcat [ ppr fam_tc + , text "lhs_ty:" <+> ppr lhs_ty + , text "final_tvs:" <+> pprTyVars final_tvs ] + + -- See Note [Error on unconstrained meta-variables] in GHC.Tc.Utils.TcMType + -- Example: typecheck/should_fail/T17301 + ; dvs_rhs <- candidateQTyVarsOfType rhs_ty + ; let err_ctx tidy_env + = do { (tidy_env2, rhs_ty) <- zonkTidyTcType tidy_env rhs_ty + ; return (tidy_env2, UninfTyCtx_TyFamRhs rhs_ty) } + ; doNotQuantifyTyVars dvs_rhs err_ctx + + ; (final_tvs, non_user_tvs, lhs_ty, rhs_ty) <- initZonkEnv NoFlexi $ + runZonkBndrT (zonkTyBndrsX final_tvs) $ \ final_tvs -> + do { lhs_ty <- zonkTcTypeToTypeX lhs_ty + ; rhs_ty <- zonkTcTypeToTypeX rhs_ty + ; non_user_tvs <- traverse lookupTyVarX qtvs + ; return (final_tvs, non_user_tvs, lhs_ty, rhs_ty) } + + ; let pats = unravelFamInstPats lhs_ty + -- Note that we do this after solveEqualities + -- so that any strange coercions inside lhs_ty + -- have been solved before we attempt to unravel it + + ; traceTc "tcTyFamInstEqnGuts }" (vcat [ ppr fam_tc, pprTyVars final_tvs ]) + -- Don't try to print 'pats' here, because lhs_ty involves + -- a knot-tied type constructor, so we get a black hole + + ; return (final_tvs, mkVarSet non_user_tvs, pats, rhs_ty) } + +checkFamTelescope :: TcLevel + -> HsOuterFamEqnTyVarBndrs GhcRn + -> [TcTyVar] -> TcM () +-- Emit a constraint (forall a b c. ), so that +-- we will do telescope-checking on a,b,c +-- See Note [Generalising in tcTyFamInstEqnGuts] +checkFamTelescope tclvl hs_outer_bndrs outer_tvs + | HsOuterExplicit { hso_bndrs = bndrs } <- hs_outer_bndrs + , (b_first : _) <- bndrs + , let b_last = last bndrs + = do { skol_info <- mkSkolemInfo (ForAllSkol $ HsTyVarBndrsRn (map unLoc bndrs)) + ; setSrcSpan (combineSrcSpans (getLocA b_first) (getLocA b_last)) $ do + emitResidualTvConstraint skol_info outer_tvs tclvl emptyWC } + | otherwise + = return () + +----------------- +unravelFamInstPats :: TcType -> [TcType] +-- Decompose fam_app to get the argument patterns +-- +-- We expect fam_app to look like (F t1 .. tn) +-- tcFamTyPats is capable of returning ((F ty1 |> co) ty2), +-- but that can't happen here because we already checked the +-- arity of F matches the number of pattern +unravelFamInstPats fam_app + = case tcSplitTyConApp_maybe fam_app of + Just (_, pats) -> pats + Nothing -> panic "unravelFamInstPats: Ill-typed LHS of family instance" + -- 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 issue #15905 + -- for an example of this happening. + +addConsistencyConstraints :: AssocInstInfo -> TcType -> TcM () +-- In the corresponding positions of the class and type-family, +-- ensure the family argument is the same as the class argument +-- E.g class C a b c d where +-- F c x y a :: Type +-- Here the first arg of F should be the same as the third of C +-- and the fourth arg of F should be the same as the first of C +addConsistencyConstraints mb_clsinfo fam_app + | InClsInst { ai_inst_env = inst_env } <- mb_clsinfo + , Just (fam_tc, pats) <- tcSplitTyConApp_maybe fam_app + = do { let eqs = [ (cls_ty, pat) + | (fam_tc_tv, pat) <- tyConTyVars fam_tc `zip` pats + , Just cls_ty <- [lookupVarEnv inst_env fam_tc_tv] ] + ; traceTc "addConsistencyConstraints" (ppr eqs) + ; emitWantedEqs AssocFamPatOrigin eqs } + -- Improve inference; these equalities will not produce errors. + -- See Note [Constraints to ignore] in GHC.Tc.Errors + -- Any mis-match is reports by checkConsistentFamInst + | otherwise + = return () + +{- Note [Constraints in patterns] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +NB: This isn't the whole story. See comment in tcFamTyPats. + +At first glance, it seems there is a complicated story to tell in tcFamTyPats +around constraint solving. After all, type family patterns can now do +GADT pattern-matching, which is jolly complicated. But, there's a key fact +which makes this all simple: everything is at top level! There cannot +be untouchable type variables. There can't be weird interaction between +case branches. There can't be global skolems. + +This means that the semantics of type-level GADT matching is a little +different than term level. If we have + + data G a where + MkGBool :: G Bool + +And then + + type family F (a :: G k) :: k + type instance F MkGBool = True + +we get + + axF : F Bool (MkGBool ) ~ True + +Simple! No casting on the RHS, because we can affect the kind parameter +to F. + +If we ever introduce local type families, this all gets a lot more +complicated, and will end up looking awfully like term-level GADT +pattern-matching. + + +** The new story ** + +Here is really what we want: + +The matcher really can't deal with covars in arbitrary spots in coercions. +But it can deal with covars that are arguments to GADT data constructors. +So we somehow want to allow covars only in precisely those spots, then use +them as givens when checking the RHS. TODO (RAE): Implement plan. + +Note [Quantified kind variables of a family pattern] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider type family KindFam (p :: k1) (q :: k1) + data T :: Maybe k1 -> k2 -> * + type instance KindFam (a :: Maybe k) b = T a b -> Int +The HsBSig for the family patterns will be ([k], [a]) + +Then in the family instance we want to + * Bring into scope [ "k" -> k:*, "a" -> a:k ] + * Kind-check the RHS + * Quantify the type instance over k and k', as well as a,b, thus + type instance [k, k', a:Maybe k, b:k'] + KindFam (Maybe k) k' a b = T k k' a b -> Int + +Notice that in the third step we quantify over all the visibly-mentioned +type variables (a,b), but also over the implicitly mentioned kind variables +(k, k'). In this case one is bound explicitly but often there will be +none. The role of the kind signature (a :: Maybe k) is to add a constraint +that 'a' must have that kind, and to bring 'k' into scope. + + + +************************************************************************ +* * + Data types +* * +************************************************************************ +-} + +dataDeclChecks :: Name + -> Maybe (LHsContext GhcRn) -> DataDefnCons (LConDecl GhcRn) + -> TcM Bool +dataDeclChecks tc_name mctxt cons + = do { let stupid_theta = fromMaybeContext mctxt + -- Check that we don't use GADT syntax in H98 world + ; gadtSyntax_ok <- xoptM LangExt.GADTSyntax + ; let gadt_syntax = anyLConIsGadt cons + ; unless (gadtSyntax_ok || not gadt_syntax) $ + addErrTc (TcRnGADTsDisabled tc_name) + + -- Check that the stupid theta is empty for a GADT-style declaration. + -- See Note [The stupid context] in GHC.Core.DataCon. + ; checkTc (null stupid_theta || not gadt_syntax) (TcRnGADTDataContext tc_name) + + -- Check that there's at least one condecl, + -- or else we're reading an hs-boot file, or -XEmptyDataDecls + ; empty_data_decls <- xoptM LangExt.EmptyDataDecls + ; is_boot <- tcIsHsBootOrSig -- Are we compiling an hs-boot file? + ; unless (not (null cons) || empty_data_decls || is_boot) $ + addErrTc (TcRnEmptyDataDeclsDisabled tc_name) + ; return gadt_syntax } + + +----------------------------------- +data DataDeclInfo + = DDataType -- data T a b = T1 a | T2 b + | DDataInstance -- data instance D [a] = D1 a | D2 + Type -- The header D [a] + +mkDDHeaderTy :: DataDeclInfo -> TyCon -> [TyConBinder] -> Type +mkDDHeaderTy dd_info rep_tycon tc_bndrs + = case dd_info of + DDataType -> mkTyConApp rep_tycon $ + mkTyVarTys (binderVars tc_bndrs) + DDataInstance header_ty -> header_ty + +-- We use `concatMapDataDefnConsTcM` here, since the following is illegal: +-- @newtype T a where T1, T2 :: a -> T a@ +-- It would be represented as a single 'ConDeclGadt' with multiple names, which is valid for 'data', but not 'newtype'. +-- So when 'tcConDecl' expands the 'ConDecl' per each name it has, if we are type-checking a 'newtype' declaration, we +-- must fail if it returns more than one. +tcConDecls :: DataDeclInfo + -> KnotTied TyCon -- Representation TyCon + -> [TcTyConBinder] -- Binders of representation TyCon + -> TcKind -- Result kind + -> DataDefnCons (LConDecl GhcRn) -> TcM (DataDefnCons DataCon) +tcConDecls dd_info rep_tycon tmpl_bndrs res_kind + = concatMapDataDefnConsTcM (tyConName rep_tycon) $ \ new_or_data -> + 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 + +-- 'concatMap' for 'DataDefnCons', but fail if the given function returns multiple values and the argument is a 'NewTypeCon'. +concatMapDataDefnConsTcM :: Name -> (NewOrData -> a -> TcM (NonEmpty b)) -> DataDefnCons a -> TcM (DataDefnCons b) +concatMapDataDefnConsTcM name f = \ case + NewTypeCon a -> f NewType a >>= \ case + b:|[] -> pure (NewTypeCon b) + bs -> failWithTc $ TcRnMultipleConForNewtype name (length bs) + DataTypeCons is_type_data as -> DataTypeCons is_type_data <$> concatMapM (fmap toList . f DataType) as + +tcConDecl :: NewOrData + -> DataDeclInfo + -> KnotTied TyCon -- Representation tycon. Knot-tied! + -> [TcTyConBinder] -- Binders of representation TyCon + -> TcKind -- Result kind + -> NameEnv ConTag + -> ConDecl GhcRn + -> TcM (NonEmpty DataCon) + +tcConDecl new_or_data dd_info rep_tycon tc_bndrs res_kind tag_map + (ConDeclH98 { con_name = lname@(L _ name) + , con_ex_tvs = explicit_tkv_nms + , con_mb_cxt = hs_ctxt + , con_args = hs_args }) + = addErrCtxt (DataConDefCtxt (NE.singleton lname)) $ + do { -- NB: the tyvars from the declaration header are in scope + + -- Get hold of the existential type variables + -- e.g. data T a = forall k (b::k) f. MkT a (f b) + -- Here tc_bndrs = {a} + -- hs_qvars = HsQTvs { hsq_implicit = {k} + -- , hsq_explicit = {f,b} } + + ; traceTc "tcConDecl 1" (vcat [ ppr name + , text "explicit_tkv_nms" <+> ppr explicit_tkv_nms + , text "tc_bndrs" <+> ppr tc_bndrs ]) + ; skol_info <- mkSkolemInfo (ForAllSkol (HsTyVarBndrsRn (unLoc <$> explicit_tkv_nms))) + + ; (tclvl, wanted, (exp_tvbndrs, (ctxt, arg_tys, field_lbls, stricts))) + <- pushLevelAndSolveEqualitiesX "tcConDecl:H98" $ + tcExplicitTKBndrs skol_info explicit_tkv_nms $ + do { ctxt <- tcHsContext hs_ctxt + ; let exp_kind = getArgExpKind new_or_data res_kind + ; btys <- tcConH98Args exp_kind hs_args + ; field_lbls <- lookupConstructorFields $ noUserRdr name + ; let (arg_tys, stricts) = unzip btys + ; return (ctxt, arg_tys, field_lbls, stricts) + } + + + ; let tc_tvs = binderVars tc_bndrs + fake_ty = mkSpecForAllTys tc_tvs $ + mkInvisForAllTys exp_tvbndrs $ + tcMkPhiTy ctxt $ + tcMkScaledFunTys arg_tys $ + unitTy + -- That type is a lie, of course. (It shouldn't end in ()!) + -- And we could construct a proper result type from the info + -- at hand. But the result would mention only the univ_tvs, + -- and so it just creates more work to do it right. Really, + -- we're only doing this to find the right kind variables to + -- quantify over, and this type is fine for that purpose. + + -- exp_tvbndrs have explicit, user-written binding sites + -- the kvs below are those kind variables entirely unmentioned by the user + -- and discovered only by generalization + + ; kvs <- kindGeneralizeAll skol_info fake_ty + + ; let all_skol_tvs = tc_tvs ++ kvs + ; reportUnsolvedEqualities skol_info all_skol_tvs tclvl wanted + -- The skol_info claims that all the variables are bound + -- by the data constructor decl, whereas actually the + -- univ_tvs are bound by the data type decl itself. It + -- would be better to have a doubly-nested implication. + -- But that just doesn't seem worth it. + -- See test dependent/should_fail/T13780a + + -- Zonk to Types + ; (tc_bndrs, kvs, exp_tvbndrs, arg_tys, ctxt) <- initZonkEnv NoFlexi $ + runZonkBndrT (zonkTyVarBindersX tc_bndrs ) $ \ tc_bndrs -> + runZonkBndrT (zonkTyBndrsX kvs ) $ \ kvs -> + runZonkBndrT (zonkTyVarBindersX exp_tvbndrs) $ \ exp_tvbndrs -> + do { arg_tys <- zonkScaledTcTypesToTypesX arg_tys + ; ctxt <- zonkTcTypesToTypesX ctxt + ; return (tc_bndrs, kvs, exp_tvbndrs, arg_tys, ctxt) } + + -- Can't print univ_tvs, arg_tys etc, because we are inside the knot here + ; traceTc "tcConDecl 2" (ppr name $$ ppr field_lbls) + ; let univ_tvbs = tyConInvisTVBinders tc_bndrs + ex_tvbs = mkTyVarBinders InferredSpec kvs ++ exp_tvbndrs + ex_tvs = binderVars ex_tvbs + -- 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 = tyVarSpecToBinders $ univ_tvbs ++ ex_tvbs + user_res_ty = mkDDHeaderTy dd_info rep_tycon tc_bndrs + + ; traceTc "tcConDecl 2" (ppr name) + ; is_infix <- tcConIsInfixH98 name hs_args + ; rep_nm <- newTyConRepName name + ; fam_envs <- tcGetFamInstEnvs + ; dflags <- getDynFlags + ; let bang_opts = SrcBangOpts (initBangOpts dflags) + ; dc <- buildDataCon fam_envs bang_opts name is_infix rep_nm + stricts field_lbls + tc_tvs ex_tvs user_tvbs + [{- no eq_preds -}] ctxt arg_tys + user_res_ty rep_tycon tag_map + -- NB: we put data_tc, the type constructor gotten from the + -- constructor type signature into the data constructor; + -- that way checkValidDataCon can complain if it's wrong. + + ; return (NE.singleton dc) } + +tcConDecl new_or_data dd_info rep_tycon tc_bndrs _res_kind tag_map + -- 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_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 (DataConDefCtxt names) $ + do { traceTc "tcConDecl 1 gadt" (ppr names) + ; let L _ name :| _ = names + ; skol_info <- mkSkolemInfo (DataConSkol name) + ; (tclvl, wanted, (tvbs, (ctxt, arg_tys, res_ty, field_lbls, stricts))) + <- pushLevelAndSolveEqualitiesX "tcConDecl:GADT" $ + tcGadtConTyVarBndrs skol_info outer_bndrs inner_bndrs $ + do { ctxt <- tcHsContext cxt + ; (res_ty, res_kind) <- tcInferLHsTypeKind hs_res_ty + -- See Note [GADT return kinds] + + -- For data instances (only), ensure that the return type, + -- res_ty, is a substitution instance of the header. + -- See Note [GADT return types] + ; case dd_info of + DDataType -> return () + DDataInstance hdr_ty -> + do { (subst, _meta_tvs) <- newMetaTyVars (binderVars tc_bndrs) + ; let head_shape = substTy subst hdr_ty + ; discardResult $ + popErrCtxt $ -- Drop DataConDefCtxt + addErrCtxt (DataConResTyCtxt names) $ + unifyType Nothing res_ty head_shape } + + -- See Note [Datatype return kinds] + ; let exp_kind = getArgExpKind new_or_data res_kind + ; btys <- tcConGADTArgs exp_kind hs_args + + ; let (arg_tys, stricts) = unzip btys + ; field_lbls <- lookupConstructorFields $ noUserRdr name + ; return (ctxt, arg_tys, res_ty, field_lbls, stricts) + } + + ; tkvs <- kindGeneralizeAll skol_info + (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 Inferred tkvs ++ tvbs + + -- Zonk to Types + ; (tvbndrs, arg_tys, ctxt, res_ty) <- initZonkEnv NoFlexi $ + runZonkBndrT (zonkTyVarBindersX tvbndrs) $ \ tvbndrs -> + do { arg_tys <- zonkScaledTcTypesToTypesX arg_tys + ; ctxt <- zonkTcTypesToTypesX ctxt + ; res_ty <- zonkTcTypeToTypeX res_ty + ; return (tvbndrs, arg_tys, ctxt, res_ty) } + + ; let res_tmpl = mkDDHeaderTy dd_info rep_tycon tc_bndrs + (univ_tvs, ex_tvs, tvbndrs', eq_preds, arg_subst) + = rejigConRes tc_bndrs res_tmpl tvbndrs res_ty + -- See Note [rejigConRes] + + ctxt' = substTys arg_subst ctxt + arg_tys' = substScaledTys arg_subst arg_tys + res_ty' = substTy arg_subst res_ty + + -- Can't print univ_tvs, arg_tys etc, because we are inside the knot here + ; traceTc "tcConDecl 2" (ppr names $$ ppr field_lbls) + ; fam_envs <- tcGetFamInstEnvs + ; dflags <- getDynFlags + ; let + buildOneDataCon (L _ name) = do + { is_infix <- tcConIsInfixGADT name hs_args + ; rep_nm <- newTyConRepName name + + ; let bang_opts = SrcBangOpts (initBangOpts dflags) + ; buildDataCon fam_envs bang_opts name is_infix + rep_nm stricts field_lbls + univ_tvs ex_tvs tvbndrs' eq_preds + ctxt' arg_tys' res_ty' rep_tycon tag_map + -- NB: we put data_tc, the type constructor gotten from the + -- constructor type signature into the data constructor; + -- that way checkValidDataCon can complain if it's wrong. + } + ; mapM buildOneDataCon names } + +{- Note [GADT return types] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + data family T :: forall k. k -> Type + data instance T (a :: Type) where + MkT :: forall b. T b + +What kind does `b` have in the signature for MkT? +Since the return type must be an instance of the type in the header, +we must have (b :: Type), but you can't tell that by looking only at +the type of the data constructor; you have to look at the header too. +If you wrote it out fully, it'd look like + data instance T @Type (a :: Type) where + MkT :: forall (b::Type). T @Type b + +We could reject the program, and expect the user to add kind +annotations to `MkT` to restrict the signature. But an easy and +helpful alternative is this: simply instantiate the type from the +header with fresh unification variables, and unify with the return +type of `MkT`. That will force `b` to have kind `Type`. See #8707 +and #14111. + +Wrikles +* At first sight it looks as though this would completely subsume the + return-type check in checkValidDataCon. But it does not. Suppose we + have + data instance T [a] where + MkT :: T (F (Maybe a)) + + where F is a type function. Then maybe (F (Maybe a)) evaluates to + [a], so unifyType will succeed. But we discard the coercion + returned by unifyType; and we really don't want to accept this + program. The check in checkValidDataCon will, however, reject it. + TL;DR: keep the check in checkValidDataCon. + +* Consider a data type, rather than a data instance, declaration + data S a where { MkS :: b -> S [b] } + In tcConDecl, S is knot-tied, so we don't want to unify (S alpha) + with (S [b]). To put it another way, unifyType should never see a + TcTycon. Simple solution: do *not* do the extra unifyType for + data types (DDataType) only for data instances (DDataInstance); in + the latter the family constructor is not knot-tied so there is no + problem. + +* Consider this (from an earlier form of GHC itself): + + data Pass = Parsed | ... + data GhcPass (c :: Pass) where + GhcPs :: GhcPs + ... + type GhcPs = GhcPass 'Parsed + + Now GhcPs and GhcPass are mutually recursive. If we did unifyType + for datatypes like GhcPass, we would not be able to expand the type + synonym (it'd still be a TcTyCon). So again, we don't do unifyType + for data types; we leave it to checkValidDataCon. + + We /do/ perform the unifyType for data /instances/, but a data + instance doesn't declare a new (user-visible) type constructor, so + there is no mutual recursion with type synonyms to worry about. + All good. + + TL;DR we do support mutual recursion between type synonyms and + data type/instance declarations, as above. + +Note [GADT return kinds] +~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + type family Star where Star = Type + data T :: Type where + MkT :: Int -> T + +If, for some stupid reason, tcInferLHsTypeKind on the return type of +MkT returned (T |> ax, Star), then the return-type check in +checkValidDataCon would reject the decl (although of course there is +nothing wrong with it). We are implicitly requiring tha +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 -> ConArgKind +getArgExpKind NewType res_ki = TheKind res_ki +getArgExpKind DataType _ = OpenKind + +tcConIsInfixH98 :: Name + -> HsConDeclH98Details GhcRn + -> TcM Bool +tcConIsInfixH98 _ details + = case details of + InfixCon{} -> return True + RecCon{} -> return False + PrefixCon{} -> return False + +tcConIsInfixGADT :: Name + -> HsConDeclGADTDetails GhcRn + -> TcM Bool +tcConIsInfixGADT con details + = case details of + RecConGADT{} -> return False + PrefixConGADT _ arg_tys -- See Note [Infix GADT constructors] + | isSymOcc (getOccName con) + , [_ty1,_ty2] <- arg_tys + -> do { fix_env <- getFixityEnv + ; return (con `elemNameEnv` fix_env) } + | otherwise -> return False + +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 IsNotPrefixConGADT) btys +tcConH98Args exp_kind (InfixCon bty1 bty2) + = do { bty1' <- tcConArg exp_kind IsNotPrefixConGADT bty1 + ; bty2' <- tcConArg exp_kind IsNotPrefixConGADT bty2 + ; return [bty1', bty2'] } +tcConH98Args exp_kind (RecCon fields) + = tcRecHsConDeclRecFields exp_kind fields + +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 IsPrefixConGADT) btys +tcConGADTArgs exp_kind (RecConGADT _ fields) + = tcRecHsConDeclRecFields exp_kind fields + +tcConArg :: ConArgKind -- expected kind for args; always OpenKind for datatypes, + -- but might be an unlifted type with UnliftedNewtypes + -> IsPrefixConGADT + -> HsConDeclField GhcRn -> TcM (Scaled TcType, HsSrcBang) +tcConArg exp_kind isPrefixConGADT (CDF (_, src) unp str w bty _) + = do { traceTc "tcConArg 1" (ppr bty) + ; arg_ty <- tcCheckLHsTypeInContext bty exp_kind + ; w' <- tcDataConMult isPrefixConGADT w + ; traceTc "tcConArg 2" (ppr bty) + ; return (Scaled w' arg_ty, HsSrcBang src unp str) } + +tcRecHsConDeclRecFields :: ConArgKind + -> LocatedL [LHsConDeclRecField GhcRn] + -> TcM [(Scaled TcType, HsSrcBang)] +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) -> (cdrf_names f, cdrf_spec f)) + (unLoc fields) + explode (ns,ty) = zip ns (repeat ty) + exploded = concatMap explode combined + (_,btys) = unzip exploded + +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] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In the absence of -XLinearTypes, we always interpret function arrows +in GADT constructor types as linear, even if the user wrote an +unrestricted arrow. See the "Without -XLinearTypes" section of the +linear types GHC proposal (#111). We opt to do this in the +typechecker, and not in an earlier pass, to ensure that the AST +matches what the user wrote (#18791). + +Note [Infix GADT constructors] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We do not currently have syntax to declare an infix constructor in GADT syntax, +but it makes a (small) difference to the Show instance. So as a slightly +ad-hoc solution, we regard a GADT data constructor as infix if + a) it is an operator symbol + b) it has two arguments + c) there is a fixity declaration for it +For example: + infix 6 (:--:) + data T a where + (:--:) :: t1 -> t2 -> T Int + + +Note [rejigConRes] +~~~~~~~~~~~~~~~~~~ +There is a delicacy around checking the return types of a datacon. The +central problem is dealing with a declaration like + + data T a where + MkT :: T a -> Q a + +Note that the return type of MkT is totally bogus. When creating the T +tycon, we also need to create the MkT datacon, which must have a "rejigged" +return type. That is, the MkT datacon's type must be transformed to have +a uniform return type with explicit coercions for GADT-like type parameters. +This rejigging is what rejigConRes does. The problem is, though, that checking +that the return type is appropriate is much easier when done over *Type*, +not *HsType*, and doing a call to tcMatchTy will loop because T isn't fully +defined yet. + +So, we want to make rejigConRes lazy and then check the validity of +the return type in checkValidDataCon. To do this we /always/ return a +6-tuple from rejigConRes (so that we can compute the return type from it, which +checkValidDataCon needs), but the first three fields may be bogus if +the return type isn't valid (the last equation for rejigConRes). + +This is better than an earlier solution which reduced the number of +errors reported in one pass. See #7175, and #10836. +-} + +-- Example +-- data instance T (b,c) where +-- TI :: forall e. e -> T (e,e) +-- +-- The representation tycon looks like this: +-- data :R7T b c where +-- TI :: forall b1 c1. (b1 ~ c1) => b1 -> :R7T b1 c1 +-- In this case orig_res_ty = T (e,e) + +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) + -> [TyVarBinder] -- The constructor's type variables (both inferred and user-written) + -> KnotTied Type -- res_ty + -> ([TyVar], -- Universal + [TyVar], -- Existential (distinct OccNames from univs) + [TyVarBinder], -- The constructor's rejigged, user-written + -- type variables + [EqSpec], -- Equality predicates + Subst) -- Substitution to apply to argument types + -- We don't check that the TyCon given in the ResTy is + -- the same as the parent tycon, because checkValidDataCon will do it +-- NB: All arguments may potentially be knot-tied +rejigConRes tc_tvbndrs res_tmpl dc_tvbndrs res_ty + -- E.g. data T [a] b c where + -- MkT :: forall x y z. T [(x,y)] z z + -- The {a,b,c} are the tc_tvs, and the {x,y,z} are the dc_tvs + -- (NB: unlike the H98 case, the dc_tvs are not all existential) + -- Then we generate + -- Univ tyvars Eq-spec + -- a a~(x,y) + -- b b~z + -- z + -- Existentials are the leftover type vars: [x,y] + -- The user-written type variables are what is listed in the forall: + -- [x, y, z] (all specified). We must rejig these as well. + -- See Note [DataCon user type variable binders] in GHC.Core.DataCon. + -- So we return ( [a,b,z], [x,y] + -- , [], [x,y,z] + -- , [a~(x,y),b~z], ) + | Just subst <- tcMatchTy res_tmpl res_ty + = let (univ_tvs, raw_eqs, kind_subst) = mkGADTVars tc_tvs dc_tvs subst + raw_ex_tvs = dc_tvs `minusList` univ_tvs + (arg_subst, substed_ex_tvs) = substTyVarBndrs kind_subst raw_ex_tvs + + -- After rejigging the existential tyvars, the resulting substitution + -- gives us exactly what we need to rejig the user-written tyvars, + -- since the dcUserTyVarBinders invariant guarantees that the + -- substitution has *all* the tyvars in its domain. + -- See Note [DataCon user type variable binders] in GHC.Core.DataCon. + subst_user_tvs = mapVarBndrs (substTyVarToTyVar arg_subst) + substed_tvbndrs = subst_user_tvs dc_tvbndrs + + substed_eqs = [ mkEqSpec (substTyVarToTyVar arg_subst tv) + (substTy arg_subst ty) + | (tv,ty) <- raw_eqs ] + in + (univ_tvs, substed_ex_tvs, substed_tvbndrs, substed_eqs, arg_subst) + + | otherwise + -- If the return type of the data constructor doesn't match the parent + -- type constructor, or the arity is wrong, the tcMatchTy will fail + -- e.g data T a b where + -- T1 :: Maybe a -- Wrong tycon + -- T2 :: T [a] -- Wrong arity + -- We are detect that later, in checkValidDataCon, but meanwhile + -- we must do *something*, not just crash. So we do something simple + -- albeit bogus, relying on checkValidDataCon to check the + -- bad-result-type error before seeing that the other fields look odd + -- See Note [rejigConRes] + = (tc_tvs, dc_tvs `minusList` tc_tvs, dc_tvbndrs, [], emptySubst) + where + dc_tvs = binderVars dc_tvbndrs + tc_tvs = binderVars tc_tvbndrs + +{- Note [mkGADTVars] +~~~~~~~~~~~~~~~~~~~~ +Running example: + +data T (k1 :: *) (k2 :: *) (a :: k2) (b :: k2) where + MkT :: forall (x1 : *) (y :: x1) (z :: *). + T x1 * (Proxy (y :: x1), z) z + +We need the rejigged type to be + + MkT :: forall (x1 :: *) (k2 :: *) (a :: k2) (b :: k2). + forall (y :: x1) (z :: *). + (k2 ~ *, a ~ (Proxy x1 y, z), b ~ z) + => T x1 k2 a b + +You might naively expect that z should become a universal tyvar, +not an existential. (After all, x1 becomes a universal tyvar.) +But z has kind * while b has kind k2, so the return type + T x1 k2 a z +is ill-kinded. Another way to say it is this: the universal +tyvars must have exactly the same kinds as the tyConTyVars. + +So we need an existential tyvar and a heterogeneous equality +constraint. (The b ~ z is a bit redundant with the k2 ~ * that +comes before in that b ~ z implies k2 ~ *. I'm sure we could do +some analysis that could eliminate k2 ~ *. But we don't do this +yet.) + +The data con signature has already been fully kind-checked. +The return type + + T x1 * (Proxy (y :: x1), z) z +becomes + qtkvs = [x1 :: *, y :: x1, z :: *] + res_tmpl = T x1 * (Proxy x1 y, z) z + +We start off by matching (T k1 k2 a b) with (T x1 * (Proxy x1 y, z) z). We +know this match will succeed because of the validity check (actually done +later, but laziness saves us -- see Note [rejigConRes]). +Thus, we get + + subst := { k1 |-> x1, k2 |-> *, a |-> (Proxy x1 y, z), b |-> z } + +Now, we need to figure out what the GADT equalities should be. In this case, +we *don't* want (k1 ~ x1) to be a GADT equality: it should just be a +renaming. The others should be GADT equalities. We also need to make +sure that the universally-quantified variables of the datacon match up +with the tyvars of the tycon, as required for Core context well-formedness. +(This last bit is why we have to rejig at all!) + +`choose` walks down the tycon tyvars, figuring out what to do with each one. +It carries two substitutions: + - t_sub's domain is *template* or *tycon* tyvars, mapping them to variables + mentioned in the datacon signature. + - r_sub's domain is *result* tyvars, names written by the programmer in + the datacon signature. The final rejigged type will use these names, but + the subst is still needed because sometimes the printed name of these variables + is different. (See choose_tv_name, below.) + +Before explaining the details of `choose`, let's just look at its operation +on our example: + + choose [] [] {} {} [k1, k2, a, b] + --> -- first branch of `case` statement + choose + univs: [x1 :: *] + eq_spec: [] + t_sub: {k1 |-> x1} + r_sub: {x1 |-> x1} + t_tvs: [k2, a, b] + --> -- second branch of `case` statement + choose + univs: [k2 :: *, x1 :: *] + eq_spec: [k2 ~ *] + t_sub: {k1 |-> x1, k2 |-> k2} + r_sub: {x1 |-> x1} + t_tvs: [a, b] + --> -- second branch of `case` statement + choose + univs: [a :: k2, k2 :: *, x1 :: *] + eq_spec: [ a ~ (Proxy x1 y, z) + , k2 ~ * ] + t_sub: {k1 |-> x1, k2 |-> k2, a |-> a} + r_sub: {x1 |-> x1} + t_tvs: [b] + --> -- second branch of `case` statement + choose + univs: [b :: k2, a :: k2, k2 :: *, x1 :: *] + eq_spec: [ b ~ z + , a ~ (Proxy x1 y, z) + , k2 ~ * ] + t_sub: {k1 |-> x1, k2 |-> k2, a |-> a, b |-> z} + r_sub: {x1 |-> x1} + t_tvs: [] + --> -- end of recursion + ( [x1 :: *, k2 :: *, a :: k2, b :: k2] + , [k2 ~ *, a ~ (Proxy x1 y, z), b ~ z] + , {x1 |-> x1} ) + +`choose` looks up each tycon tyvar in the matching (it *must* be matched!). + +* If it finds a bare result tyvar (the first branch of the `case` + statement), it checks to make sure that the result tyvar isn't yet + in the list of univ_tvs. If it is in that list, then we have a + repeated variable in the return type, and we in fact need a GADT + equality. + +* It then checks to make sure that the kind of the result tyvar + matches the kind of the template tyvar. This check is what forces + `z` to be existential, as it should be, explained above. + +* Assuming no repeated variables or kind-changing, we wish to use the + variable name given in the datacon signature (that is, `x1` not + `k1`), not the tycon signature (which may have been made up by + GHC). So, we add a mapping from the tycon tyvar to the result tyvar + to t_sub. + +* If we discover that a mapping in `subst` gives us a non-tyvar (the + second branch of the `case` statement), then we have a GADT equality + to create. We create a fresh equality, but we don't extend any + substitutions. The template variable substitution is meant for use + in universal tyvar kinds, and these shouldn't be affected by any + GADT equalities. + +This whole algorithm is quite delicate, indeed. I (Richard E.) see two ways +of simplifying it: + +1) The first branch of the `case` statement is really an optimization, used +in order to get fewer GADT equalities. It might be possible to make a GADT +equality for *every* univ. tyvar, even if the equality is trivial, and then +either deal with the bigger type or somehow reduce it later. + +2) This algorithm strives to use the names for type variables as specified +by the user in the datacon signature. If we always used the tycon tyvar +names, for example, this would be simplified. This change would almost +certainly degrade error messages a bit, though. +-} + +-- | From information about a source datacon definition, extract out +-- what the universal variables and the GADT equalities should be. +-- See Note [mkGADTVars]. +mkGADTVars :: [TyVar] -- ^ The tycon vars + -> [TyVar] -- ^ The datacon vars + -> Subst -- ^ The matching between the template result type + -- and the actual result type + -> ( [TyVar] + , [(TyVar,Type)] -- The un-substituted eq-spec + , Subst ) -- ^ The univ. variables, the GADT equalities, + -- and a subst to apply to the GADT equalities + -- and existentials. +mkGADTVars tmpl_tvs dc_tvs subst + = choose [] [] empty_subst empty_subst tmpl_tvs + where + in_scope = mkInScopeSet (mkVarSet tmpl_tvs `unionVarSet` mkVarSet dc_tvs) + `unionInScope` substInScopeSet subst + empty_subst = mkEmptySubst in_scope + + choose :: [TyVar] -- accumulator of univ tvs, reversed + -> [(TyVar,Type)] -- accumulator of GADT equalities, reversed + -> Subst -- template substitution + -> Subst -- res. substitution + -> [TyVar] -- template tvs (the univ tvs passed in) + -> ( [TyVar] -- the univ_tvs + , [(TyVar,Type)] -- GADT equalities + , Subst ) -- a substitution to fix kinds in ex_tvs + + choose univs eqs _t_sub r_sub [] + = (reverse univs, reverse eqs, r_sub) + choose univs eqs t_sub r_sub (t_tv:t_tvs) + | Just r_ty <- lookupTyVar subst t_tv + = case getTyVar_maybe r_ty of + Just r_tv + | not (r_tv `elem` univs) + , tyVarKind r_tv `eqType` (substTy t_sub (tyVarKind t_tv)) + -> -- simple, well-kinded variable substitution. + -- the name of the universal comes from the result of the ctor + -- see (R2) of Note [DataCon user type variable binders] in GHC.Core.DataCon + choose (r_tv:univs) eqs + (extendTvSubst t_sub t_tv r_ty') + (extendTvSubst r_sub r_tv r_ty') + t_tvs + where + r_tv1 = setTyVarName r_tv (choose_tv_name r_tv t_tv) + r_ty' = mkTyVarTy r_tv1 + + -- Not a simple substitution: make an equality predicate + -- the name of the universal comes from the datatype header + -- see (R2) of Note [DataCon user type variable binders] in GHC.Core.DataCon + _ -> choose (t_tv':univs) eqs' + (extendTvSubst t_sub t_tv (mkTyVarTy t_tv')) + -- We've updated the kind of t_tv, + -- so add it to t_sub (#14162) + r_sub t_tvs + where + tv_kind = tyVarKind t_tv + tv_kind' = substTy t_sub tv_kind + t_tv' = setTyVarKind t_tv tv_kind' + eqs' = (t_tv', r_ty) : eqs + + | otherwise + = choose (t_tv:univs) eqs t_sub r_sub t_tvs + + -- choose an appropriate name for a univ tyvar. + -- This *must* preserve the Unique of the result tv, so that we + -- can detect repeated variables. It prefers user-specified names + -- over system names. A result variable with a system name can + -- happen with GHC-generated implicit kind variables. + choose_tv_name :: TyVar -> TyVar -> Name + choose_tv_name r_tv t_tv + | isSystemName r_tv_name + = setNameUnique t_tv_name (getUnique r_tv_name) + + | otherwise + = r_tv_name + + where + r_tv_name = getName r_tv + t_tv_name = getName t_tv + +{- +Note [Substitution in template variables kinds] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +data G (a :: Maybe k) where + MkG :: G Nothing + +With explicit kind variables + +data G k (a :: Maybe k) where + MkG :: G k1 (Nothing k1) + +Note how k1 is distinct from k. So, when we match the template +`G k a` against `G k1 (Nothing k1)`, we get a subst +[ k |-> k1, a |-> Nothing k1 ]. Even though this subst has two +mappings, we surely don't want to add (k, k1) to the list of +GADT equalities -- that would be overly complex and would create +more untouchable variables than we need. So, when figuring out +which tyvars are GADT-like and which aren't (the fundamental +job of `choose`), we want to treat `k` as *not* GADT-like. +Instead, we wish to substitute in `a`'s kind, to get (a :: Maybe k1) +instead of (a :: Maybe k). This is the reason for dealing +with a substitution in here. + +However, we do not *always* want to substitute. Consider + +data H (a :: k) where + MkH :: H Int + +With explicit kind variables: + +data H k (a :: k) where + MkH :: H * Int + +Here, we have a kind-indexed GADT. The subst in question is +[ k |-> *, a |-> Int ]. Now, we *don't* want to substitute in `a`'s +kind, because that would give a constructor with the type + +MkH :: forall (k :: *) (a :: *). (k ~ *) -> (a ~ Int) -> H k a + +The problem here is that a's kind is wrong -- it needs to be k, not *! +So, if the matching for a variable is anything but another bare variable, +we drop the mapping from the substitution before proceeding. This +was not an issue before kind-indexed GADTs because this case could +never happen. + +************************************************************************ +* * + Validity checking +* * +************************************************************************ + +Validity checking is done once the mutually-recursive knot has been +tied, so we can look at things freely. +-} + +checkValidTyCl :: TyCon -> TcM [TyCon] +-- The returned list is either a singleton (if valid) +-- or a list of "fake tycons" (if not); the fake tycons +-- include any implicits, like promoted data constructors +-- See Note [Recover from validity error] +checkValidTyCl tc + = setSrcSpan (getSrcSpan tc) $ + addTyConCtxt tc $ + recoverM recovery_code $ + do { traceTc "Starting validity for tycon" (ppr tc) + ; checkValidTyCon tc + ; checkTyConConsistentWithBoot tc -- See Note [TyCon boot consistency checking] + ; traceTc "Done validity for tycon" (ppr tc) + ; return [tc] } + where + recovery_code -- See Note [Recover from validity error] + = do { traceTc "Aborted validity for tycon" (ppr tc) + ; return (map mk_fake_tc $ + tc : child_tycons tc) } + + mk_fake_tc tc + | isClassTyCon tc = tc -- Ugh! Note [Recover from validity error] + | otherwise = makeRecoveryTyCon tc + + child_tycons tc = tyConATs tc ++ map promoteDataCon (tyConDataCons tc) + +{- Note [Recover from validity error] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We recover from a validity error in a type or class, which allows us +to report multiple validity errors. In the failure case we return a +TyCon of the right kind, but with no interesting behaviour +(makeRecoveryTyCon). Why? Suppose we have + type T a = Fun +where Fun is a type family of arity 1. The RHS is invalid, but we +want to go on checking validity of subsequent type declarations. +So we replace T with an abstract TyCon which will do no harm. +See indexed-types/should_fail/BadSock and #10896 + +Some notes: + +* We must make fakes for promoted DataCons too. Consider (#15215) + data T a = MkT ... + data S a = ...T...MkT.... + If there is an error in the definition of 'T' we add a "fake type + constructor" to the type environment, so that we can continue to + typecheck 'S'. But we /were not/ adding a fake anything for 'MkT' + and so there was an internal error when we met 'MkT' in the body of + 'S'. + + Similarly for associated types. + +* Painfully, we *don't* want to do this for classes. + Consider tcfail041: + class (?x::Int) => C a where ... + instance C Int + The class is invalid because of the superclass constraint. But + we still want it to look like a /class/, else the instance bleats + that the instance is mal-formed because it hasn't got a class in + the head. + + This is really bogus; now we have in scope a Class that is invalid + in some way, with unknown downstream consequences. A better + alternative might be to make a fake class TyCon. A job for another day. + +* Previously, we used implicitTyConThings to snaffle out the parts + to add to the context. The problem is that this also grabs data con + wrapper Ids. These could be filtered out. But, painfully, getting + the wrapper Ids checks the DataConRep, and forcing the DataConRep + can panic if there is a representation-polymorphic argument. This is #18534. + We don't need the wrapper Ids here anyway. So the code just takes what + it needs, via child_tycons. +-} + +------------------------- +-- For data types declared with record syntax, we require +-- that each constructor that has a field 'f' +-- (a) has the same result type +-- (b) has the same type for 'f' +-- module alpha conversion of the quantified type variables +-- of the constructor. +-- +-- Note that we allow existentials to match because the +-- fields can never meet. E.g +-- data T where +-- T1 { f1 :: b, f2 :: a, f3 ::Int } :: T +-- T2 { f1 :: c, f2 :: c, f3 ::Int } :: T +-- Here we do not complain about f1,f2 because they are existential + +-- | Check that a 'TyCon' is consistent with the one in the hs-boot file, +-- if any. +-- +-- See Note [TyCon boot consistency checking]. +checkTyConConsistentWithBoot :: TyCon -> TcM () +checkTyConConsistentWithBoot tc = + do { gbl_env <- getGblEnv + ; let name = tyConName tc + real_thing = ATyCon tc + boot_info = tcg_self_boot gbl_env + boot_type_env = case boot_info of + NoSelfBoot -> emptyTypeEnv + SelfBoot boot_details -> md_types boot_details + m_boot_info = lookupTypeEnv boot_type_env name + ; case m_boot_info of + Nothing -> return () + Just boot_thing -> checkBootDeclM HsBoot boot_thing real_thing + } + +{- Note [TyCon boot consistency checking] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We want to throw an error when A.hs and A.hs-boot define a TyCon inconsistently, +e.g. + + -- A.hs-boot + type D :: Type + data D + + -- A.hs + data D (k :: Type) = MkD + +Here A.D and A[boot].D have different kinds, so we must error. In addition, we +must error eagerly, lest other parts of the compiler witness this inconsistency +(which was the subject of #16127). To achieve this, we call +checkTyConIsConsistentWithBoot in checkValidTyCl, which is called in +GHC.Tc.TyCl.tcTyClGroup. + +Note that, when calling checkValidTyCl, we must extend the TyCon environment. +For example, we could end up comparing the RHS of two type synonym declarations +to check they are consistent, and these RHS might mention some of the TyCons we +are validity checking, so they need to be in the environment. +-} + +checkValidTyCon :: TyCon -> TcM () +checkValidTyCon tc + | isPrimTyCon tc -- Happens when Haddock'ing GHC.Prim + = return () + + | isWiredIn tc -- validity-checking wired-in tycons is a waste of + -- time. More importantly, a wired-in tycon might + -- violate assumptions. Example: (~) has a superclass + -- mentioning (~#), which is ill-kinded in source Haskell + = traceTc "Skipping validity check for wired-in" (ppr tc) + + | otherwise + = do { traceTc "checkValidTyCon" (ppr tc $$ ppr (tyConClass_maybe tc)) + ; if | Just cl <- tyConClass_maybe tc + -> checkValidClass cl + + | Just syn_rhs <- synTyConRhs_maybe tc + -> do { checkValidType syn_ctxt syn_rhs + ; checkTySynRhs syn_ctxt syn_rhs } + + | Just fam_flav <- famTyConFlav_maybe tc + -> case fam_flav of + { ClosedSynFamilyTyCon (Just ax) + -> addErrCtxt (ClosedFamEqnCtxt tc) $ + checkValidCoAxiom ax + ; ClosedSynFamilyTyCon Nothing -> return () + ; AbstractClosedSynFamilyTyCon -> + do { hsBoot <- tcIsHsBootOrSig + ; checkTc hsBoot $ TcRnAbstractClosedTyFamDecl } + ; DataFamilyTyCon {} -> return () + ; OpenSynFamilyTyCon -> return () + ; BuiltInSynFamTyCon _ -> return () } + + | otherwise -> do + { -- Check the context on the data decl + traceTc "cvtc1" (ppr tc) + ; checkValidTheta (DataTyCtxt name) (tyConStupidTheta tc) + + ; traceTc "cvtc2" (ppr tc) + + ; dflags <- getDynFlags + ; existential_ok <- xoptM LangExt.ExistentialQuantification + ; gadt_ok <- xoptM LangExt.GADTs + ; let ex_ok = existential_ok || gadt_ok + -- Data cons can have existential context + ; mapM_ (checkValidDataCon dflags ex_ok tc) data_cons + ; mapM_ (checkPartialRecordField data_cons) (tyConFieldLabels tc) + + -- Check that fields with the same name share a type + ; mapM_ check_fields groups }} + where + syn_ctxt = TySynCtxt name + name = tyConName tc + data_cons = tyConDataCons tc + + groups = equivClasses cmp_fld (concatMap get_fields data_cons) + -- This spot seems OK with non-determinism. cmp_fld is used only in equivClasses + -- which produces equivalence classes. + -- The order of these equivalence classes might conceivably (non-deterministically) + -- depend on the result of this comparison, but that just affects the order in which + -- fields are checked for compatibility. It will not affect the compiled binary. + cmp_fld (f1,_) (f2,_) = field_label (flLabel f1) `uniqCompareFS` field_label (flLabel f2) + get_fields con = dataConFieldLabels con `zip` repeat con + -- dataConFieldLabels may return the empty list, which is fine + + -- See Note [GADT record selectors] in GHC.Tc.TyCl.Utils + -- We must check (a) that the named field has the same + -- type in each constructor + -- (b) that those constructors have the same result type + -- + -- However, the constructors may have differently named type variable + -- and (worse) we don't know how the correspond to each other. E.g. + -- C1 :: forall a b. { f :: a, g :: b } -> T a b + -- C2 :: forall d c. { f :: c, g :: c } -> T c d + -- + -- So what we do is to ust Unify.tcMatchTys to compare the first candidate's + -- result type against other candidates' types BOTH WAYS ROUND. + -- If they magically agrees, take the substitution and + -- apply them to the latter ones, and see if they match perfectly. + check_fields ((label, con1) :| other_fields) + -- These fields all have the same name, but are from + -- different constructors in the data type + = recoverM (return ()) $ mapM_ checkOne other_fields + -- Check that all the fields in the group have the same type + -- NB: this check assumes that all the constructors of a given + -- data type use the same type variables + where + res1 = dataConOrigResTy con1 + fty1 = dataConFieldType con1 lbl + lbl = flLabel label + + checkOne (_, con2) -- Do it both ways to ensure they are structurally identical + = do { checkFieldCompat lbl con1 con2 res1 res2 fty1 fty2 + ; checkFieldCompat lbl con2 con1 res2 res1 fty2 fty1 } + where + res2 = dataConOrigResTy con2 + fty2 = dataConFieldType con2 lbl + +checkPartialRecordField :: [DataCon] -> FieldLabel -> TcM () +-- Checks the partial record field selector, and warns. +-- See Note [Checking partial record field] +checkPartialRecordField all_cons fld + = setSrcSpan loc $ + warnIf (not is_exhaustive && not (startsWithUnderscore occ_name)) + (TcRnPartialFieldSelector fld) + where + sel = flSelector fld + loc = getSrcSpan sel + occ_name = nameOccName sel + + (cons_with_field, cons_without_field) = partition has_field all_cons + has_field con = fld `elem` (dataConFieldLabels con) + is_exhaustive = all (dataConCannotMatch inst_tys) cons_without_field + + con1 = assert (not (null cons_with_field)) $ head cons_with_field + inst_tys = dataConResRepTyArgs con1 + +checkFieldCompat :: FieldLabelString -> DataCon -> DataCon + -> Type -> Type -> Type -> Type -> TcM () +checkFieldCompat fld con1 con2 res1 res2 fty1 fty2 + = do { checkTc (isJust mb_subst1) (TcRnCommonFieldResultTypeMismatch con1 con2 fld) + ; checkTc (isJust mb_subst2) (TcRnCommonFieldTypeMismatch con1 con2 fld) } + where + mb_subst1 = tcMatchTy res1 res2 + mb_subst2 = tcMatchTyX (expectJust mb_subst1) fty1 fty2 + +------------------------------- +checkValidDataCon :: DynFlags -> Bool -> TyCon -> DataCon -> TcM () +checkValidDataCon dflags existential_ok tc con + = setSrcSpan con_loc $ + 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 + orig_res_ty = dataConOrigResTy con + + ; traceTc "checkValidDataCon" (vcat + [ ppr con, ppr tc, ppr tc_tvs + , ppr res_ty_tmpl <+> dcolon <+> ppr (typeKind res_ty_tmpl) + , ppr orig_res_ty <+> dcolon <+> ppr (typeKind orig_res_ty)]) + + + -- Check that the return type of the data constructor + -- matches the type constructor; eg reject this: + -- data T a where { MkT :: Bogus a } + -- It's important to do this first: + -- see Note [rejigConRes] + -- and c.f. Note [Check role annotations in a second pass] + + -- Check that the return type of the data constructor is an instance + -- of the header of the header of data decl. This checks for + -- data T a where { MkT :: S a } + -- data instance D [a] where { MkD :: D (Maybe b) } + -- see Note [GADT return types] + ; checkTc (isJust (tcMatchTyKi res_ty_tmpl orig_res_ty)) + (TcRnDataConParentTypeMismatch con res_ty_tmpl) + -- Note that checkTc aborts if it finds an error. This is + -- critical to avoid panicking when we call dataConDisplayType + -- on an un-rejiggable datacon! + -- Also NB that we match the *kind* as well as the *type* (#18357) + -- However, if the kind is the only thing that doesn't match, the + -- error message is terrible. E.g. test T18357b + -- type family Star where Star = Type + -- newtype T :: Type where MkT :: Int -> (T :: Star) + + ; traceTc "checkValidDataCon 2" (ppr data_con_display_type) + + -- Check that the result type is a *monotype* + -- e.g. reject this: MkT :: T (forall a. a->a) + -- Reason: it's really the argument of an equality constraint + ; checkValidMonoType orig_res_ty + ; checkEscapingKind (dataConWrapperType con) + + -- For /data/ types check that each argument has a fixed runtime rep + -- If we are dealing with a /newtype/, we allow representation + -- polymorphism regardless of whether or not UnliftedNewtypes + -- is enabled. A later check in checkNewDataCon handles this, + -- producing a better error message than checkTypeHasFixedRuntimeRep would. + ; let check_rr = checkTypeHasFixedRuntimeRep FixedRuntimeRepDataConField + ; unless (isNewTyCon tc) $ + checkNoErrs $ + mapM_ (check_rr . scaledThing) arg_tys + -- The checkNoErrs is to prevent a panic in isVanillaDataCon + -- (called a a few lines down), which can fall over if there is a + -- bang on a representation-polymorphic argument. This is #18534, + -- typecheck/should_fail/T18534 + + -- Extra checks for newtype data constructors. Importantly, these + -- checks /must/ come before the call to checkValidType below. This + -- is because checkValidType invokes the constraint solver, and + -- invoking the solver on an ill formed newtype constructor can + -- confuse GHC to the point of panicking. See #17955 for an example. + ; when (isNewTyCon tc) (checkNewDataCon con) + + -- Check all argument types for validity + ; checkValidType ctxt data_con_display_type + + -- Check that existentials are allowed if they are used + ; unless (existential_ok || isVanillaDataCon con) $ + addErrTc (TcRnExistentialQuantificationDisabled con) + + -- Check that the only constraints in signatures of constructors + -- in a "type data" declaration are equality constraints. + -- See Note [Type data declarations] in GHC.Rename.Module, + -- restriction (R4). + ; when (isTypeDataCon 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 + , not (bang_opt_strict_data bang_opts) + = addErrTc (bad_bang n LazyFieldsDisabled) + + -- Warn about UNPACK without "!" + -- e.g. data T = MkT {-# UNPACK #-} Int + | HsSrcBang _ want_unpack strict_mark <- bang + , isSrcUnpacked want_unpack, not (is_strict strict_mark) + , not (isUnliftedType orig_arg_ty) + = addDiagnosticTc (bad_bang n UnpackWithoutStrictness) + + -- Warn about a redundant ! on an unlifted type + -- e.g. data T = MkT !Int# + | HsSrcBang _ _ SrcStrict <- bang + , isUnliftedType orig_arg_ty + = addDiagnosticTc $ TcRnBangOnUnliftedType orig_arg_ty + + -- Warn about a ~ on an unlifted type (#21951) + -- e.g. data T = MkT ~Int# + | HsSrcBang _ _ SrcLazy <- bang + , isUnliftedType orig_arg_ty + = addDiagnosticTc $ TcRnLazyBangOnUnliftedType orig_arg_ty + + -- Warn about unusable UNPACK pragmas + -- e.g. data T a = MkT {-# UNPACK #-} !a -- Can't unpack + | HsSrcBang _ want_unpack _ <- bang + + -- See Note [Detecting useless UNPACK pragmas] in GHC.Core.DataCon. + , isSrcUnpacked want_unpack -- this means the user wrote {-# UNPACK #-} + , case rep_bang of { HsUnpack {} -> False; HsStrict True -> False; _ -> True } + + -- When typechecking an indefinite package in Backpack, we + -- may attempt to UNPACK an abstract type. The test here will + -- conclude that this is unusable, but it might become usable + -- when we actually fill in the abstract type. As such, don't + -- 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 UnusableUnpackPragma) + + | otherwise + = return () + + ; void $ zipWith4M check_bang (map scaledThing $ dataConOrigArgTys con) + (dataConSrcBangs con) (dataConImplBangs con) [1..] + + -- Check the dcUserTyVarBinders invariant + -- See Note [DataCon user type variable binders] in GHC.Core.DataCon + -- checked here because we sometimes build invalid DataCons before + -- erroring above here + ; when debugIsOn $ whenNoErrs $ + massertPpr (checkDataConTyVars con) $ + ppr con $$ ppr (dataConFullSig con) $$ ppr (dataConUserTyVars con) + + ; 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)) + , case tyConFamInst_maybe (dataConTyCon con) of + Nothing -> text "not family" + Just (f, _) -> ppr (tyConBinders f) ] + } + where + bang_opts = initBangOpts dflags + con_name = dataConName con + con_loc = nameSrcSpan con_name + ctxt = ConArgCtxt con_name + is_strict = \case + NoSrcStrict -> bang_opt_strict_data bang_opts + bang -> isSrcStrict bang + + bad_bang n + = TcRnBadFieldAnnotation n con + + show_linear_types = xopt LangExt.LinearTypes dflags + data_con_display_type = dataConDisplayType show_linear_types con + +------------------------------- +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 +-- newtype C = MkC Int# +-- But they are caught earlier, by GHC.Tc.Gen.HsType.checkDataKindSig +checkNewDataCon con + = do { show_linear_types <- xopt LangExt.LinearTypes <$> getDynFlags + ; checkNoErrs $ + -- Fail here if the newtype is invalid: subsequent code in + -- checkValidDataCon can fall over if it comes across an invalid newtype. + do { case arg_tys of + [Scaled arg_mult _] -> + unless (ok_mult arg_mult) $ + addErrTc $ + TcRnIllegalNewtype con show_linear_types IsNonLinear + _ -> + addErrTc $ + TcRnIllegalNewtype con show_linear_types (DoesNotHaveSingleField $ length arg_tys) + + -- Add an error if the newtype is a GADt or has existentials. + -- + -- If the newtype is a GADT, the GADT error is enough; + -- we don't need to *also* complain about existentials. + ; if not (null eq_spec) + then addErrTc $ TcRnIllegalNewtype con show_linear_types IsGADT + else unless (null ex_tvs) $ + addErrTc $ + TcRnIllegalNewtype con show_linear_types HasExistentialTyVar + + ; unless (null theta) $ + addErrTc $ + TcRnIllegalNewtype con show_linear_types HasConstructorContext + + ; unless (all ok_bang (dataConSrcBangs con)) $ + addErrTc $ + TcRnIllegalNewtype con show_linear_types HasStrictnessAnnotation } } + where + + (_univ_tvs, ex_tvs, eq_spec, theta, arg_tys, _res_ty) + = dataConFullSig con + + ok_bang (HsSrcBang _ _ SrcStrict) = False + ok_bang (HsSrcBang _ _ SrcLazy) = False + ok_bang _ = True + + ok_mult OneTy = True + ok_mult _ = False + +------------------------------- +checkValidClass :: Class -> TcM () +checkValidClass cls + = do { constrained_class_methods <- xoptM LangExt.ConstrainedClassMethods + ; multi_param_type_classes <- xoptM LangExt.MultiParamTypeClasses + ; nullary_type_classes <- xoptM LangExt.NullaryTypeClasses + ; fundep_classes <- xoptM LangExt.FunctionalDependencies + ; undecidable_super_classes <- xoptM LangExt.UndecidableSuperClasses + + -- Check that the class is unary, unless multiparameter type classes + -- are enabled; also recognize deprecated nullary type classes + -- extension (subsumed by multiparameter type classes, #8993) + ; checkTc (multi_param_type_classes || cls_arity == 1 || + (nullary_type_classes && cls_arity == 0)) + (TcRnClassExtensionDisabled cls (MultiParamDisabled cls_arity)) + ; unless (fundep_classes || null fundeps) $ + addErrTc (TcRnClassExtensionDisabled cls FunDepsDisabled) + + -- Check the super-classes + ; checkValidTheta (ClassSCCtxt (className cls)) theta + + -- Now check for cyclic superclasses + -- If there are superclass cycles, checkClassCycleErrs bails. + ; unless undecidable_super_classes $ + case checkClassCycles cls of + Just err -> setSrcSpan (getSrcSpan cls) $ + addErrTc (TcRnSuperclassCycle err) + Nothing -> return () + + -- Check the class operations. + -- But only if there have been no earlier errors + -- See Note [Abort when superclass cycle is detected] + ; whenNoErrs $ + mapM_ (check_op constrained_class_methods) op_stuff + + -- Check the associated type defaults are well-formed and instantiated + ; mapM_ check_at at_stuff } + where + (tyvars, fundeps, theta, _, at_stuff, op_stuff) = classExtraBigSig cls + cls_arity = length (tyConVisibleTyVars (classTyCon cls)) + -- Ignore invisible variables + cls_tv_set = mkVarSet tyvars + + check_op constrained_class_methods (sel_id, dm) + = setSrcSpan (getSrcSpan sel_id) $ + 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 + -- Example: tc223 + -- class Error e => Game b mv e | b -> mv e where + -- newBoard :: MonadState b m => m () + -- Here, MonadState has a fundep m->b, so newBoard is fine + + -- NB: we don't check that the class method is not representation-polymorphic here, + -- as GHC.TcGen.TyCl.tcClassSigType already includes a subtype check that guarantees + -- typeclass methods always have kind 'Type'. + -- + -- Test case: rep-poly/RepPolyClassMethod. + + ; unless constrained_class_methods $ + mapM_ check_constraint op_theta + + ; check_dm ctxt sel_id cls_pred tau2 dm + } + where + ctxt = FunSigCtxt op_name (WantRRC (getSrcSpan cls)) -- Report redundant class constraints + op_name = idName sel_id + op_ty = idType sel_id + (_,cls_pred,tau1) = tcSplitMethodTy op_ty + -- See Note [Splitting nested sigma types in class type signatures] + (_,op_theta,tau2) = tcSplitNestedSigmaTys tau1 + + check_constraint :: TcPredType -> TcM () + check_constraint pred -- See Note [Class method constraints] + = when (not (isEmptyVarSet pred_tvs) && + pred_tvs `subVarSet` cls_tv_set) + (addErrTc (TcRnClassExtensionDisabled cls (ConstrainedClassMethodsDisabled sel_id pred))) + where + pred_tvs = tyCoVarsOfType pred + + check_at (ATI fam_tc m_dflt_rhs) + = do { traceTc "ati" (ppr fam_tc $$ ppr tyvars $$ ppr fam_tvs) + ; checkTc (cls_arity == 0 || any (`elemVarSet` cls_tv_set) fam_tvs) $ + TcRnIllegalInstance $ IllegalFamilyInstance $ + InvalidAssoc $ InvalidAssocInstance $ + AssocNoClassTyVar cls fam_tc + -- Check that the associated type mentions at least + -- one of the class type variables + -- The check is disabled for nullary type classes, + -- since there is no possible ambiguity (#10020) + + -- Check that any default declarations for associated types are valid + ; whenIsJust m_dflt_rhs $ \ (_, at_validity_info) -> + case at_validity_info of + NoVI -> pure () + VI { vi_loc = loc + , vi_qtvs = qtvs + , 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 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 }} + where + fam_tvs = tyConTyVars fam_tc + + check_dm :: UserTypeCtxt -> Id -> PredType -> Type -> DefMethInfo -> TcM () + -- Check validity of the /top-level/ generic-default type + -- E.g for class C a where + -- default op :: forall b. (a~b) => blah + -- we do not want to do an ambiguity check on a type with + -- a free TyVar 'a' (#11608). See TcType + -- Note [TyVars and TcTyVars during type checking] in GHC.Tc.Utils.TcType + -- Hence the mkDefaultMethodType to close the type. + check_dm ctxt sel_id vanilla_cls_pred vanilla_tau + (Just (dm_name, dm_spec@(GenericDM dm_ty))) + = setSrcSpan (getSrcSpan dm_name) $ do + -- We have carefully set the SrcSpan on the generic + -- default-method Name to be that of the generic + -- default type signature + + -- First, we check that the method's default type signature + -- aligns with the non-default type signature. + -- See Note [Default method type signatures must align] + let cls_pred = mkClassPred cls $ mkTyVarTys $ classTyVars cls + -- Note that the second field of this tuple contains the context + -- of the default type signature, making it apparent that we + -- ignore method contexts completely when validity-checking + -- default type signatures. See the end of + -- Note [Default method type signatures must align] + -- to learn why this is OK. + -- + -- See also + -- Note [Splitting nested sigma types in class type signatures] + -- for an explanation of why we don't use tcSplitSigmaTy here. + (_, _, dm_tau) = tcSplitNestedSigmaTys dm_ty + + -- Given this class definition: + -- + -- class C a b where + -- op :: forall p q. (Ord a, D p q) + -- => a -> b -> p -> (a, b) + -- default op :: forall r s. E r + -- => a -> b -> s -> (a, b) + -- + -- We want to match up two types of the form: + -- + -- Vanilla type sig: C aa bb => aa -> bb -> p -> (aa, bb) + -- Default type sig: C a b => a -> b -> s -> (a, b) + -- + -- Notice that the two type signatures can be quantified over + -- different class type variables! Therefore, it's important that + -- we include the class predicate parts to match up a with aa and + -- b with bb. + vanilla_phi_ty = mkPhiTy [vanilla_cls_pred] vanilla_tau + dm_phi_ty = mkPhiTy [cls_pred] dm_tau + + traceTc "check_dm" $ vcat + [ text "vanilla_phi_ty" <+> ppr vanilla_phi_ty + , text "dm_phi_ty" <+> ppr dm_phi_ty ] + + -- Actually checking that the types align is done with a call to + -- tcMatchTys. We need to get a match in both directions to rule + -- out degenerate cases like these: + -- + -- class Foo a where + -- foo1 :: a -> b + -- default foo1 :: a -> Int + -- + -- foo2 :: a -> Int + -- default foo2 :: a -> b + 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) + check_dm _ _ _ _ _ = return () + +checkFamFlag :: Name -> TcM () +-- Check that we don't use families without -XTypeFamilies +-- The parser won't even parse them, but I suppose a GHC API +-- client might have a go! +checkFamFlag tc_name + = do { idx_tys <- xoptM LangExt.TypeFamilies + ; unless idx_tys $ addErrTc (TcRnTyFamsDisabled (TyFamsDisabledFamily tc_name)) } + +checkResultSigFlag :: Name -> FamilyResultSig GhcRn -> TcM () +checkResultSigFlag tc_name (TyVarSig _ tvb) + = do { ty_fam_deps <- xoptM LangExt.TypeFamilyDependencies + ; unless ty_fam_deps $ addErrTc (TcRnTyFamResultDisabled tc_name tvb) } +checkResultSigFlag _ _ = return () -- other cases OK + +{- Note [Class method constraints] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Haskell 2010 is supposed to reject + class C a where + op :: Eq a => a -> a +where the method type constrains only the class variable(s). (The extension +-XConstrainedClassMethods switches off this check.) But regardless +we should not reject + class C a where + op :: (?x::Int) => a -> a +as pointed out in #11793. So the test here rejects the program if + * -XConstrainedClassMethods is off + * the tyvars of the constraint are non-empty + * all the tyvars are class tyvars, none are locally quantified + +Note [Abort when superclass cycle is detected] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We must avoid doing the ambiguity check for the methods (in +checkValidClass.check_op) when there are already errors accumulated. +This is because one of the errors may be a superclass cycle, and +superclass cycles cause canonicalization to loop. Here is a +representative example: + + class D a => C a where + meth :: D a => () + class C a => D a + +This fixes #9415, #9739 + +Note [Default method type signatures must align] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +GHC enforces the invariant that a class method's default type signature +must "align" with that of the method's non-default type signature, as per +GHC #12918. For instance, if you have: + + class Foo a where + bar :: forall b. Context => a -> b + +Then a default type signature for bar must be alpha equivalent to +(forall b. a -> b). That is, the types must be the same modulo differences in +contexts. So the following would be acceptable default type signatures: + + default bar :: forall b. Context1 => a -> b + default bar :: forall x. Context2 => a -> x + +But the following are NOT acceptable default type signatures: + + default bar :: forall b. b -> a + default bar :: forall x. x + default bar :: a -> Int + +Note that a is bound by the class declaration for Foo itself, so it is +not allowed to differ in the default type signature. + +The default type signature (default bar :: a -> Int) deserves special mention, +since (a -> Int) is a straightforward instantiation of (forall b. a -> b). To +write this, you need to declare the default type signature like so: + + default bar :: forall b. (b ~ Int). a -> b + +As noted in #12918, there are several reasons to do this: + +1. It would make no sense to have a type that was flat-out incompatible with + the non-default type signature. For instance, if you had: + + class Foo a where + bar :: a -> Int + default bar :: a -> Bool + + Then that would always fail in an instance declaration. So this check + nips such cases in the bud before they have the chance to produce + confusing error messages. + +2. Internally, GHC uses TypeApplications to instantiate the default method in + an instance. See Note [Default methods in instances] in GHC.Tc.TyCl.Instance. + Thus, GHC needs to know exactly what the universally quantified type + variables are, and when instantiated that way, the default method's type + must match the expected type. + +3. Aesthetically, by only allowing the default type signature to differ in its + context, we are making it more explicit the ways in which the default type + signature is less polymorphic than the non-default type signature. + +You might be wondering: why are the contexts allowed to be different, but not +the rest of the type signature? That's because default implementations often +rely on assumptions that the more general, non-default type signatures do not. +For instance, in the Enum class declaration: + + class Enum a where + enum :: [a] + default enum :: (Generic a, GEnum (Rep a)) => [a] + enum = map to genum + + class GEnum f where + genum :: [f a] + +The default implementation for enum only works for types that are instances of +Generic, and for which their generic Rep type is an instance of GEnum. But +clearly enum doesn't _have_ to use this implementation, so naturally, the +context for enum is allowed to be different to accommodate this. As a result, +when we validity-check default type signatures, we ignore contexts completely. + +Note that when checking whether two type signatures match, we must take care to +split as many foralls as it takes to retrieve the tau types we which to check. +See Note [Splitting nested sigma types in class type signatures]. + +Extra note: July 22. If we have + class C a b where + op :: op_ty + default op :: def_ty + op = blah + +then we'll generate something like + $gdm_op :: C a b => def_ty + $gdm_op = blah + +We expect to write an instance that looks (in effect) like this: + instance G => C t1 t2 where + op = $gdm_op -- Added when you leave out binding for 'op' + +So we need that + assuming constraints G, and C t1 t2, + we have (def_ty[t1/a,t2/b] <= op_ty[t1/a,t2/b] + +In the validity check, we want to check that there is such a G. +E.g. if we check def_ty <= op_ty, and get an insoluble constraint +(Int~Bool), we know there will never be such a G, and can complain. + +This seems to be a more general way of thinking about the problem. +But no one is complaining, so it'll have to wait for another day + +Note [Splitting nested sigma types in class type signatures] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this type synonym and class definition: + + type Traversal s t a b = forall f. Applicative f => (a -> f b) -> s -> f t + + class Each s t a b where + each :: Traversal s t a b + default each :: (Traversable g, s ~ g a, t ~ g b) => Traversal s t a b + +It might seem obvious that the tau types in both type signatures for `each` +are the same, but actually getting GHC to conclude this is surprisingly tricky. +That is because in general, the form of a class method's non-default type +signature is: + + forall a. C a => forall d. D d => E a b + +And the general form of a default type signature is: + + forall f. F f => E a f -- The variable `a` comes from the class + +So it you want to get the tau types in each type signature, you might find it +reasonable to call tcSplitSigmaTy twice on the non-default type signature, and +call it once on the default type signature. For most classes and methods, this +will work, but Each is a bit of an exceptional case. The way `each` is written, +it doesn't quantify any additional type variables besides those of the Each +class itself, so the non-default type signature for `each` is actually this: + + forall s t a b. Each s t a b => Traversal s t a b + +Notice that there _appears_ to only be one forall. But there's actually another +forall lurking in the Traversal type synonym, so if you call tcSplitSigmaTy +twice, you'll also go under the forall in Traversal! That is, you'll end up +with: + + (a -> f b) -> s -> f t + +A problem arises because you only call tcSplitSigmaTy once on the default type +signature for `each`, which gives you + + Traversal s t a b + +Or, equivalently: + + forall f. Applicative f => (a -> f b) -> s -> f t + +This is _not_ the same thing as (a -> f b) -> s -> f t! So now tcMatchTy will +say that the tau types for `each` are not equal. + +A solution to this problem is to use tcSplitNestedSigmaTys instead of +tcSplitSigmaTy. tcSplitNestedSigmaTys will always split any foralls that it +sees until it can't go any further, so if you called it on the default type +signature for `each`, it would return (a -> f b) -> s -> f t like we desired. + +Note [Checking partial record field] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +This check checks the partial record field selector, and warns (#7169). + +For example: + + data T a = A { m1 :: a, m2 :: a } | B { m1 :: a } + +The function 'm2' is partial record field, and will fail when it is applied to +'B'. The warning identifies such partial fields. The check is performed at the +declaration of T, not at the call-sites of m2. + +The warning can be suppressed by prefixing the field-name with an underscore. +For example: + + data T a = A { m1 :: a, _m2 :: a } | B { m1 :: a } + +************************************************************************ +* * + Checking role validity +* * +************************************************************************ +-} + +checkValidRoleAnnots :: RoleAnnotEnv -> TyCon -> TcM () +checkValidRoleAnnots role_annots tc + | isTypeSynonymTyCon tc = check_no_roles + | isFamilyTyCon tc = check_no_roles + | isAlgTyCon tc = check_roles + | otherwise = return () + where + -- Role annotations are given only on *explicit* variables, + -- but a tycon stores roles for all variables. + -- So, we drop the implicit roles (which are all Nominal, anyway). + name = tyConName tc + roles = tyConRoles tc + (vis_roles, vis_vars) = unzip $ mapMaybe pick_vis $ + zip roles (tyConBinders tc) + role_annot_decl_maybe = lookupRoleAnnot role_annots name + + pick_vis :: (Role, TyConBinder) -> Maybe (Role, TyVar) + pick_vis (role, tvb) + | isVisibleTyConBinder tvb = Just (role, binderVar tvb) + | otherwise = Nothing + + check_roles = case role_annot_decl_maybe of + Nothing -> + setSrcSpan (getSrcSpan name) $ + -- See Note [Missing role annotations warning] + warnIf (not (isClassTyCon tc) && not (null vis_roles)) $ + TcRnMissingRoleAnnotation name vis_roles + Just (decl@(L loc (RoleAnnotDecl _ _ the_role_annots))) -> + addErrCtxt (RoleAnnotErrCtxt name) $ + setSrcSpanA loc $ do + { role_annots_ok <- xoptM LangExt.RoleAnnotations + ; unless role_annots_ok $ addErrTc $ TcRnRoleAnnotationsDisabled tc + ; checkTc (vis_vars `equalLength` the_role_annots) + (TcRnRoleCountMismatch (length vis_vars) decl) + ; _ <- zipWith3M checkRoleAnnot vis_vars the_role_annots vis_roles + -- Representational or phantom roles for class parameters + -- quickly lead to incoherence. So, we require + -- IncoherentInstances to have them. See #8773, #14292 + ; incoherent_roles_ok <- xoptM LangExt.IncoherentInstances + ; checkTc ( incoherent_roles_ok + || (not $ isClassTyCon tc) + || (all (== Nominal) vis_roles)) + (TcRnIncoherentRoles tc) + + ; lint <- goptM Opt_DoCoreLinting + ; when lint $ checkValidRoles tc } + + check_no_roles + = whenIsJust role_annot_decl_maybe illegalRoleAnnotDecl + +-- Note [Missing role annotations warning] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- We warn about missing role annotations for tycons +-- 1. not type-classes: +-- type classes are nominal by default, which is most conservative +-- choice. E.g. we cannot have a type-class with an (accidentally) +-- phantom or representational type variable, as we can with +-- data types. +-- 2. with visible roles +-- +-- We don't make any exceptions for other data types. +-- In particular we explicitly warn about omitted (default and common) +-- representational roles. That is the point of the warning. +-- For example the default representational role for `Map`s key type parameter +-- would be wrong, and this warning is there to warn about it, +-- asking users to be explicit. +-- +-- If the default roles have been nominal, i.e. as conservative as possible, +-- the warning would still be valuable, as most types can be `representational` +-- (c.f. type-classes, which usually cannot). +-- +-- We don't warn about types with invisible roles only, because users cannot +-- specify them: +-- +-- type Foo :: forall {k}. Type +-- data Foo = Foo Int +-- type role Foo phantom +-- +-- is incorrect, GHC complains: +-- Wrong number of roles listed in role annotation; +-- Expected 0, got 1: +-- + +checkRoleAnnot :: TyVar -> LocatedAn NoEpAnns (Maybe Role) -> Role -> TcM () +checkRoleAnnot _ (L _ Nothing) _ = return () +checkRoleAnnot tv (L _ (Just r1)) r2 + = when (r1 /= r2) $ + addErrTc $ TcRnRoleMismatch (tyVarName tv) r1 r2 + +-- This is a double-check on the role inference algorithm. It is only run when +-- -dcore-lint is enabled. See Note [Role inference] in GHC.Tc.TyCl.Utils +checkValidRoles :: TyCon -> TcM () +-- If you edit this function, you may need to update the GHC formalism +-- See Note [GHC Formalism] in GHC.Core.Lint +checkValidRoles tc + | isAlgTyCon tc + -- tyConDataCons returns an empty list for data families + = mapM_ check_dc_roles (tyConDataCons tc) + | Just rhs <- synTyConRhs_maybe tc + = check_ty_roles (zipVarEnv (tyConTyVars tc) (tyConRoles tc)) Representational rhs + | otherwise + = return () + where + check_dc_roles datacon + = do { traceTc "check_dc_roles" (ppr datacon <+> ppr (tyConRoles tc)) + ; mapM_ (check_ty_roles role_env Representational) $ + eqSpecPreds eq_spec ++ theta ++ map scaledThing arg_tys } + -- See Note [Role-checking data constructor arguments] in GHC.Tc.TyCl.Utils + where + (univ_tvs, ex_tvs, eq_spec, theta, arg_tys, _res_ty) + = dataConFullSig datacon + univ_roles = zipVarEnv univ_tvs (tyConRoles tc) + -- zipVarEnv uses zipEqual, but we don't want that for ex_tvs + ex_roles = mkVarEnv (map (, Nominal) ex_tvs) + role_env = univ_roles `plusVarEnv` ex_roles + + check_ty_roles env role ty + | Just ty' <- coreView ty -- #14101 + = check_ty_roles env role ty' + + check_ty_roles env role (TyVarTy tv) + = case lookupVarEnv env tv of + Just role' -> unless (role' `ltRole` role || role' == role) $ + report_error role $ TyVarRoleMismatch tv role' + Nothing -> report_error role $ TyVarMissingInEnv tv + + check_ty_roles env Representational (TyConApp tc tys) + = let roles' = tyConRoles tc in + zipWithM_ (maybe_check_ty_roles env) roles' tys + + check_ty_roles env Nominal (TyConApp _ tys) + = mapM_ (check_ty_roles env Nominal) tys + + check_ty_roles _ Phantom ty@(TyConApp {}) + = pprPanic "check_ty_roles" (ppr ty) + + check_ty_roles env role (AppTy ty1 ty2) + = check_ty_roles env role ty1 + >> check_ty_roles env Nominal ty2 + + check_ty_roles env role (FunTy _ w ty1 ty2) + = check_ty_roles env Nominal w + >> check_ty_roles env role ty1 + >> check_ty_roles env role ty2 + + check_ty_roles env role (ForAllTy (Bndr tv _) ty) + = check_ty_roles env Nominal (tyVarKind tv) + >> check_ty_roles (extendVarEnv env tv Nominal) role ty + + check_ty_roles _ _ (LitTy {}) = return () + + check_ty_roles env role (CastTy t _) + = check_ty_roles env role t + + check_ty_roles _ role (CoercionTy co) + = unless (role == Phantom) $ + report_error role $ BadCoercionRole co + + maybe_check_ty_roles env role ty + = when (role == Nominal || role == Representational) $ + check_ty_roles env role ty + + report_error role reason + = addErrTc $ TcRnRoleValidationFailed role reason + +{- +************************************************************************ +* * + Error messages +* * +************************************************************************ +-} + +tcMkDeclCtxt :: TyClDecl GhcRn -> ErrCtxtMsg +tcMkDeclCtxt decl = + TyConDeclCtxt (tcdName decl) (tyClDeclFlavour decl) + +addVDQNote :: TcTyCon -> TcM a -> TcM a +-- See Note [Inferring visible dependent quantification] +-- Only types without a signature (CUSK or SAKS) here +addVDQNote tycon thing_inside + | assertPpr (isMonoTcTyCon tycon) (ppr tycon $$ ppr tc_kind) + has_vdq + = addLandmarkErrCtxt (VDQWarningCtxt tycon) thing_inside + | otherwise + = thing_inside + where + -- Check whether a tycon has visible dependent quantification. + -- This will *always* be a TcTyCon. Furthermore, it will *always* + -- be an ungeneralised TcTyCon, straight out of kcInferDeclHeader. + -- Thus, all the TyConBinders will be anonymous. Thus, the + -- free variables of the tycon's kind will be the same as the free + -- variables from all the binders. + has_vdq = any is_vdq_tcb (tyConBinders tycon) + tc_kind = tyConKind tycon + kind_fvs = tyCoVarsOfType tc_kind + + is_vdq_tcb tcb = (binderVar tcb `elemVarSet` kind_fvs) && + isVisibleTyConBinder tcb + +tcAddDeclCtxt :: TyClDecl GhcRn -> TcM a -> TcM a +tcAddDeclCtxt decl thing_inside + = addErrCtxt (tcMkDeclCtxt decl) thing_inside + +tcAddOpenTyFamInstCtxt :: AssocInstInfo -> TyFamInstDecl GhcRn -> TcM a -> TcM a +tcAddOpenTyFamInstCtxt mb_assoc decl + = tcAddFamInstCtxt flav (tyFamInstDeclName decl) + where + assoc = case mb_assoc of + NotAssociated -> Nothing + InClsInst { ai_class = cls } -> Just $ classTyCon cls + flav = TyConInstFlavour + { tyConInstFlavour = OpenFamilyFlavour IAmType assoc + , tyConInstIsDefault = False + } + +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 + +tcAddDataFamInstCtxt :: AssocInstInfo -> NewOrData -> DataFamInstDecl GhcRn -> TcM a -> TcM a +tcAddDataFamInstCtxt assoc new_or_data decl + = addErrCtxt (tcMkDataFamInstCtxt assoc new_or_data decl) + +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) + = setErrCtxt [] $ + setSrcSpanA loc $ + addErrTc $ TcRnIllegalRoleAnnotation role + +addTyConCtxt :: TyCon -> TcM a -> TcM a +addTyConCtxt tc = addErrCtxt (TyConDeclCtxt name flav) + where + name = getName tc + flav = tyConFlavour tc 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 @@ -4,13 +4,13 @@ -} - {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} module GHC.Tc.TyCl.Build ( buildDataCon, buildPatSyn, - TcMethInfo, MethInfo, buildClass, + TcMethInfo, MethInfo, + buildClass, buildAbstractClass, mkNewTyConRhs, newImplicitBinder, newTyConRepName ) where @@ -155,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 @@ -184,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 } @@ -289,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") @@ -331,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) @@ -368,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 } @@ -388,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 @@ -413,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 @@ -35,22 +35,24 @@ import GHC.Tc.Gen.Bind import GHC.Tc.Utils.Env import GHC.Tc.Utils.Unify -import GHC.Tc.Utils.Instantiate( tcSuperSkolTyVars ) +import GHC.Tc.Utils.Instantiate( newFamInst, tcSuperSkolTyVars ) import GHC.Tc.Gen.HsType import GHC.Tc.Utils.TcMType -import GHC.Core.Type ( extendTvSubstWithClone, piResultTys ) -import GHC.Core.Predicate -import GHC.Core.Multiplicity import GHC.Tc.Types.Origin import GHC.Tc.Utils.TcType import GHC.Tc.Utils.Monad import GHC.Tc.TyCl.Build( TcMethInfo ) + +import GHC.Core.Type ( extendTvSubstWithClone, piResultTys ) +import GHC.Core.Predicate +import GHC.Core.Multiplicity import GHC.Core.Class import GHC.Core.Coercion ( pprCoAxiom ) -import GHC.Driver.Session -import GHC.Tc.Instance.Family import GHC.Core.FamInstEnv -import GHC.Types.Error +import GHC.Core.TyCon + +import GHC.Driver.DynFlags + import GHC.Types.Id import GHC.Types.Name import GHC.Types.Name.Env @@ -58,14 +60,13 @@ import GHC.Types.Var import GHC.Types.Var.Env ( lookupVarEnv ) import GHC.Types.SourceFile (HscSource(..)) +import GHC.Types.SrcLoc +import GHC.Types.Basic + import GHC.Utils.Outputable import GHC.Utils.Panic -import GHC.Utils.Panic.Plain -import GHC.Types.SrcLoc -import GHC.Core.TyCon + import GHC.Data.Maybe -import GHC.Types.Basic -import GHC.Data.Bag import GHC.Data.BooleanFormula import Control.Monad @@ -138,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 @@ -154,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] @@ -192,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 @@ -219,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) @@ -234,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)) @@ -278,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 @@ -292,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] $ @@ -313,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 @@ -342,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 @@ -386,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 @@ -400,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] @@ -462,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 @@ -597,6 +594,8 @@ -- hs-boot and signatures never need to provide complete "definitions" -- of any sort, as they aren't really defining anything, but just -- constraining items which are defined elsewhere. - ; let dia = TcRnNoExplicitAssocTypeOrDefaultDeclaration name - ; diagnosticTc (warn && hsc_src == HsSrcFile) dia + ; let diag = TcRnIllegalInstance $ IllegalFamilyInstance + $ InvalidAssoc $ InvalidAssocInstance + $ AssocInstanceMissing name + ; diagnosticTc (warn && hsc_src == HsSrcFile) diag } 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 @@ -6,7 +6,9 @@ {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE LambdaCase #-} {-# OPTIONS_GHC -Wno-incomplete-record-updates #-} @@ -21,6 +23,7 @@ import GHC.Prelude import GHC.Hs +import GHC.Rename.Bind ( rejectBootDecls ) import GHC.Tc.Errors.Types import GHC.Tc.Gen.Bind import GHC.Tc.TyCl @@ -32,7 +35,8 @@ import GHC.Tc.Gen.Sig import GHC.Tc.Utils.Monad import GHC.Tc.Validity -import GHC.Tc.Utils.Zonk +import GHC.Tc.Zonk.Type +import GHC.Tc.Zonk.TcType import GHC.Tc.Utils.TcMType import GHC.Tc.Utils.TcType import GHC.Tc.Types.Constraint @@ -40,46 +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.Core ( Expr(..), mkApps, mkVarApps, mkLams ) +import GHC.Tc.Types.Evidence + +import GHC.Builtin.Names ( unsatisfiableIdName ) + +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.Session -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 @@ -179,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* @@ -213,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 @@ -347,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] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -414,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 @@ -481,16 +499,18 @@ 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 })) - = setSrcSpanA loc $ + = setSrcSpanA loc $ addErrCtxt (instDeclCtxt1 hs_ty) $ 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 ] @@ -501,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) @@ -536,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 @@ -552,11 +573,13 @@ all_insts = tyfam_insts ++ datafam_insts -- In hs-boot files there should be no bindings - ; let no_binds = isEmptyLHsBinds binds && null uprags - ; is_boot <- tcIsHsBootOrSig - ; failIfTc (is_boot && not no_binds) TcRnIllegalHsBootFileDecl - - ; return ( [inst_info], all_insts, deriv_infos ) } + ; gbl_env <- getGblEnv; + ; case tcg_src gbl_env of + { HsSrcFile -> return () + ; HsBootOrSig boot_or_sig -> + do { rejectBootDecls boot_or_sig BootBindsRn binds + ; rejectBootDecls boot_or_sig BootInstanceSigs uprags } } + ; return ([inst_info], all_insts, deriv_infos) } where defined_ats = mkNameSet (map (tyFamInstDeclName . unLoc) ats) `unionNameSet` @@ -579,27 +602,33 @@ 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 fam_tc + ; tcFamInstDeclChecks mb_clsinfo IAmType fam_tc -- (0) Check it's an open type family - ; checkTc (isTypeFamilyTyCon fam_tc) (wrongKindOfFamily fam_tc) - ; checkTc (isOpenTypeFamilyTyCon fam_tc) (TcRnNotOpenFamily fam_tc) + ; checkTc (isTypeFamilyTyCon fam_tc) $ + TcRnIllegalInstance $ IllegalFamilyInstance $ + FamilyCategoryMismatch fam_tc + ; checkTc (isOpenTypeFamilyTyCon fam_tc) $ + TcRnIllegalInstance $ IllegalFamilyInstance $ + NotAnOpenFamilyTyCon fam_tc -- (1) do the work of verifying the synonym group -- For some reason we don't have a location for the equation -- itself, so we make do with the location of family name - ; co_ax_branch <- tcTyFamInstEqn fam_tc mb_clsinfo - (L (na2la $ getLoc fam_lname) eqn) + ; (co_ax_branch, co_ax_validity_info) + <- tcTyFamInstEqn fam_tc mb_clsinfo + (L (l2l $ getLoc fam_lname) eqn) -- (2) check for validity ; checkConsistentFamInst mb_clsinfo fam_tc co_ax_branch + ; checkTyFamEqnValidityInfo fam_tc co_ax_validity_info ; checkValidCoAxBranch fam_tc co_ax_branch -- (3) construct coercion axiom @@ -609,24 +638,32 @@ --------------------- -tcFamInstDeclChecks :: AssocInstInfo -> TyCon -> TcM () +tcFamInstDeclChecks :: AssocInstInfo -> TypeOrData -> TyCon -> TcM () -- Used for both type and data families -tcFamInstDeclChecks mb_clsinfo fam_tc +tcFamInstDeclChecks mb_clsinfo ty_or_data fam_tc = do { -- Type family instances require -XTypeFamilies -- and can't (currently) be in an hs-boot file ; traceTc "tcFamInstDecl" (ppr fam_tc) ; type_families <- xoptM LangExt.TypeFamilies - ; is_boot <- tcIsHsBootOrSig -- Are we compiling an hs-boot file? - ; checkTc type_families (TcRnBadFamInstDecl fam_tc) - ; checkTc (not is_boot) TcRnBadBootFamInstDecl + ; hs_src <- tcHscSource -- Are we compiling an hs-boot file? + ; checkTc type_families (TcRnTyFamsDisabled (TyFamsDisabledInstance fam_tc)) + ; case hs_src of + HsBootOrSig boot_or_sig -> + addErrTc $ TcRnIllegalHsBootOrSigDecl boot_or_sig (BootFamInst fam_tc) + HsSrcFile -> + return () - -- Check that it is a family TyCon, and that - -- oplevel type instances are not for associated types. - ; checkTc (isFamilyTyCon fam_tc) (TcRnIllegalFamilyInstance fam_tc) + -- Check that it is a family TyCon + ; checkTc (isFamilyTyCon fam_tc) $ + TcRnIllegalInstance $ IllegalFamilyInstance $ + NotAFamilyTyCon ty_or_data fam_tc + -- Check that top-level type instances are not for associated types. ; when (isNotAssociated mb_clsinfo && -- Not in a class decl - isTyConAssoc fam_tc) -- but an associated type - (addErr $ TcRnMissingClassAssoc fam_tc) + isTyConAssoc fam_tc) $ -- but an associated type + addErr $ TcRnIllegalInstance $ IllegalFamilyInstance + $ InvalidAssoc $ InvalidAssocInstance + $ AssocInstanceNotInAClass fam_tc } {- Note [Associated type instances] @@ -677,22 +714,23 @@ , 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 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) (wrongKindOfFamily fam_tc) + ; checkTc (isDataFamilyTyCon fam_tc) $ + TcRnIllegalInstance $ IllegalFamilyInstance $ + FamilyCategoryMismatch fam_tc ; gadt_syntax <- dataDeclChecks fam_name hs_ctxt hs_cons -- 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, pats, tc_res_kind, stupid_theta) + ; (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] @@ -717,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) @@ -739,17 +776,21 @@ , text "eta_tcbs" <+> ppr eta_tcbs ] -- Zonk the patterns etc into the Type world - ; ze <- mkEmptyZonkEnv NoFlexi - ; (ze, ty_binders) <- zonkTyVarBindersX ze tc_ty_binders - ; res_kind <- zonkTcTypeToTypeX ze tc_res_kind - ; all_pats <- zonkTcTypesToTypesX ze all_pats - ; eta_pats <- zonkTcTypesToTypesX ze eta_pats - ; stupid_theta <- zonkTcTypesToTypesX ze stupid_theta - ; let zonked_post_eta_qtvs = map (lookupTyVarX ze) post_eta_qtvs - zonked_eta_tvs = map (lookupTyVarX ze) eta_tvs - -- All these qtvs are in ty_binders, and hence will be in - -- the ZonkEnv, ze. We need the zonked (TyVar) versions to - -- put in the CoAxiom that we are about to build. + ; (ty_binders, res_kind, all_pats, eta_pats, stupid_theta, + zonked_post_eta_qtvs, zonked_eta_tvs) <- + initZonkEnv NoFlexi $ + runZonkBndrT (zonkTyVarBindersX tc_ty_binders) $ \ ty_binders -> + do { res_kind <- zonkTcTypeToTypeX tc_res_kind + ; all_pats <- zonkTcTypesToTypesX all_pats + ; eta_pats <- zonkTcTypesToTypesX eta_pats + ; stupid_theta <- zonkTcTypesToTypesX stupid_theta + ; zonked_post_eta_qtvs <- mapM lookupTyVarX post_eta_qtvs + ; zonked_eta_tvs <- mapM lookupTyVarX eta_tvs + -- All these qtvs are in ty_binders, and hence will be in + -- the ZonkEnv, ze. We need the zonked (TyVar) versions to + -- put in the CoAxiom that we are about to build. + ; return (ty_binders, res_kind, all_pats, eta_pats, stupid_theta, + zonked_post_eta_qtvs, zonked_eta_tvs) } ; traceTc "tcDataFamInstDecl" $ vcat [ text "Fam tycon:" <+> ppr fam_tc @@ -761,7 +802,7 @@ , text "res_kind:" <+> ppr res_kind , text "eta_pats" <+> ppr eta_pats , text "eta_tcbs" <+> ppr eta_tcbs ] - ; (rep_tc, axiom) <- fixM $ \ ~(rec_rep_tc, _) -> + ; (rep_tc, (axiom, ax_rhs)) <- fixM $ \ ~(rec_rep_tc, _) -> do { data_cons <- tcExtendTyVarEnv (binderVars tc_ty_binders) $ -- For H98 decls, the tyvars scope -- over the data constructors @@ -797,13 +838,15 @@ -- further instance might not introduce a new recursive -- dependency. (2) They are always valid loop breakers as -- they involve a coercion. - ; return (rep_tc, axiom) } + ; return (rep_tc, (axiom, ax_rhs)) } + -- Remember to check validity; no recursion to worry about here -- Check that left-hand sides are ok (mono-types, no type families, -- consistent instantiations, etc) ; let ax_branch = coAxiomSingleBranch axiom ; checkConsistentFamInst mb_clsinfo fam_tc ax_branch + ; checkFamPatBinders fam_tc zonked_post_eta_qtvs non_user_tvs eta_pats ax_rhs ; checkValidCoAxBranch fam_tc ax_branch ; checkValidTyCon rep_tc @@ -811,14 +854,18 @@ m_deriv_info = case derivs of [] -> Nothing preds -> - Just $ DerivInfo { di_rep_tc = rep_tc + Just $ DerivInfo { di_rep_tc = rep_tc , di_scoped_tvs = scoped_tvs - , di_clauses = preds - , di_ctxt = tcMkDataFamInstCtxt decl } + , di_clauses = preds + , 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] @@ -886,16 +933,15 @@ tcDataFamInstHeader :: AssocInstInfo -> SkolemInfo -> TyCon -> HsOuterFamEqnTyVarBndrs GhcRn -> LexicalFixity -> Maybe (LHsContext GhcRn) - -> HsTyPats GhcRn -> Maybe (LHsKind GhcRn) - -> NewOrData - -> TcM ([TcTyVar], [TcType], TcKind, TcThetaType) + -> 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 -- the data constructors themselves -- 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" $ @@ -911,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" $ @@ -948,11 +995,15 @@ -- the outer_tvs. See Note [Generalising in tcTyFamInstEqnGuts] ; reportUnsolvedEqualities skol_info final_tvs tclvl wanted - ; final_tvs <- zonkTcTyVarsToTcTyVars final_tvs - ; lhs_ty <- zonkTcType lhs_ty - ; master_res_kind <- zonkTcType master_res_kind - ; instance_res_kind <- zonkTcType instance_res_kind - ; stupid_theta <- zonkTcTypes stupid_theta + ; (final_tvs, non_user_tvs, lhs_ty, master_res_kind, instance_res_kind, stupid_theta) <- + liftZonkM $ do + { final_tvs <- mapM zonkTcTyVarToTcTyVar final_tvs + ; non_user_tvs <- mapM zonkTcTyVarToTcTyVar qtvs + ; lhs_ty <- zonkTcType lhs_ty + ; master_res_kind <- zonkTcType master_res_kind + ; instance_res_kind <- zonkTcType instance_res_kind + ; stupid_theta <- zonkTcTypes stupid_theta + ; return (final_tvs, non_user_tvs, lhs_ty, master_res_kind, instance_res_kind, stupid_theta) } -- Check that res_kind is OK with checkDataKindSig. We need to -- check that it's ok because res_kind can come from a user-written @@ -964,13 +1015,20 @@ -- For the scopedSort see Note [Generalising in tcTyFamInstEqnGuts] ; let pats = unravelFamInstPats lhs_ty - ; return (final_tvs, pats, master_res_kind, stupid_theta) } + ; return (final_tvs, mkVarSet non_user_tvs, pats, master_res_kind, stupid_theta) } 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 @@ -996,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 @@ -1150,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. -} @@ -1198,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 @@ -1209,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] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1261,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 @@ -1297,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 @@ -1321,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 @@ -1343,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] @@ -1363,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] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1452,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) @@ -1463,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 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 @@ -1476,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) } @@ -1644,7 +1719,7 @@ it is the superclass of an unblocked dictionary (wrinkle (W1)), that is Paterson-smaller than the instance head. - This is implemented in GHC.Tc.Solver.Canonical.mk_strict_superclasses + This is implemented in GHC.Tc.Solver.Dict.mk_strict_superclasses (in the mk_given_loc helper function). * Superclass "Wanted" constraints have CtOrigin of (ScOrigin NakedSc) @@ -1655,26 +1730,12 @@ origin. But if we apply an instance declaration, we can set the origin to (ScOrigin NotNakedSc), thus lifting any restrictions by making prohibitedSuperClassSolve return False. This happens - in GHC.Tc.Solver.Interact.checkInstanceOK. + in GHC.Tc.Solver.Dict.checkInstanceOK. * (sc2) ScOrigin wanted constraints can't be solved from a 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.Interact.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.Interact. - Note [Silent superclass arguments] (historical interest only) ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ NB1: this note describes our *old* solution to the @@ -1756,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 @@ -1771,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 @@ -1785,11 +1846,14 @@ hs_sig_fn = mkHsSigFun sigs inst_loc = getSrcSpan dfun_id + unsat_thetas = + mapMaybe (\ id -> (id,) <$> isUnsatisfiableCt_maybe (idType id)) dfun_ev_vars + ---------------------- 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 @@ -1801,41 +1865,73 @@ tc_default :: Id -> DefMethInfo -> TcM (TcId, LHsBind GhcTc, Maybe Implication) - tc_default sel_id (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 + tc_default sel_id mb_dm = case mb_dm of + + -- If the instance has an "Unsatisfiable msg" context, + -- add method bindings that use "unsatisfiable". + -- + -- See Note [Implementation of Unsatisfiable constraints], + -- in GHC.Tc.Errors, point (D). + _ | (theta_id,unsat_msg) : _ <- unsat_thetas + -> do { (meth_id, _) <- mkMethIds clas tyvars dfun_ev_vars + inst_tys sel_id + ; unsat_id <- tcLookupId unsatisfiableIdName + -- Recall that unsatisfiable :: forall {rep} (msg :: ErrorMessage) (a :: TYPE rep). Unsatisfiable msg => a + -- + -- So we need to instantiate the forall and pass the dictionary evidence. + ; let meth_rhs = L inst_loc' $ + wrapId + ( mkWpEvApps [EvExpr $ Var theta_id] + <.> mkWpTyApps [getRuntimeRep meth_tau, unsat_msg, meth_tau]) + unsat_id + meth_bind = mkVarBind meth_id $ mkLHsWrap lam_wrapper meth_rhs + ; return (meth_id, meth_bind, Nothing) } + + 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 } - tc_default sel_id Nothing -- No default method at all - = do { traceTc "tc_def: warn" (ppr sel_id) + -- No default method + Nothing -> + do { traceTc "tc_def: warn" (ppr sel_id) ; (meth_id, _) <- mkMethIds clas tyvars dfun_ev_vars inst_tys sel_id ; dflags <- getDynFlags - ; let meth_bind = mkVarBind meth_id $ - mkLHsWrap lam_wrapper (error_rhs dflags) + -- Add a binding whose RHS is an error + -- "No explicit nor default method for class operation 'meth'". + ; let meth_rhs = error_rhs dflags + meth_bind = mkVarBind meth_id $ mkLHsWrap lam_wrapper meth_rhs ; return (meth_id, meth_bind, Nothing) } + 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 - (hcat [ppr inst_loc, vbar, ppr sel_id ]) + (hcat [ppr inst_loc, vbar, quotes (ppr sel_id) ]) lam_wrapper = mkWpTyLams tyvars <.> mkWpEvLams dfun_ev_vars ---------------------- -- Check if one of the minimal complete definitions is satisfied checkMinimalDefinition - = whenIsJust (isUnsatisfied methodExists (classMinimalDef clas)) $ + = when (null unsat_thetas) $ + -- Don't warn if there is an "Unsatisfiable" constraint in the context. + -- + -- See Note [Implementation of Unsatisfiable constraints] in GHC.Tc.Errors, + -- point (D). + whenIsJust (isUnsatisfied (methodExists . unLoc) (classMinimalDef clas)) $ warnUnsatisfiedMinimalDefinition methodExists meth = isJust (findMethodBind meth binds prag_fn) @@ -1850,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] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1907,39 +2009,40 @@ instances in order to determine which cases were unreachable. This seems like a lot of work for minimal gain, so we have opted not to go for this approach. -Instead, we take the much simpler approach of always disabling --Winaccessible-code for derived code. To accomplish this, we do the following: +Instead, we take the following approach: -1. In tcMethods (which typechecks method bindings), disable - -Winaccessible-code. +1. In tcMethods (which typechecks method bindings), use 'setInGeneratedCode'. 2. When creating Implications during typechecking, record this flag (in ic_warn_inaccessible) at the time of creation. 3. After typechecking comes error reporting, where GHC must decide how to report inaccessible code to the user, on an Implication-by-Implication - basis. If an Implication's DynFlags indicate that -Winaccessible-code was - disabled, then don't bother reporting it. That's it! + basis. If the ic_warn_inaccessible field of the Implication is False, then + we don't bother reporting it. That's it! -} ------------------------ -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 @@ -1950,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 @@ -1969,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 @@ -2003,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 = [] @@ -2063,15 +2177,11 @@ poly_meth_ty = mkSpecSigmaTy tyvars theta local_meth_ty theta = map idType dfun_ev_vars -methSigCtxt :: Name -> TcType -> TcType -> TidyEnv -> TcM (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] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -2127,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 @@ -2143,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 @@ -2161,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 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 @@ -2226,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 @@ -2240,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 @@ -2372,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) } @@ -2380,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" @@ -2397,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 @@ -23,9 +23,10 @@ import GHC.Tc.Gen.Pat import GHC.Tc.Utils.Env import GHC.Tc.Utils.TcMType -import GHC.Tc.Utils.Zonk +import GHC.Tc.Zonk.Type import GHC.Tc.Errors.Types import GHC.Tc.Utils.Monad +import GHC.Tc.Zonk.TcType import GHC.Tc.Gen.Sig ( TcPragEnv, emptyPragEnv, completeSigFromId, lookupPragEnv , addInlinePrags, addInlinePragArity ) import GHC.Tc.Solver @@ -36,13 +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.Error import GHC.Types.Name +import GHC.Types.Name.Reader import GHC.Types.Name.Set import GHC.Types.SrcLoc import GHC.Core.PatSyn @@ -62,12 +63,15 @@ import GHC.Types.FieldLabel import GHC.Rename.Env import GHC.Rename.Utils (wrapGenSpan) -import GHC.Data.Bag import GHC.Utils.Misc -import GHC.Driver.Session ( getDynFlags, xopt_FieldSelectors ) +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 ) +import Data.List.NonEmpty (NonEmpty, nonEmpty) {- ************************************************************************ @@ -83,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] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -133,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 @@ -171,11 +154,11 @@ ; ((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 $ - do { prov_dicts <- mapM zonkId prov_dicts + do { prov_dicts <- liftZonkM $ mapM zonkId prov_dicts ; let filtered_prov_dicts = mkMinimalBySCs evVarPred prov_dicts -- Filtering: see Note [Remove redundant provided dicts] (prov_theta, prov_evs) @@ -184,25 +167,24 @@ -- Report coercions that escape -- See Note [Coercions that escape] - ; args <- mapM zonkId args - ; let bad_args = [ (arg, bad_cos) | arg <- args ++ prov_dicts - , let bad_cos = filterDVarSet isId $ - (tyCoVarsOfTypeDSet (idType arg)) - , not (isEmptyDVarSet bad_cos) ] + ; args <- liftZonkM $ mapM zonkId args + ; let bad_arg arg = fmap (\bad_cos -> (arg, bad_cos)) $ + nonEmpty $ + dVarSetElems $ + filterDVarSet isId (tyCoVarsOfTypeDSet (idType arg)) + bad_args = mapMaybe bad_arg (args ++ prov_dicts) ; mapM_ dependentArgErr bad_args -- Report un-quantifiable type variables: -- see Note [Unquantified tyvars in a pattern synonym] ; dvs <- candidateQTyVarsOfTypes prov_theta - ; let mk_doc tidy_env + ; let err_ctx tidy_env = do { (tidy_env2, theta) <- zonkTidyTcTypes tidy_env prov_theta - ; return ( tidy_env2 - , sep [ text "the provided context:" - , pprTheta theta ] ) } - ; doNotQuantifyTyVars dvs mk_doc + ; return ( tidy_env2, UninfTyCtx_ProvidedContext theta ) } + ; 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)) @@ -238,22 +220,11 @@ pred = evVarPred ev_id eq_con_args = [evId ev_id] -dependentArgErr :: (Id, DTyCoVarSet) -> TcM () +dependentArgErr :: (Id, NonEmpty CoVar) -> TcM () -- See Note [Coercions that escape] dependentArgErr (arg, bad_cos) = failWithTc $ -- fail here: otherwise we get downstream errors - mkTcRnUnknownMessage $ mkPlainError noHints $ - 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 = dVarSetElems bad_cos + TcRnPatSynEscapedCoercion arg bad_cos {- Note [Type variables whose kind is captured] ~~-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -323,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 @@ -382,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 @@ -407,11 +378,7 @@ -- The existential 'x' should not appear in the result type -- Can't check this until we know P's arity (decl_arity above) ; let bad_tvs = filter (`elemVarSet` tyCoVarsOfType pat_ty) $ binderVars explicit_ex_bndrs - ; checkTc (null bad_tvs) $ mkTcRnUnknownMessage $ mkPlainError noHints $ - 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) + ; checkTc (null bad_tvs) $ TcRnPatSynExistentialInResult name pat_ty bad_tvs -- See Note [The pattern-synonym signature splitting rule] in GHC.Tc.Gen.Sig ; let univ_fvs = closeOverKinds $ @@ -487,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) @@ -598,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. @@ -675,16 +642,13 @@ -> ([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) wrongNumberOfParmsErr :: Name -> Arity -> Arity -> TcM a wrongNumberOfParmsErr name decl_arity missing - = failWithTc $ mkTcRnUnknownMessage $ mkPlainError noHints $ - 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") + = failWithTc $ TcRnPatSynArityMismatch name decl_arity missing ------------------------- -- Shared by both tcInferPatSyn and tcCheckPatSyn @@ -711,21 +675,25 @@ = do { -- Zonk everything. We are about to build a final PatSyn -- so there had better be no unification variables in there - ; ze <- mkEmptyZonkEnv NoFlexi - ; (ze, univ_tvs') <- zonkTyVarBindersX ze univ_tvs - ; req_theta' <- zonkTcTypesToTypesX ze req_theta - ; (ze, ex_tvs') <- zonkTyVarBindersX ze ex_tvs - ; prov_theta' <- zonkTcTypesToTypesX ze prov_theta - ; pat_ty' <- zonkTcTypeToTypeX ze pat_ty - ; arg_tys' <- zonkTcTypesToTypesX ze arg_tys + (univ_tvs, req_theta, ex_tvs, prov_theta, arg_tys, pat_ty) <- + initZonkEnv NoFlexi $ + runZonkBndrT (zonkTyVarBindersX univ_tvs) $ \ univ_tvs' -> + do { req_theta' <- zonkTcTypesToTypesX req_theta + ; runZonkBndrT (zonkTyVarBindersX ex_tvs) $ \ ex_tvs' -> + do { prov_theta' <- zonkTcTypesToTypesX prov_theta + ; pat_ty' <- zonkTcTypeToTypeX pat_ty + ; arg_tys' <- zonkTcTypesToTypesX arg_tys - ; let (env1, univ_tvs) = tidyForAllTyBinders emptyTidyEnv univ_tvs' - (env2, ex_tvs) = tidyForAllTyBinders env1 ex_tvs' - req_theta = tidyTypes env2 req_theta' - prov_theta = tidyTypes env2 prov_theta' - arg_tys = tidyTypes env2 arg_tys' - pat_ty = tidyType env2 pat_ty' + ; let (env1, univ_tvs) = tidyForAllTyBinders emptyTidyEnv univ_tvs' + (env2, ex_tvs) = tidyForAllTyBinders env1 ex_tvs' + req_theta = tidyTypes env2 req_theta' + prov_theta = tidyTypes env2 prov_theta' + arg_tys = tidyTypes env2 arg_tys' + pat_ty = tidyType env2 pat_ty' + ; return (univ_tvs, req_theta, + ex_tvs, prov_theta, arg_tys, pat_ty) } } + ; traceTc "tc_patsyn_finish {" $ ppr (unLoc lname) $$ ppr (unLoc lpat') $$ ppr (univ_tvs, req_theta, req_ev_binds, req_dicts) $$ @@ -808,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 @@ -820,31 +789,33 @@ fail' = nlHsApps fail [nlHsDataCon unboxedUnitDataCon] - args = map nlVarPat [scrutinee, cont, fail] + args = noLocA $ map nlVarPat [scrutinee, cont, fail] lwpat = noLocA $ WildPat pat_ty - cases = if isIrrefutableHsPat dflags lpat + cases = if isIrrefutableHsPat is_strict (irrefutableConLikeTc comps) lpat then [mkHsCaseAlt lpat cont'] else [mkHsCaseAlt lpat cont', mkHsCaseAlt lwpat fail'] + gen = Generated OtherExpansion SkipPmc body = mkLHsWrap (mkWpLet req_ev_binds) $ L (getLoc lpat) $ - HsCase noExtField (nlHsVar scrutinee) $ + HsCase PatSyn (nlHsVar scrutinee) $ MG{ mg_alts = L (l2l $ getLoc lpat) cases - , mg_ext = MatchGroupTc [unrestricted pat_ty] res_ty Generated + , mg_ext = MatchGroupTc [unrestricted pat_ty] res_ty gen } body' = noLocA $ - HsLam noExtField $ - MG{ mg_alts = noLocA [mkSimpleMatch LambdaExpr - args body] - , mg_ext = MatchGroupTc (map unrestricted [pat_ty, cont_ty, fail_ty]) res_ty Generated + 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) mg :: MatchGroup GhcTc (LHsExpr GhcTc) mg = MG{ mg_alts = L (l2l $ getLoc match) [match] - , mg_ext = MatchGroupTc [] res_ty Generated + , mg_ext = MatchGroupTc [] res_ty gen } matcher_arity = length req_theta + 3 -- See Note [Pragmas for pattern synonyms] @@ -859,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) @@ -920,19 +891,15 @@ , 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 $ mkTcRnUnknownMessage $ mkPlainError noHints $ - vcat [ hang (text "Invalid right-hand side of bidirectional pattern synonym" - <+> quotes (ppr ps_name) <> colon) - 2 why - , text "RHS pattern:" <+> ppr lpat ] + = setSrcSpan (getLocA lpat) $ failWithTc $ TcRnPatSynInvalidRhs ps_name lpat args why | 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 @@ -970,35 +937,32 @@ ; 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 ExplicitBidirectional explicit_mg -> Right explicit_mg - ImplicitBidirectional -> fmap mk_mg (tcPatToExpr ps_name args lpat) + ImplicitBidirectional -> fmap mk_mg (tcPatToExpr args lpat) Unidirectional -> panic "tcPatSynBuilderBind" mk_mg :: LHsExpr GhcRn -> MatchGroup GhcRn (LHsExpr GhcRn) - mk_mg body = mkMatchGroup Generated (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 @@ -1021,8 +985,8 @@ | need_dummy_arg = mkVisFunTyMany unboxedUnitTy ty | otherwise = ty -tcPatToExpr :: Name -> [LocatedN Name] -> LPat GhcRn - -> Either SDoc (LHsExpr GhcRn) +tcPatToExpr :: [LocatedN Name] -> LPat GhcRn + -> Either PatSynInvalidRhsReason (LHsExpr GhcRn) -- Given a /pattern/, return an /expression/ that builds a value -- that matches the pattern. E.g. if the pattern is (Just [x]), -- the expression is (Just [x]). They look the same, but the @@ -1031,35 +995,37 @@ -- -- Returns (Left r) if the pattern is not invertible, for reason r. -- See Note [Builder for a bidirectional pattern synonym] -tcPatToExpr name args pat = go pat +tcPatToExpr args pat = go pat where lhsVars = mkNameSet (map unLoc args) -- Make a prefix con for prefix and infix patterns for simplicity - mkPrefixConExpr :: LocatedN Name -> [LPat GhcRn] - -> Either SDoc (HsExpr GhcRn) + mkPrefixConExpr :: LocatedN (WithUserRdr Name) + -> [LPat GhcRn] + -> Either PatSynInvalidRhsReason (HsExpr GhcRn) mkPrefixConExpr lcon@(L loc _) pats = do { exprs <- mapM go pats ; let con = L (l2l loc) (HsVar noExtField lcon) ; return (unLoc $ mkHsApps con exprs) } - mkRecordConExpr :: LocatedN Name -> HsRecFields GhcRn (LPat GhcRn) - -> Either SDoc (HsExpr GhcRn) - mkRecordConExpr con (HsRecFields fields dd) + mkRecordConExpr :: LocatedN (WithUserRdr Name) + -> HsRecFields GhcRn (LPat GhcRn) + -> Either PatSynInvalidRhsReason (HsExpr GhcRn) + 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 SDoc (LHsRecField GhcRn (LHsExpr GhcRn)) + go' :: LHsRecField GhcRn (LPat GhcRn) -> Either PatSynInvalidRhsReason (LHsRecField GhcRn (LHsExpr GhcRn)) go' (L l rf) = L l <$> traverse go rf - go :: LPat GhcRn -> Either SDoc (LHsExpr GhcRn) + go :: LPat GhcRn -> Either PatSynInvalidRhsReason (LHsExpr GhcRn) go (L loc p) = L loc <$> go1 p - go1 :: Pat GhcRn -> Either SDoc (HsExpr GhcRn) + 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 @@ -1068,28 +1034,33 @@ go1 (VarPat _ (L l var)) | var `elemNameSet` lhsVars - = return $ HsVar noExtField (L l var) + = return $ mkHsVar (L l var) | otherwise - = Left (quotes (ppr var) <+> text "is not bound by the LHS of the pattern synonym") - go1 (ParPat _ lpar pat rpar) = fmap (\e -> HsPar noAnn lpar e rpar) $ go pat + = Left (PatSynUnboundVar var) + 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] @@ -1097,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. @@ -1106,20 +1077,9 @@ go1 p@(WildPat {}) = notInvertible p go1 p@(AsPat {}) = notInvertible p go1 p@(NPlusKPat {}) = notInvertible p - - notInvertible p = Left (not_invertible_msg p) - - not_invertible_msg p - = text "Pattern" <+> quotes (ppr p) <+> text "is not invertible" - $+$ hang (text "Suggestion: instead use an explicitly bidirectional" - <+> text "pattern synonym, e.g.") - 2 (hang (text "pattern" <+> pp_name <+> pp_args <+> larrow - <+> ppr pat <+> text "where") - 2 (pp_name <+> pp_args <+> equals <+> text "...")) - where - pp_name = ppr name - pp_args = hsep (map ppr args) + go1 p@(OrPat {}) = notInvertible p + notInvertible p = Left (PatSynNotInvertible p) {- Note [Builder for a bidirectional pattern synonym] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1271,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 @@ -1290,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,9 +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 @@ -40,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 ) @@ -54,27 +51,24 @@ 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 (wrapGenSpan) +import GHC.Rename.Utils (genHsVar, genLHsApp, genLHsLit, genWildPat, wrapGenSpan) import GHC.Types.Basic -import GHC.Types.Error import GHC.Types.FieldLabel import GHC.Types.SrcLoc import GHC.Types.SourceFile import GHC.Types.SourceText import GHC.Types.Name import GHC.Types.Name.Env -import GHC.Types.Name.Reader ( mkVarUnqual ) +import GHC.Types.Name.Reader ( mkRdrUnqual ) import GHC.Types.Id import GHC.Types.Id.Info import GHC.Types.Var.Env @@ -136,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 @@ -170,7 +160,7 @@ -- track of the TyCons which are known to be acyclic, or -- a failure message reporting that a cycle was found. newtype SynCycleM a = SynCycleM { - runSynCycleM :: SynCycleState -> Either (SrcSpan, SDoc) (a, SynCycleState) } + runSynCycleM :: SynCycleState -> Either (SrcSpan, TySynCycleTyCons) (a, SynCycleState) } deriving (Functor) -- TODO: TyConSet is implemented as IntMap over uniques. @@ -190,8 +180,8 @@ runSynCycleM (f x) state' Left err -> Left err -failSynCycleM :: SrcSpan -> SDoc -> SynCycleM () -failSynCycleM loc err = SynCycleM $ \_ -> Left (loc, err) +failSynCycleM :: SrcSpan -> TySynCycleTyCons -> SynCycleM () +failSynCycleM loc seen_tcs = SynCycleM $ \_ -> Left (loc, seen_tcs) -- | Test if a 'Name' is acyclic, short-circuiting if we've -- seen it already. @@ -211,7 +201,7 @@ checkSynCycles :: Unit -> [TyCon] -> [LTyClDecl GhcRn] -> TcM () checkSynCycles this_uid tcs tyclds = case runSynCycleM (mapM_ (go emptyTyConSet []) tcs) emptyTyConSet of - Left (loc, err) -> setSrcSpan loc $ failWithTc (mkTcRnUnknownMessage $ mkPlainError noHints err) + Left (loc, err) -> setSrcSpan loc $ failWithTc (TcRnTypeSynonymCycle err) Right _ -> return () where -- Try our best to print the LTyClDecl for locally defined things @@ -228,9 +218,7 @@ go' :: TyConSet -> [TyCon] -> TyCon -> SynCycleM () go' so_far seen_tcs tc | tc `elemTyConSet` so_far - = failSynCycleM (getSrcSpan (head seen_tcs)) $ - sep [ text "Cycle in type synonym declarations:" - , nest 2 (vcat (map ppr_decl seen_tcs)) ] + = failSynCycleM (getSrcSpan (head seen_tcs)) (lookup_decl <$> seen_tcs) -- Optimization: we don't allow cycles through external packages, -- so once we find a non-local name we are guaranteed to not -- have a cycle. @@ -247,13 +235,10 @@ where n = tyConName tc mod = nameModule n - ppr_decl tc = - case lookupNameEnv lcl_decls n of - Just (L loc decl) -> ppr (locA loc) <> colon <+> ppr decl - Nothing -> ppr (getSrcSpan n) <> colon <+> ppr n - <+> text "from external module" - where - n = tyConName tc + lookup_decl tc = + case lookupNameEnv lcl_decls (tyConName tc) of + Just decl -> Right decl + Nothing -> Left tc go_ty :: TyConSet -> [TyCon] -> Type -> SynCycleM () go_ty so_far seen_tcs ty = @@ -307,19 +292,14 @@ type ClassSet = UniqSet Class -checkClassCycles :: Class -> Maybe SDoc +checkClassCycles :: Class -> Maybe SuperclassCycle -- Nothing <=> ok -- Just err <=> possible cycle error checkClassCycles cls - = do { (definite_cycle, err) <- go (unitUniqSet cls) + = do { (definite_cycle, details) <- go (unitUniqSet cls) cls (mkTyVarTys (classTyVars cls)) - ; let herald | definite_cycle = text "Superclass cycle for" - | otherwise = text "Potential superclass cycle for" - ; return (vcat [ herald <+> quotes (ppr cls) - , nest 2 err, hint]) } + ; return (MkSuperclassCycle cls definite_cycle details) } where - hint = text "Use UndecidableSuperClasses to accept this" - -- Expand superclasses starting with (C a b), complaining -- if you find the same class a second time, or a type function -- or predicate headed by a type variable @@ -327,12 +307,12 @@ -- NB: this code duplicates TcType.transSuperClasses, but -- with more error message generation clobber -- Make sure the two stay in sync. - go :: ClassSet -> Class -> [Type] -> Maybe (Bool, SDoc) + go :: ClassSet -> Class -> [Type] -> Maybe (Bool, [SuperclassCycleDetail]) go so_far cls tys = firstJusts $ map (go_pred so_far) $ immSuperClasses cls tys - go_pred :: ClassSet -> PredType -> Maybe (Bool, SDoc) + go_pred :: ClassSet -> PredType -> Maybe (Bool, [SuperclassCycleDetail]) -- Nothing <=> ok -- Just (True, err) <=> definite cycle -- Just (False, err) <=> possible cycle @@ -340,31 +320,28 @@ | Just (tc, tys) <- tcSplitTyConApp_maybe pred = go_tc so_far pred tc tys | hasTyVarHead pred - = Just (False, hang (text "one of whose superclass constraints is headed by a type variable:") - 2 (quotes (ppr pred))) + = Just (False, [SCD_HeadTyVar pred]) | otherwise = Nothing - go_tc :: ClassSet -> PredType -> TyCon -> [Type] -> Maybe (Bool, SDoc) + go_tc :: ClassSet -> PredType -> TyCon -> [Type] -> Maybe (Bool, [SuperclassCycleDetail]) go_tc so_far pred tc tys | isFamilyTyCon tc - = Just (False, hang (text "one of whose superclass constraints is headed by a type family:") - 2 (quotes (ppr pred))) + = Just (False, [SCD_HeadTyFam pred]) | Just cls <- tyConClass_maybe tc = go_cls so_far cls tys | otherwise -- Equality predicate, for example = Nothing - go_cls :: ClassSet -> Class -> [Type] -> Maybe (Bool, SDoc) + go_cls :: ClassSet -> Class -> [Type] -> Maybe (Bool, [SuperclassCycleDetail]) go_cls so_far cls tys | cls `elementOfUniqSet` so_far - = Just (True, text "one of whose superclasses is" <+> quotes (ppr cls)) + = Just (True, [SCD_Superclass cls]) | isCTupleClass cls = go so_far cls tys | otherwise - = do { (b,err) <- go (so_far `addOneToUniqSet` cls) cls tys - ; return (b, text "one of whose superclasses is" <+> quotes (ppr cls) - $$ err) } + = do { (b, details) <- go (so_far `addOneToUniqSet` cls) cls tys + ; return (b, SCD_Superclass cls : details) } {- ************************************************************************ @@ -757,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)) {- ********************************************************************* @@ -823,14 +801,6 @@ -- (#13998) {- -************************************************************************ -* * - Building record selectors -* * -************************************************************************ --} - -{- Note [Default method Ids and Template Haskell] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider this (#4169): @@ -856,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 ] @@ -896,14 +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 } -- 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 @@ -928,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 @@ -942,37 +936,34 @@ -- make the binding: sel (C2 { fld = x }) = x -- sel (C7 { fld = x }) = x -- where cons_w_field = [C2,C7] - sel_bind = mkTopFunBind Generated 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 $ mkVarUnqual (field_label lbl))) + = 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 - [wrapGenSpan (WildPat noExtField)] - (wrapGenSpan - (HsApp noComments - (wrapGenSpan (HsVar noExtField (wrapGenSpan (getName rEC_SEL_ERROR_ID)))) - (wrapGenSpan (HsLit noComments msg_lit))))] + | otherwise = [mkSimpleMatch match_ctxt (wrapGenSpan [genWildPat]) + (genLHsApp + (genHsVar (getName rEC_SEL_ERROR_ID)) + (genLHsLit msg_lit))] -- Do not add a default case unless there are unmatched -- constructors. We must take account of GADTs, else we @@ -1070,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 @@ -1,6 +1,7 @@ {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE PatternSynonyms #-} @@ -29,7 +30,7 @@ -- The environment types Env(..), - TcGblEnv(..), TcLclEnv(..), + TcGblEnv(..), TcLclEnv(..), modifyLclCtxt, TcLclCtxt(..), setLclEnvTcLevel, getLclEnvTcLevel, setLclEnvLoc, getLclEnvLoc, lclEnvInGeneratedCode, IfGblEnv(..), IfLclEnv(..), @@ -40,9 +41,11 @@ FrontendResult(..), -- Renamer types - ErrCtxt, RecFieldEnv, pushErrCtxt, pushErrCtxtSameOrigin, + ErrCtxt, ImportAvails(..), emptyImportAvails, plusImportAvails, - WhereFrom(..), mkModDeps, + ImportUserSpec(..), + ImpUserList(..), + mkModDeps, -- Typechecker types TcTypeEnv, TcBinderStack, TcBinder(..), @@ -56,9 +59,15 @@ CompleteMatch, CompleteMatches, -- Template Haskell - ThStage(..), SpliceType(..), PendingStuff(..), - topStage, topAnnStage, topSpliceStage, - ThLevel, impLevel, outerLevel, thLevel, + ThLevel(..), SpliceType(..), SpliceOrBracket(..), PendingStuff(..), + topLevel, topAnnLevel, topSpliceLevel, + ThLevelIndex, + topLevelIndex, + spliceLevelIndex, + quoteLevelIndex, + + thLevelIndex, + ForeignSrcLang(..), THDocs, DocLoc(..), ThBindEnv, @@ -66,12 +75,15 @@ 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, TcIdSet, + TcId, NameShape(..), removeBindingShadowing, getPlatform, @@ -85,7 +97,7 @@ -- Defaulting plugin DefaultingPlugin(..), DefaultingProposal(..), - FillDefaulting, DefaultingPluginResult, + FillDefaulting, -- Role annotations RoleAnnotEnv, emptyRoleAnnotEnv, mkRoleAnnotEnv, @@ -102,31 +114,37 @@ import GHC.Platform import GHC.Driver.Env +import GHC.Driver.Env.KnotVars import GHC.Driver.Config.Core.Lint -import GHC.Driver.Session +import GHC.Driver.DynFlags import {-# SOURCE #-} GHC.Driver.Hooks +import GHC.Linker.Types + import GHC.Hs import GHC.Tc.Utils.TcType import GHC.Tc.Types.Constraint -import GHC.Tc.Types.Origin +import GHC.Tc.Types.CtLoc( CtLoc ) import GHC.Tc.Types.Evidence -import {-# SOURCE #-} GHC.Tc.Errors.Hole.FitTypes ( HoleFitPlugin ) +import GHC.Tc.Types.TH +import GHC.Tc.Types.TcRef +import GHC.Tc.Types.LclEnv +import GHC.Tc.Types.BasicTypes +import GHC.Tc.Types.ErrCtxt +import {-# SOURCE #-} GHC.Tc.Errors.Hole.Plugin ( HoleFitPlugin ) import GHC.Tc.Errors.Types import GHC.Core.Reduction ( Reduction(..) ) import GHC.Core.Type -import GHC.Core.TyCon ( TyCon, tyConKind ) +import GHC.Core.TyCon ( TyCon ) import GHC.Core.PatSyn ( PatSyn ) import GHC.Core.Lint ( lintAxioms ) -import GHC.Core.UsageEnv import GHC.Core.InstEnv import GHC.Core.FamInstEnv import GHC.Core.Predicate -import GHC.Types.Id ( idType, idName ) -import GHC.Types.FieldLabel ( FieldLabel ) +import GHC.Types.DefaultEnv ( DefaultEnv ) import GHC.Types.Fixity.Env import GHC.Types.Annotations import GHC.Types.CompleteMatch @@ -136,16 +154,12 @@ import GHC.Types.Name.Set import GHC.Types.Avail import GHC.Types.Var -import GHC.Types.Var.Env import GHC.Types.TypeEnv -import GHC.Types.TyThing import GHC.Types.SourceFile import GHC.Types.SrcLoc -import GHC.Types.Var.Set 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 @@ -159,25 +173,51 @@ import GHC.Utils.Error import GHC.Utils.Outputable import GHC.Utils.Fingerprint -import GHC.Utils.Misc import GHC.Utils.Panic import GHC.Utils.Logger import GHC.Builtin.Names ( isUnboundName ) +import GHCi.Message +import GHCi.RemoteTypes + import Data.Set ( Set ) import qualified Data.Set as S -import Data.Map ( Map ) +import qualified Data.Map as M import Data.Dynamic ( Dynamic ) +import Data.Map ( Map ) import Data.Typeable ( TypeRep ) import Data.Maybe ( mapMaybe ) -import GHCi.Message -import GHCi.RemoteTypes -import qualified Language.Haskell.TH as TH -import GHC.Driver.Env.KnotVars -import GHC.Linker.Types +-- | 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 @@ -291,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] } @@ -439,12 +478,10 @@ -- ^ 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 - tcg_field_env :: RecFieldEnv, -- ^ Just for things in this module - -- See Note [The interactive package] in "GHC.Runtime.Context" + tcg_fix_env :: FixityEnv, -- ^ Just for things in this module tcg_type_env :: TypeEnv, -- ^ Global type env for the module we are compiling now. All @@ -470,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. @@ -505,10 +545,18 @@ -- (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, tcg_used_gres :: TcRef [GlobalRdrElt], + -- ^ INVARIANT: all these GREs were imported; that is, + -- they all have a non-empty gre_imp field. tcg_keep :: TcRef NameSet, tcg_th_used :: TcRef Bool, @@ -520,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] @@ -532,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. @@ -603,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 @@ -647,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] @@ -687,22 +733,10 @@ instance ContainsModule TcGblEnv where extractModule env = tcg_semantic_mod env -type RecFieldEnv = NameEnv [FieldLabel] - -- Maps a constructor name *in this module* - -- to the fields for that constructor. - -- This is used when dealing with ".." notation in record - -- construction and pattern matching. - -- The FieldEnv deals *only* with constructors defined in *this* - -- module. For imported modules, we get the same info from the - -- TypeEnv - data SelfBootInfo = NoSelfBoot -- No corresponding hi-boot file | SelfBoot - { sb_mds :: ModDetails -- There was a hi-boot file, - , sb_tcs :: NameSet } -- defining these TyCons, --- What is sb_tcs used for? See Note [Extra dependencies from .hs-boot files] --- in GHC.Rename.Module + { sb_mds :: ModDetails } -- There was a hi-boot file bootExports :: SelfBootInfo -> NameSet bootExports boot = @@ -785,118 +819,9 @@ * GHC.Rename.Names.reportUnusedNames. Where newtype data constructors like (d) are imported, we don't want to report them as unused. - - -************************************************************************ -* * - The local typechecker environment -* * -************************************************************************ - -Note [The Global-Env/Local-Env story] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -During type checking, we keep in the tcg_type_env - * All types and classes - * All Ids derived from types and classes (constructors, selectors) - -At the end of type checking, we zonk the local bindings, -and as we do so we add to the tcg_type_env - * Locally defined top-level Ids - -Why? Because they are now Ids not TcIds. This final GlobalEnv is - a) fed back (via the knot) to typechecking the - unfoldings of interface signatures - b) used in the ModDetails of this module -} -data TcLclEnv -- Changes as we move inside an expression - -- Discarded after typecheck/rename; not passed on to desugarer - = TcLclEnv { - 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_tclvl :: TcLevel, - tcl_th_ctxt :: ThStage, -- 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) - -- We can't put this info in the TypeEnv because it's needed - -- (and extended) in the renamer, for untyped splices - - tcl_arrow_ctxt :: ArrowCtxt, -- Arrow-notation context - - tcl_rdr :: LocalRdrEnv, -- Local name envt - -- Maintained during renaming, of course, but also during - -- type checking, solely so that when renaming a Template-Haskell - -- splice we have the right environment for the renamer. - -- - -- Does *not* include global name envt; may shadow it - -- Includes both ordinary variables and type variables; - -- they are kept distinct because tyvar have a different - -- occurrence constructor (Name.TvOcc) - -- We still need the unsullied global name env so that - -- we can look up record field names - - tcl_env :: TcTypeEnv, -- The local type environment: - -- Ids and TyVars defined in this module - - tcl_usage :: TcRef UsageEnv, -- Required multiplicity of bindings is accumulated here. - - - tcl_bndrs :: TcBinderStack, -- Used for reporting relevant bindings, - -- and for tidying types - - tcl_lie :: TcRef WantedConstraints, -- Place to accumulate type constraints - tcl_errs :: TcRef (Messages TcRnMessage) -- Place to accumulate diagnostics - } - -setLclEnvTcLevel :: TcLclEnv -> TcLevel -> TcLclEnv -setLclEnvTcLevel env lvl = env { tcl_tclvl = lvl } - -getLclEnvTcLevel :: TcLclEnv -> TcLevel -getLclEnvTcLevel = tcl_tclvl - -setLclEnvLoc :: TcLclEnv -> RealSrcSpan -> TcLclEnv -setLclEnvLoc env loc = env { tcl_loc = loc } - -getLclEnvLoc :: TcLclEnv -> RealSrcSpan -getLclEnvLoc = tcl_loc - -lclEnvInGeneratedCode :: TcLclEnv -> Bool -lclEnvInGeneratedCode = tcl_in_gen_code - -type ErrCtxt = (Bool, TidyEnv -> TcM (TidyEnv, SDoc)) - -- 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 - --- These are here to avoid module loops: one might expect them --- in GHC.Tc.Types.Constraint, but they refer to ErrCtxt which refers to TcM. --- Easier to just keep these definitions here, alongside TcM. -pushErrCtxt :: CtOrigin -> ErrCtxt -> CtLoc -> CtLoc -pushErrCtxt o err loc@(CtLoc { ctl_env = lcl }) - = loc { ctl_origin = o, ctl_env = lcl { tcl_ctxt = err : tcl_ctxt lcl } } - -pushErrCtxtSameOrigin :: ErrCtxt -> CtLoc -> CtLoc --- Just add information w/o updating the origin! -pushErrCtxtSameOrigin err loc@(CtLoc { ctl_env = lcl }) - = loc { ctl_env = lcl { tcl_ctxt = err : tcl_ctxt lcl } } - -type TcTypeEnv = NameEnv TcTyThing - -type ThBindEnv = NameEnv (TopLevelFlag, ThLevel) - -- 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 - -- cross-stage at arbitrary types if the Id is bound at top level. - -- - -- 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 - {- Note [Given Insts] ~~~~~~~~~~~~~~~~~~ Because of GADTs, we have to pass inwards the Insts provided by type signatures @@ -911,54 +836,7 @@ -} --- | Type alias for 'IORef'; the convention is we'll use this for mutable --- bits of data in 'TcGblEnv' which are updated during typechecking and --- returned at the end. -type TcRef a = IORef a --- ToDo: when should I refer to it as a 'TcId' instead of an 'Id'? -type TcId = Id -type TcIdSet = IdSet ---------------------------- --- The TcBinderStack ---------------------------- - -type TcBinderStack = [TcBinder] - -- This is a stack of locally-bound ids and tyvars, - -- innermost on top - -- Used only in error reporting (relevantBindings in TcError), - -- and in tidying - -- We can't use the tcl_env type environment, because it doesn't - -- keep track of the nesting order - -data TcBinder - = TcIdBndr - TcId - TopLevelFlag -- Tells whether the binding is syntactically top-level - -- (The monomorphic Ids for a recursive group count - -- as not-top-level for this purpose.) - - | TcIdBndr_ExpType -- Variant that allows the type to be specified as - -- an ExpType - Name - ExpType - TopLevelFlag - - | TcTvBndr -- e.g. case x of P (y::a) -> blah - Name -- We bind the lexical name "a" to the type of y, - TyVar -- which might be an utterly different (perhaps - -- existential) tyvar - -instance Outputable TcBinder where - ppr (TcIdBndr id top_lvl) = ppr id <> brackets (ppr top_lvl) - ppr (TcIdBndr_ExpType id _ top_lvl) = ppr id <> brackets (ppr top_lvl) - ppr (TcTvBndr name tv) = ppr name <+> ppr tv - -instance HasOccName TcBinder where - occName (TcIdBndr id _) = occName (idName id) - occName (TcIdBndr_ExpType name _ _) = occName name - occName (TcTvBndr name _) = occName name - -- fixes #12177 -- Builds up a list of bindings whose OccName has not been seen before -- i.e., If ys = removeBindingShadowing xs @@ -981,104 +859,7 @@ getPlatform :: TcRnIf a b Platform getPlatform = targetPlatform <$> getDynFlags ---------------------------- --- Template Haskell stages and levels ---------------------------- -data SpliceType = Typed | Untyped - -data ThStage -- 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 - - | RunSplice (TcRef [ForeignRef (TH.Q ())]) - -- Set when running a splice, i.e. NOT when renaming or typechecking the - -- Haskell code for the splice. See Note [RunSplice ThLevel]. - -- - -- Contains a list of mod finalizers collected while executing the splice. - -- - -- 'addModFinalizer' inserts finalizers here, and from here they are taken - -- to construct an @HsSpliced@ annotation for untyped splices. See Note - -- [Delaying modFinalizers in untyped splices] in GHC.Rename.Splice. - -- - -- For typed splices, the typechecker takes finalizers from here and - -- inserts them in the list of finalizers in the global environment. - -- - -- See Note [Collecting modFinalizers in typed splices] in "GHC.Tc.Gen.Splice". - - | Comp -- Ordinary Haskell code - -- Binding level = 1 - - | Brack -- Inside brackets - ThStage -- Enclosing stage - PendingStuff - -data PendingStuff - = RnPendingUntyped -- Renaming the inside of an *untyped* bracket - (TcRef [PendingRnSplice]) -- Pending splices in here - - | RnPendingTyped -- Renaming the inside of a *typed* bracket - - | TcPending -- Typechecking the inside of a typed bracket - (TcRef [PendingTcSplice]) -- Accumulate pending splices here - (TcRef WantedConstraints) -- and type constraints here - QuoteWrapper -- A type variable and evidence variable - -- for the overall monad of - -- the bracket. Splices are checked - -- against this monad. The evidence - -- variable is used for desugaring - -- `lift`. - - -topStage, topAnnStage, topSpliceStage :: ThStage -topStage = Comp -topAnnStage = Splice Untyped -topSpliceStage = Splice Untyped - -instance Outputable ThStage where - ppr (Splice _) = text "Splice" - ppr (RunSplice _) = text "RunSplice" - ppr Comp = text "Comp" - 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" - -- See Note [RunSplice ThLevel]. - -{- Note [RunSplice ThLevel] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The 'RunSplice' stage 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. - -'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 -set 'RunSplice' when renaming or typechecking the splice, where 'Splice', -'Brack' or 'Comp' are used instead. - --} - --------------------------- -- Arrow-notation context --------------------------- @@ -1116,237 +897,6 @@ from further out in the ArrowCtxt that we push inwards. -} -data ArrowCtxt -- Note [Escaping the arrow scope] - = NoArrowCtxt - | ArrowCtxt LocalRdrEnv (TcRef WantedConstraints) - - ---------------------------- --- TcTyThing ---------------------------- - --- | A typecheckable thing available in a local context. Could be --- 'AGlobal' 'TyThing', but also lexically scoped variables, etc. --- See "GHC.Tc.Utils.Env" for how to retrieve a 'TyThing' given a 'Name'. -data TcTyThing - = AGlobal TyThing -- Used only in the return type of a lookup - - | ATcId -- Ids defined in this module; may not be fully zonked - { tct_id :: TcId - , tct_info :: IdBindingInfo -- See Note [Meaning of IdBindingInfo] - } - - | ATyVar Name TcTyVar -- See Note [Type variables in the type environment] - - | ATcTyCon TyCon -- Used temporarily, during kind checking, for the - -- tycons and classes in this recursive group - -- The TyCon is always a TcTyCon. Its kind - -- can be a mono-kind or a poly-kind; in TcTyClsDcls see - -- Note [Type checking recursive type and class declarations] - - | APromotionErr PromotionErr - --- | Matches on either a global 'TyCon' or a 'TcTyCon'. -tcTyThingTyCon_maybe :: TcTyThing -> Maybe TyCon -tcTyThingTyCon_maybe (AGlobal (ATyCon tc)) = Just tc -tcTyThingTyCon_maybe (ATcTyCon tc_tc) = Just tc_tc -tcTyThingTyCon_maybe _ = Nothing - -instance Outputable TcTyThing where -- Debugging only - ppr (AGlobal g) = ppr g - ppr elt@(ATcId {}) = text "Identifier" <> - brackets (ppr (tct_id elt) <> dcolon - <> ppr (varType (tct_id elt)) <> comma - <+> ppr (tct_info elt)) - ppr (ATyVar n tv) = text "Type variable" <+> quotes (ppr n) <+> equals <+> ppr tv - <+> dcolon <+> ppr (varType tv) - ppr (ATcTyCon tc) = text "ATcTyCon" <+> ppr tc <+> dcolon <+> ppr (tyConKind tc) - ppr (APromotionErr err) = text "APromotionErr" <+> ppr err - --- | IdBindingInfo describes how an Id is bound. --- --- It is used for the following purposes: --- a) for static forms in 'GHC.Tc.Gen.Expr.checkClosedInStaticForm' and --- b) to figure out when a nested binding can be generalised, --- in 'GHC.Tc.Gen.Bind.decideGeneralisationPlan'. --- -data IdBindingInfo -- See Note [Meaning of IdBindingInfo] - = NotLetBound - | ClosedLet - | NonClosedLet - RhsNames -- Used for (static e) checks only - ClosedTypeId -- Used for generalisation checks - -- and for (static e) checks - --- | IsGroupClosed describes a group of mutually-recursive bindings -data IsGroupClosed - = IsGroupClosed - (NameEnv RhsNames) -- Free var info for the RHS of each binding in the group - -- Used only for (static e) checks - - ClosedTypeId -- True <=> all the free vars of the group are - -- imported or ClosedLet or - -- NonClosedLet with ClosedTypeId=True. - -- In particular, no tyvars, no NotLetBound - -type RhsNames = NameSet -- Names of variables, mentioned on the RHS of - -- a definition, that are not Global or ClosedLet - -type ClosedTypeId = Bool - -- See Note [Meaning of IdBindingInfo] - -{- Note [Meaning of IdBindingInfo] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -NotLetBound means that - the Id is not let-bound (e.g. it is bound in a - lambda-abstraction or in a case pattern) - -ClosedLet means that - - The Id is let-bound, - - Any free term variables are also Global or ClosedLet - - Its type has no free variables (NB: a top-level binding subject - to the MR might have free vars in its type) - These ClosedLets can definitely be floated to top level; and we - may need to do so for static forms. - - Property: ClosedLet - is equivalent to - NonClosedLet emptyNameSet True - -(NonClosedLet (fvs::RhsNames) (cl::ClosedTypeId)) means that - - The Id is let-bound - - - The fvs::RhsNames contains the free names of the RHS, - excluding Global and ClosedLet ones. - - - For the ClosedTypeId field see Note [Bindings with closed types: ClosedTypeId] - -For (static e) to be valid, we need for every 'x' free in 'e', -that x's binding is floatable to the top level. Specifically: - * x's RhsNames must be empty - * x's type has no free variables -See Note [Grand plan for static forms] in "GHC.Iface.Tidy.StaticPtrTable". -This test is made in GHC.Tc.Gen.Expr.checkClosedInStaticForm. -Actually knowing x's RhsNames (rather than just its emptiness -or otherwise) is just so we can produce better error messages - -Note [Bindings with closed types: ClosedTypeId] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - - f x = let g ys = map not ys - in ... - -Can we generalise 'g' under the OutsideIn algorithm? Yes, -because all g's free variables are top-level; that is they themselves -have no free type variables, and it is the type variables in the -environment that makes things tricky for OutsideIn generalisation. - -Here's the invariant: - If an Id has ClosedTypeId=True (in its IdBindingInfo), then - the Id's type is /definitely/ closed (has no free type variables). - Specifically, - a) The Id's actual type is closed (has no free tyvars) - b) Either the Id has a (closed) user-supplied type signature - or all its free variables are Global/ClosedLet - or NonClosedLet with ClosedTypeId=True. - In particular, none are NotLetBound. - -Why is (b) needed? Consider - \x. (x :: Int, let y = x+1 in ...) -Initially x::alpha. If we happen to typecheck the 'let' before the -(x::Int), y's type will have a free tyvar; but if the other way round -it won't. So we treat any let-bound variable with a free -non-let-bound variable as not ClosedTypeId, regardless of what the -free vars of its type actually are. - -But if it has a signature, all is well: - \x. ...(let { y::Int; y = x+1 } in - let { v = y+2 } in ...)... -Here the signature on 'v' makes 'y' a ClosedTypeId, so we can -generalise 'v'. - -Note that: - - * A top-level binding may not have ClosedTypeId=True, if it suffers - from the MR - - * A nested binding may be closed (eg 'g' in the example we started - with). Indeed, that's the point; whether a function is defined at - top level or nested is orthogonal to the question of whether or - not it is closed. - - * A binding may be non-closed because it mentions a lexically scoped - *type variable* Eg - f :: forall a. blah - f x = let g y = ...(y::a)... - -Under OutsideIn we are free to generalise an Id all of whose free -variables have ClosedTypeId=True (or imported). This is an extension -compared to the JFP paper on OutsideIn, which used "top-level" as a -proxy for "closed". (It's not a good proxy anyway -- the MR can make -a top-level binding with a free type variable.) - -Note [Type variables in the type environment] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The type environment has a binding for each lexically-scoped -type variable that is in scope. For example - - f :: forall a. a -> a - f x = (x :: a) - - g1 :: [a] -> a - g1 (ys :: [b]) = head ys :: b - - g2 :: [Int] -> Int - g2 (ys :: [c]) = head ys :: c - -* The forall'd variable 'a' in the signature scopes over f's RHS. - -* The pattern-bound type variable 'b' in 'g1' scopes over g1's - RHS; note that it is bound to a skolem 'a' which is not itself - lexically in scope. - -* The pattern-bound type variable 'c' in 'g2' is bound to - Int; that is, pattern-bound type variables can stand for - arbitrary types. (see - GHC proposal #128 "Allow ScopedTypeVariables to refer to types" - https://github.com/ghc-proposals/ghc-proposals/pull/128, - and the paper - "Type variables in patterns", Haskell Symposium 2018. - - -This is implemented by the constructor - ATyVar Name TcTyVar -in the type environment. - -* The Name is the name of the original, lexically scoped type - variable - -* The TcTyVar is sometimes a skolem (like in 'f'), and sometimes - a unification variable (like in 'g1', 'g2'). We never zonk the - type environment so in the latter case it always stays as a - unification variable, although that variable may be later - unified with a type (such as Int in 'g2'). --} - -instance Outputable IdBindingInfo where - ppr NotLetBound = text "NotLetBound" - ppr ClosedLet = text "TopLevelLet" - ppr (NonClosedLet fvs closed_type) = - text "TopLevelLet" <+> ppr fvs <+> ppr closed_type - --------------- -pprTcTyThingCategory :: TcTyThing -> SDoc -pprTcTyThingCategory = text . capitalise . tcTyThingCategory - -tcTyThingCategory :: TcTyThing -> String -tcTyThingCategory (AGlobal thing) = tyThingCategory thing -tcTyThingCategory (ATyVar {}) = "type variable" -tcTyThingCategory (ATcId {}) = "local identifier" -tcTyThingCategory (ATcTyCon {}) = "local tycon" -tcTyThingCategory (APromotionErr pe) = peCategory pe - {- ************************************************************************ * * @@ -1362,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 @@ -1377,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 = [], @@ -1408,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, @@ -1418,214 +982,7 @@ imp_orphs = unionListsOrd orphs1 orphs2, imp_finsts = unionListsOrd finsts1 finsts2 } -{- -************************************************************************ -* * -\subsection{Where from} -* * -************************************************************************ -The @WhereFrom@ type controls where the renamer looks for an interface file --} - -data WhereFrom - = ImportByUser IsBootInterface -- Ordinary user import (perhaps {-# SOURCE #-}) - | ImportBySystem -- Non user import. - | ImportByPlugin -- Importing a plugin; - -- See Note [Care with plugin imports] in GHC.Iface.Load - -instance Outputable WhereFrom where - ppr (ImportByUser IsBoot) = text "{- SOURCE -}" - ppr (ImportByUser NotBoot) = empty - ppr ImportBySystem = text "{- SYSTEM -}" - ppr ImportByPlugin = text "{- PLUGIN -}" - - -{- ********************************************************************* -* * - Type signatures -* * -********************************************************************* -} - --- These data types need to be here only because --- GHC.Tc.Solver uses them, and GHC.Tc.Solver is fairly --- low down in the module hierarchy - -type TcSigFun = Name -> Maybe TcSigInfo - -data TcSigInfo = TcIdSig TcIdSigInfo - | TcPatSynSig TcPatSynInfo - -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 - - , 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 - - , sig_loc :: SrcSpan -- Location of the type signature - } - - | PartialSig -- 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 - } - - -{- Note [Complete and partial type signatures] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -A type signature is partial when it contains one or more wildcards -(= type holes). The wildcard can either be: -* A (type) wildcard occurring in sig_theta or sig_tau. These are - stored in sig_wcs. - f :: Bool -> _ - g :: Eq _a => _a -> _a -> Bool -* Or an extra-constraints wildcard, stored in sig_cts: - h :: (Num a, _) => a -> a - -A type signature is a complete type signature when there are no -wildcards in the type signature, i.e. iff sig_wcs is empty and -sig_extra_cts is Nothing. --} - -data TcIdSigInst - = TISI { sig_inst_sig :: TcIdSigInfo - - , sig_inst_skols :: [(Name, InvisTVBinder)] - -- Instantiated type and kind variables, TyVarTvs - -- The Name is the Name that the renamer chose; - -- but the TcTyVar may come from instantiating - -- the type and hence have a different unique. - -- No need to keep track of whether they are truly lexically - -- scoped because the renamer has named them uniquely - -- See Note [Binding scoped type variables] in GHC.Tc.Gen.Sig - -- - -- NB: The order of sig_inst_skols is irrelevant - -- for a CompleteSig, but for a PartialSig see - -- Note [Quantified variables in partial type signatures] - - , sig_inst_theta :: TcThetaType - -- Instantiated theta. In the case of a - -- PartialSig, sig_theta does not include - -- the extra-constraints wildcard - - , sig_inst_tau :: TcSigmaType -- Instantiated tau - -- See Note [sig_inst_tau may be polymorphic] - - -- Relevant for partial signature only - , sig_inst_wcs :: [(Name, TcTyVar)] - -- Like sig_inst_skols, but for /named/ wildcards (_a etc). - -- The named wildcards scope over the binding, and hence - -- their Names may appear in type signatures in the binding - - , sig_inst_wcx :: Maybe TcType - -- Extra-constraints wildcard to fill in, if any - -- If this exists, it is surely of the form (meta_tv |> co) - -- (where the co might be reflexive). This is filled in - -- only from the return value of GHC.Tc.Gen.HsType.tcAnonWildCardOcc - } - -{- Note [sig_inst_tau may be polymorphic] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -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 -It happens, too! See Note [Polymorphic methods] in GHC.Tc.TyCl.Class. - -Note [Quantified variables in partial type signatures] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - f :: forall a b. _ -> a -> _ -> b - f (x,y) p q = q - -Then we expect f's final type to be - f :: forall {x,y}. forall a b. (x,y) -> a -> b -> b - -Note that x,y are Inferred, and can't be use for visible type -application (VTA). But a,b are Specified, and remain Specified -in the final type, so we can use VTA for them. (Exception: if -it turns out that a's kind mentions b we need to reorder them -with scopedSort.) - -The sig_inst_skols of the TISI from a partial signature records -that original order, and is used to get the variables of f's -final type in the correct order. - - -Note [Wildcards in partial signatures] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The wildcards in psig_wcs may stand for a type mentioning -the universally-quantified tyvars of psig_ty - -E.g. f :: forall a. _ -> a - f x = x -We get sig_inst_skols = [a] - sig_inst_tau = _22 -> a - sig_inst_wcs = [_22] -and _22 in the end is unified with the type 'a' - -Moreover the kind of a wildcard in sig_inst_wcs may mention -the universally-quantified tyvars sig_inst_skols -e.g. f :: t a -> t _ -Here we get - sig_inst_skols = [k:*, (t::k ->*), (a::k)] - sig_inst_tau = t a -> t _22 - 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 - -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 "psig" <+> ppr name <+> dcolon <+> ppr hs_ty - -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 TcPatSynInfo where - ppr (TPSI{ patsig_name = name}) = ppr name - -isPartialSig :: TcIdSigInst -> Bool -isPartialSig (TISI { sig_inst_sig = PartialSig {} }) = 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 - - {- Constraint Solver Plugins ------------------------- @@ -1679,7 +1036,7 @@ -- and possibly emit additional constraints. These returned constraints -- must be Givens in the first case, and Wanteds in the second. -- - -- Use @ \\ _ _ _ _ _ -> pure $ TcPluginOK [] [] @ if your plugin + -- Use @ \\ _ _ _ _ -> pure $ TcPluginOk [] [] @ if your plugin -- does not provide this functionality. , tcPluginRewrite :: s -> UniqFM TyCon TcPluginRewriter @@ -1756,24 +1113,20 @@ , 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 diff --git a/GHC/Tc/Types.hs-boot b/GHC/Tc/Types.hs-boot deleted file mode 100644 --- a/GHC/Tc/Types.hs-boot +++ /dev/null @@ -1,24 +0,0 @@ -module GHC.Tc.Types where - -import GHC.Prelude -import GHC.Tc.Utils.TcType -import GHC.Types.SrcLoc -import GHC.Utils.Outputable - -data TcLclEnv - -data SelfBootInfo - -data TcIdSigInfo -instance Outputable TcIdSigInfo - -data TcTyThing -instance Outputable TcTyThing - -setLclEnvTcLevel :: TcLclEnv -> TcLevel -> TcLclEnv -getLclEnvTcLevel :: TcLclEnv -> TcLevel - -setLclEnvLoc :: TcLclEnv -> RealSrcSpan -> TcLclEnv -getLclEnvLoc :: TcLclEnv -> RealSrcSpan - -lclEnvInGeneratedCode :: TcLclEnv -> Bool diff --git a/GHC/Tc/Types/BasicTypes.hs b/GHC/Tc/Types/BasicTypes.hs new file mode 100644 --- /dev/null +++ b/GHC/Tc/Types/BasicTypes.hs @@ -0,0 +1,524 @@ +module GHC.Tc.Types.BasicTypes ( + -- * TcBinder + TcBinderStack + , TcId + , TcBinder(..) + + -- * Signatures + , TcSigFun, TcSigInfo(..), TcIdSig(..) + , TcCompleteSig(..), TcPartialSig(..), TcPatSynSig(..) + , TcIdSigInst(..) + , isPartialSig, hasCompleteSig + , tcSigInfoName, tcIdSigLoc, completeSigPolyId_maybe + + -- * TcTyThing + , TcTyThing(..) + , IdBindingInfo(..) + , IsGroupClosed(..) + , RhsNames + , ClosedTypeId + , tcTyThingCategory + , tcTyThingTyCon_maybe + , pprTcTyThingCategory + ) where + +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 +import GHC.Types.SrcLoc +import GHC.Types.Name +import GHC.Types.TyThing +import GHC.Types.Name.Env +import GHC.Types.Name.Set + +import GHC.Hs.Extension ( GhcRn ) + +import Language.Haskell.Syntax.Type ( LHsSigWcType ) + +import GHC.Tc.Errors.Types.PromotionErr (PromotionErr, peCategory) + +import GHC.Core.TyCon ( TyCon, tyConKind ) +import GHC.Utils.Outputable +import GHC.Utils.Misc + + +--------------------------- +-- The TcBinderStack +--------------------------- + +type TcBinderStack = [TcBinder] +type TcId = Id + -- This is a stack of locally-bound ids and tyvars, + -- innermost on top + -- Used only in error reporting (relevantBindings in TcError), + -- and in tidying + -- We can't use the tcl_env type environment, because it doesn't + -- keep track of the nesting order + +data TcBinder + = TcIdBndr + TcId + TopLevelFlag -- Tells whether the binding is syntactically top-level + -- (The monomorphic Ids for a recursive group count + -- as not-top-level for this purpose.) + + | TcIdBndr_ExpType -- Variant that allows the type to be specified as + -- an ExpType + Name + ExpType + TopLevelFlag + + | TcTvBndr -- e.g. case x of P (y::a) -> blah + Name -- We bind the lexical name "a" to the type of y, + TyVar -- which might be an utterly different (perhaps + -- existential) tyvar + +instance Outputable TcBinder where + ppr (TcIdBndr id top_lvl) = ppr id <> brackets (ppr top_lvl) + ppr (TcIdBndr_ExpType id _ top_lvl) = ppr id <> brackets (ppr top_lvl) + ppr (TcTvBndr name tv) = ppr name <+> ppr tv + +instance HasOccName TcBinder where + occName (TcIdBndr id _) = occName (idName id) + occName (TcIdBndr_ExpType name _ _) = occName name + occName (TcTvBndr name _) = occName name + +{- ********************************************************************* +* * + Type signatures +* * +********************************************************************* -} + +-- These data types need to be here only because +-- GHC.Tc.Solver uses them, and GHC.Tc.Solver is fairly +-- low down in the module hierarchy + +type TcSigFun = Name -> Maybe TcSigInfo + +-- TcSigInfo is simply the range of TcSigFun +data TcSigInfo = TcIdSig TcIdSig + | TcPatSynSig TcPatSynSig -- For a pattern synonym + +-- See Note [Complete and partial type signatures] +data TcIdSig -- For an Id + = TcCompleteSig TcCompleteSig + | TcPartialSig TcPartialSig + +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_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 + + , 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 { 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] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +A type signature is partial when it contains one or more wildcards +(= type holes). The wildcard can either be: +* A (type) wildcard occurring in sig_theta or sig_tau. These are + stored in sig_wcs. + f :: Bool -> _ + g :: Eq _a => _a -> _a -> Bool +* Or an extra-constraints wildcard, stored in sig_cts: + h :: (Num a, _) => a -> a + +A type signature is a complete type signature when there are no +wildcards in the type signature, i.e. iff sig_wcs is empty and +sig_extra_cts is Nothing. +-} + +data TcIdSigInst + = TISI { sig_inst_sig :: TcIdSig + + , sig_inst_skols :: [(Name, InvisTVBinder)] + -- Instantiated type and kind variables, TyVarTvs + -- The Name is the Name that the renamer chose; + -- but the TcTyVar may come from instantiating + -- the type and hence have a different unique. + -- No need to keep track of whether they are truly lexically + -- scoped because the renamer has named them uniquely + -- See Note [Binding scoped type variables] in GHC.Tc.Gen.Sig + -- + -- NB: The order of sig_inst_skols is irrelevant + -- for a CompleteSig, but for a PartialSig see + -- Note [Quantified variables in partial type signatures] + + , sig_inst_theta :: TcThetaType + -- Instantiated theta. In the case of a + -- PartialSig, sig_theta does not include + -- the extra-constraints wildcard + + , sig_inst_tau :: TcSigmaType -- Instantiated tau + -- See Note [sig_inst_tau may be polymorphic] + + -- Relevant for partial signature only + , sig_inst_wcs :: [(Name, TcTyVar)] + -- Like sig_inst_skols, but for /named/ wildcards (_a etc). + -- The named wildcards scope over the binding, and hence + -- their Names may appear in type signatures in the binding + + , sig_inst_wcx :: Maybe TcType + -- Extra-constraints wildcard to fill in, if any + -- If this exists, it is surely of the form (meta_tv |> co) + -- (where the co might be reflexive). This is filled in + -- only from the return value of GHC.Tc.Gen.HsType.tcAnonWildCardOcc + } + +{- Note [sig_inst_tau may be polymorphic] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +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: 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] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + f :: forall a b. _ -> a -> _ -> b + f (x,y) p q = q + +Then we expect f's final type to be + f :: forall {x,y}. forall a b. (x,y) -> a -> b -> b + +Note that x,y are Inferred, and can't be use for visible type +application (VTA). But a,b are Specified, and remain Specified +in the final type, so we can use VTA for them. (Exception: if +it turns out that a's kind mentions b we need to reorder them +with scopedSort.) + +The sig_inst_skols of the TISI from a partial signature records +that original order, and is used to get the variables of f's +final type in the correct order. + + +Note [Wildcards in partial signatures] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The wildcards in psig_wcs may stand for a type mentioning +the universally-quantified tyvars of psig_ty + +E.g. f :: forall a. _ -> a + f x = x +We get sig_inst_skols = [a] + sig_inst_tau = _22 -> a + sig_inst_wcs = [_22] +and _22 in the end is unified with the type 'a' + +Moreover the kind of a wildcard in sig_inst_wcs may mention +the universally-quantified tyvars sig_inst_skols +e.g. f :: t a -> t _ +Here we get + sig_inst_skols = [k:*, (t::k ->*), (a::k)] + sig_inst_tau = t a -> t _22 + sig_inst_wcs = [ _22::k ] +-} + +instance Outputable TcSigInfo where + ppr (TcIdSig sig) = ppr sig + ppr (TcPatSynSig sig) = ppr sig + +instance Outputable TcIdSig where + ppr (TcCompleteSig sig) = ppr sig + ppr (TcPartialSig sig) = ppr sig + +instance Outputable TcCompleteSig where + ppr (CSig { sig_bndr = bndr }) + = ppr bndr <+> dcolon <+> ppr (idType bndr) + +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 = 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 (TcCompleteSig {})) -> True + _ -> False + +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. +-- See "GHC.Tc.Utils.Env" for how to retrieve a 'TyThing' given a 'Name'. +data TcTyThing + = AGlobal TyThing -- Used only in the return type of a lookup + + | ATcId -- Ids defined in this module; may not be fully zonked + { tct_id :: Id + , tct_info :: IdBindingInfo -- See Note [Meaning of IdBindingInfo] + } + + | ATyVar Name TcTyVar -- See Note [Type variables in the type environment] + + | ATcTyCon TyCon -- Used temporarily, during kind checking, for the + -- tycons and classes in this recursive group + -- The TyCon is always a TcTyCon. Its kind + -- can be a mono-kind or a poly-kind; in TcTyClsDcls see + -- Note [Type checking recursive type and class declarations] + + | APromotionErr PromotionErr + +-- | Matches on either a global 'TyCon' or a 'TcTyCon'. +tcTyThingTyCon_maybe :: TcTyThing -> Maybe TyCon +tcTyThingTyCon_maybe (AGlobal (ATyCon tc)) = Just tc +tcTyThingTyCon_maybe (ATcTyCon tc_tc) = Just tc_tc +tcTyThingTyCon_maybe _ = Nothing + +instance Outputable TcTyThing where -- Debugging only + ppr (AGlobal g) = ppr g + ppr elt@(ATcId {}) = text "Identifier" <> + brackets (ppr (tct_id elt) <> dcolon + <> ppr (varType (tct_id elt)) <> comma + <+> ppr (tct_info elt)) + ppr (ATyVar n tv) = text "Type variable" <+> quotes (ppr n) <+> equals <+> ppr tv + <+> dcolon <+> ppr (varType tv) + ppr (ATcTyCon tc) = text "ATcTyCon" <+> ppr tc <+> dcolon <+> ppr (tyConKind tc) + ppr (APromotionErr err) = text "APromotionErr" <+> ppr err + +-- | IdBindingInfo describes how an Id is bound. +-- +-- It is used for the following purposes: +-- a) for static forms in 'GHC.Tc.Gen.Expr.checkClosedInStaticForm' and +-- b) to figure out when a nested binding can be generalised, +-- in 'GHC.Tc.Gen.Bind.decideGeneralisationPlan'. +-- +data IdBindingInfo -- See Note [Meaning of IdBindingInfo] + = NotLetBound + | ClosedLet + | NonClosedLet + RhsNames -- Used for (static e) checks only + ClosedTypeId -- Used for generalisation checks + -- and for (static e) checks + +-- | IsGroupClosed describes a group of mutually-recursive bindings +data IsGroupClosed + = IsGroupClosed + (NameEnv RhsNames) -- Free var info for the RHS of each binding in the group + -- Used only for (static e) checks + + ClosedTypeId -- True <=> all the free vars of the group are + -- imported or ClosedLet or + -- NonClosedLet with ClosedTypeId=True. + -- In particular, no tyvars, no NotLetBound + +type RhsNames = NameSet -- Names of variables, mentioned on the RHS of + -- a definition, that are not Global or ClosedLet + +type ClosedTypeId = Bool + -- See Note [Meaning of IdBindingInfo] + +{- Note [Meaning of IdBindingInfo] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +NotLetBound means that + the Id is not let-bound (e.g. it is bound in a + lambda-abstraction or in a case pattern) + +ClosedLet means that + - The Id is let-bound, + - Any free term variables are also Global or ClosedLet + - Its type has no free variables (NB: a top-level binding subject + to the MR might have free vars in its type) + These ClosedLets can definitely be floated to top level; and we + may need to do so for static forms. + + Property: ClosedLet + is equivalent to + NonClosedLet emptyNameSet True + +(NonClosedLet (fvs::RhsNames) (cl::ClosedTypeId)) means that + - The Id is let-bound + + - The fvs::RhsNames contains the free names of the RHS, + excluding Global and ClosedLet ones. + + - For the ClosedTypeId field see Note [Bindings with closed types: ClosedTypeId] + +For (static e) to be valid, we need for every 'x' free in 'e', +that x's binding is floatable to the top level. Specifically: + * x's RhsNames must be empty + * x's type has no free variables +See Note [Grand plan for static forms] in "GHC.Iface.Tidy.StaticPtrTable". +This test is made in GHC.Tc.Gen.Expr.checkClosedInStaticForm. +Actually knowing x's RhsNames (rather than just its emptiness +or otherwise) is just so we can produce better error messages + +Note [Bindings with closed types: ClosedTypeId] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + + f x = let g ys = map not ys + in ... + +Can we generalise 'g' under the OutsideIn algorithm? Yes, +because all g's free variables are top-level; that is they themselves +have no free type variables, and it is the type variables in the +environment that makes things tricky for OutsideIn generalisation. + +Here's the invariant: + If an Id has ClosedTypeId=True (in its IdBindingInfo), then + the Id's type is /definitely/ closed (has no free type variables). + Specifically, + a) The Id's actual type is closed (has no free tyvars) + b) Either the Id has a (closed) user-supplied type signature + or all its free variables are Global/ClosedLet + or NonClosedLet with ClosedTypeId=True. + In particular, none are NotLetBound. + +Why is (b) needed? Consider + \x. (x :: Int, let y = x+1 in ...) +Initially x::alpha. If we happen to typecheck the 'let' before the +(x::Int), y's type will have a free tyvar; but if the other way round +it won't. So we treat any let-bound variable with a free +non-let-bound variable as not ClosedTypeId, regardless of what the +free vars of its type actually are. + +But if it has a signature, all is well: + \x. ...(let { y::Int; y = x+1 } in + let { v = y+2 } in ...)... +Here the signature on 'v' makes 'y' a ClosedTypeId, so we can +generalise 'v'. + +Note that: + + * A top-level binding may not have ClosedTypeId=True, if it suffers + from the MR + + * A nested binding may be closed (eg 'g' in the example we started + with). Indeed, that's the point; whether a function is defined at + top level or nested is orthogonal to the question of whether or + not it is closed. + + * A binding may be non-closed because it mentions a lexically scoped + *type variable* Eg + f :: forall a. blah + f x = let g y = ...(y::a)... + +Under OutsideIn we are free to generalise an Id all of whose free +variables have ClosedTypeId=True (or imported). This is an extension +compared to the JFP paper on OutsideIn, which used "top-level" as a +proxy for "closed". (It's not a good proxy anyway -- the MR can make +a top-level binding with a free type variable.) + +Note [Type variables in the type environment] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The type environment has a binding for each lexically-scoped +type variable that is in scope. For example + + f :: forall a. a -> a + f x = (x :: a) + + g1 :: [a] -> a + g1 (ys :: [b]) = head ys :: b + + g2 :: [Int] -> Int + g2 (ys :: [c]) = head ys :: c + +* The forall'd variable 'a' in the signature scopes over f's RHS. + +* The pattern-bound type variable 'b' in 'g1' scopes over g1's + RHS; note that it is bound to a skolem 'a' which is not itself + lexically in scope. + +* The pattern-bound type variable 'c' in 'g2' is bound to + Int; that is, pattern-bound type variables can stand for + arbitrary types. (see + GHC proposal #128 "Allow ScopedTypeVariables to refer to types" + https://github.com/ghc-proposals/ghc-proposals/pull/128, + and the paper + "Type variables in patterns", Haskell Symposium 2018. + + +This is implemented by the constructor + ATyVar Name TcTyVar +in the type environment. + +* The Name is the name of the original, lexically scoped type + variable + +* The TcTyVar is sometimes a skolem (like in 'f'), and sometimes + a unification variable (like in 'g1', 'g2'). We never zonk the + type environment so in the latter case it always stays as a + unification variable, although that variable may be later + unified with a type (such as Int in 'g2'). +-} + +instance Outputable IdBindingInfo where + ppr NotLetBound = text "NotLetBound" + ppr ClosedLet = text "TopLevelLet" + ppr (NonClosedLet fvs closed_type) = + text "TopLevelLet" <+> ppr fvs <+> ppr closed_type + +-------------- +pprTcTyThingCategory :: TcTyThing -> SDoc +pprTcTyThingCategory = text . capitalise . tcTyThingCategory + +tcTyThingCategory :: TcTyThing -> String +tcTyThingCategory (AGlobal thing) = tyThingCategory thing +tcTyThingCategory (ATyVar {}) = "type variable" +tcTyThingCategory (ATcId {}) = "local identifier" +tcTyThingCategory (ATcTyCon {}) = "local tycon" +tcTyThingCategory (APromotionErr pe) = peCategory pe 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,2450 +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 ( - -- QCInst - QCInst(..), pendingScInst_maybe, - - -- Canonical constraints - Xi, Ct(..), Cts, - emptyCts, andCts, andManyCts, pprCts, - singleCt, listToCts, ctsElts, consCts, snocCts, extendCtsList, - isEmptyCts, - isPendingScDict, pendingScDict_maybe, - superClassesMightHelp, getPendingWantedScs, - isWantedCt, isGivenCt, - isUserTypeError, getUserTypeErrorMsg, - ctEvidence, ctLoc, ctPred, ctFlavour, ctEqRel, ctOrigin, - ctRewriters, - ctEvId, wantedEvId_maybe, mkTcEqPredLikeEv, - mkNonCanonical, mkNonCanonicalCt, mkGivens, - mkIrredCt, - ctEvPred, ctEvLoc, ctEvOrigin, ctEvEqRel, - ctEvExpr, ctEvTerm, ctEvCoercion, ctEvEvId, - ctEvRewriters, - tyCoVarsOfCt, tyCoVarsOfCts, - tyCoVarsOfCtList, tyCoVarsOfCtsList, - - CtIrredReason(..), isInsolubleReason, - - CheckTyEqResult, CheckTyEqProblem, cteProblem, cterClearOccursCheck, - cteOK, cteImpredicative, cteTypeFamily, - cteInsolubleOccurs, cteSolubleOccurs, cterSetOccursCheckSoluble, - - cterHasNoProblem, cterHasProblem, cterHasOnlyProblem, - cterRemoveProblem, cterHasOccursCheck, cterFromKind, - - CanEqLHS(..), canEqLHS_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, insolubleEqCt, insolubleCt, - 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, - - -- CtEvidence - CtEvidence(..), TcEvDest(..), - mkKindLoc, toKindLoc, mkGivenLoc, - isWanted, isGiven, - ctEvRole, setCtEvPredType, setCtEvLoc, - tyCoVarsOfCtEvList, tyCoVarsOfCtEv, tyCoVarsOfCtEvsList, - ctEvUnique, tcEvDestUnique, - - RewriterSet(..), emptyRewriterSet, isEmptyRewriterSet, - -- exported concretely only for anyUnfilledCoercionHoles - rewriterSetFromType, rewriterSetFromTypes, rewriterSetFromCo, - addRewriterSet, - - wrapType, - - CtFlavour(..), ctEvFlavour, - CtFlavourRole, ctEvFlavourRole, ctFlavourRole, - eqCanRewrite, eqCanRewriteFR, - - -- Pretty printing - pprEvVarTheta, - pprEvVars, pprEvVarWithType, - - ) - where - -import GHC.Prelude - -import {-# SOURCE #-} GHC.Tc.Types ( TcLclEnv, setLclEnvTcLevel, getLclEnvTcLevel - , setLclEnvLoc, getLclEnvLoc ) - -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.Core - -import GHC.Core.TyCo.Ppr -import GHC.Utils.FV -import GHC.Types.Var.Set -import GHC.Driver.Session -import GHC.Types.Basic -import GHC.Types.Unique -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 Data.Monoid ( Endo(..) ) -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 * -* * -************************************************************************ - -Note [CEqCan 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. This is because - a CEqCan over a meta-variable is also used to inform unification, - in GHC.Tc.Solver.Interact.solveByUnification. If the LHS appears - anywhere, at all, in the RHS, 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.checkTypeEq -and forms condition T3 in Note [Extending the inert equalities] -in GHC.Tc.Solver.InertSet. - --} - --- | 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 - -data Ct - -- Atomic canonical constraints - = CDictCan { -- e.g. Num ty - cc_ev :: CtEvidence, -- See Note [Ct/evidence invariant] - - cc_class :: Class, - cc_tyargs :: [Xi], -- cc_tyargs are rewritten w.r.t. inerts, so Xi - - cc_pend_sc :: Bool - -- See Note [The superclass story] in GHC.Tc.Solver.Canonical - -- True <=> (a) cc_class has superclasses - -- (b) we have not (yet) added those - -- superclasses as Givens - } - - | CIrredCan { -- These stand for yet-unusable predicates - cc_ev :: CtEvidence, -- See Note [Ct/evidence invariant] - cc_reason :: CtIrredReason - - -- For the might-be-soluble case, the ctev_pred of the evidence is - -- of form (tv xi1 xi2 ... xin) with a tyvar at the head - -- or (lhs1 ~ ty2) where the CEqCan kind invariant (TyEq:K) fails - -- See Note [CIrredCan constraints] - - -- The definitely-insoluble case is for things like - -- Int ~ Bool tycons don't match - -- a ~ [a] occurs check - } - - | CEqCan { -- CanEqLHS ~ rhs - -- Invariants: - -- * See Note [inert_eqs: the inert equalities] in GHC.Tc.Solver.InertSet - -- * Many are checked in checkTypeEq in GHC.Tc.Utils.Unify - -- * (TyEq:OC) lhs does not occur in rhs (occurs check) - -- Note [CEqCan 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 Note [No top-level newtypes on RHS of representational equalities] - -- in GHC.Tc.Solver.Canonical. (Applies only when constructor of newtype is - -- in scope.) - -- * (TyEq:TV) If rhs (perhaps under a cast) is also CanEqLHS, then it is oriented - -- to give best chance of - -- unification happening; eg if rhs is touchable then lhs is too - -- Note [TyVar/TyVar orientation] in GHC.Tc.Utils.Unify - cc_ev :: CtEvidence, -- See Note [Ct/evidence invariant] - cc_lhs :: CanEqLHS, - cc_rhs :: Xi, -- See invariants above - - cc_eq_rel :: EqRel -- INVARIANT: cc_eq_rel = ctEvEqRel cc_ev - } - - | CNonCanonical { -- See Note [NonCanonical Semantics] in GHC.Tc.Solver.Monad - cc_ev :: CtEvidence - } - - | CQuantCan QCInst -- A quantified constraint - -- NB: I expect to make more of the cases in Ct - -- look like this, with the payload in an - -- auxiliary type - ------------- --- | 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 -- ^ of the family - [Xi] -- ^ 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) - ------------- -data QCInst -- A much simplified version of ClsInst - -- See Note [Quantified constraints] in GHC.Tc.Solver.Canonical - = 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 :: Bool -- Same as cc_pend_sc flag in CDictCan - -- Invariant: True => qci_pred is a ClassPred - } - -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 - -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)" - --- | 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 - ------------------------------------------------------------------------------- --- --- 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 :: 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 - -- must be one bit to the left of cteInsolubleOccurs --- See also Note [Insoluble occurs check] in GHC.Tc.Errors - -cteProblem :: CheckTyEqProblem -> CheckTyEqResult -cteProblem (CTEP mask) = CTER mask - -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 - -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 Outputable CheckTyEqResult where - ppr cter | cterHasNoProblem cter = text "cteOK" - | otherwise - = parens $ fcat $ intersperse vbar $ set_bits - where - all_bits = [ (cteImpredicative, "cteImpredicative") - , (cteTypeFamily, "cteTypeFamily") - , (cteInsolubleOccurs, "cteInsolubleOccurs") - , (cteSolubleOccurs, "cteSolubleOccurs") ] - set_bits = [ text str - | (bitmask, str) <- all_bits - , cter `cterHasProblem` bitmask ] - -{- 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 CDictCan, - ctev_pred (cc_ev ct) = (cc_class ct) (cc_tyargs ct) -This holds by construction; look at the unique place where CDictCan is -built (in GHC.Tc.Solver.Canonical). - -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 { cc_ev = ev } - -mkNonCanonicalCt :: Ct -> Ct -mkNonCanonicalCt ct = CNonCanonical { cc_ev = cc_ev ct } - -mkIrredCt :: CtIrredReason -> CtEvidence -> Ct -mkIrredCt reason ev = CIrredCan { cc_ev = ev, cc_reason = reason } - -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 ct = cc_ev ct - -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 { cc_pend_sc = psc } - | psc -> text "CDictCan(psc)" - | otherwise -> text "CDictCan" - CIrredCan { cc_reason = reason } -> text "CIrredCan" <> ppr reason - CQuantCan (QCI { qci_pend_sc = pend_sc }) - | pend_sc -> text "CQuantCan(psc)" - | otherwise -> text "CQuantCan" - ------------------------------------ --- | 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 - - | 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 Type -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 - -isUserTypeError :: PredType -> Bool -isUserTypeError pred = case getUserTypeErrorMsg pred of - Just _ -> True - _ -> False - -isPendingScDict :: Ct -> Bool -isPendingScDict (CDictCan { cc_pend_sc = psc }) = psc --- Says whether this is a CDictCan with cc_pend_sc is True; --- i.e. pending un-expanded superclasses -isPendingScDict _ = False - -pendingScDict_maybe :: Ct -> Maybe Ct --- Says whether this is a CDictCan with cc_pend_sc is True, --- AND if so flips the flag -pendingScDict_maybe ct@(CDictCan { cc_pend_sc = True }) - = Just (ct { cc_pend_sc = False }) -pendingScDict_maybe _ = Nothing - -pendingScInst_maybe :: QCInst -> Maybe QCInst --- Same as isPendingScDict, but for QCInsts -pendingScInst_maybe qci@(QCI { qci_pend_sc = True }) - = Just (qci { qci_pend_sc = False }) -pendingScInst_maybe _ = 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 { cc_class = cls }) = isIPClass cls - is_ip _ = False - -getPendingWantedScs :: Cts -> ([Ct], Cts) -getPendingWantedScs simples - = mapAccumBagL get [] simples - where - get acc ct | Just ct' <- pendingScDict_maybe ct - = (ct':acc, ct') - | otherwise - = (acc, ct) - -{- Note [When superclasses help] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -First read Note [The superclass story] in GHC.Tc.Solver.Canonical. - -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 - -andManyCts :: [Cts] -> Cts -andManyCts = unionManyBags - -emptyCts :: Cts -emptyCts = emptyBag - -isEmptyCts :: Cts -> Bool -isEmptyCts = isEmptyBag - -pprCts :: Cts -> SDoc -pprCts cts = vcat (map ppr (bagToList 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 Ct -> WantedConstraints -addInsols wc cts - = wc { wc_simple = wc_simple wc `unionBags` cts } - -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 (isConcrete rhs) - -> unitVarSet tv - | Just tv <- getTyVar_maybe rhs - , isConcreteTyVar tv - , not (isConcrete 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_ev ir_reason <- ct - -- CIrredCan: see (IW1) in Note [Insoluble Wanteds] - , CtWanted { ctev_loc = loc, ctev_rewriters = rewriters } <- ir_ev - -- It's a Wanted - , insolubleIrredCt ir_ev ir_reason - -- It's insoluble - , isEmptyRewriterSet rewriters - -- 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_ev ir_reason) = insolubleIrredCt ir_ev ir_reason -insolubleCt _ = False - -insolubleIrredCt :: CtEvidence -> CtIrredReason -> 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 ev reason - = isInsolubleReason reason - || isJust (userTypeError_maybe (ctEvPred ev)) - -{- -insolubleIrredCt (IrredCt { ir_ev = ev, ir_reason = reason }) - = isInsolubleReason reason - || isTopLevelUserTypeError (ctEvPred ev) - --- | 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) - - - --} - -insolubleEqCt :: Ct -> Bool --- Returns True of /equality/ constraints --- that are /definitely/ insoluble --- It won't detect some definite errors like --- F a ~ T (F a) --- where F is a type family, which actually has an occurs check --- --- The function is tuned for application /after/ constraint solving --- i.e. assuming canonicalisation has been done --- E.g. It'll reply True for a ~ [a] --- but False for [a] ~ a --- and --- True for Int ~ F a Int --- but False for Maybe Int ~ F a Int Int --- (where F is an arity-1 type function) -insolubleEqCt (CIrredCan { cc_reason = reason }) = isInsolubleReason reason -insolubleEqCt _ = False - --- | Returns True of equality constraints that are definitely insoluble, --- as well as TypeError constraints. --- Can return 'True' for Given constraints, unlike 'insolubleWantedCt'. --- --- 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)@. - - -- Don't use 'isUserTypeErrorCt' here, as that function is 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. - -- - -- 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 oare put into - CIrredCan - -(IW2) We only treat it as insoluble if it has an empty rewriter set. - 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 becuase of its empty rewriter set; and suppress reporting A because - there is an insoluble B lying around. (This suppression happens in - GHC.Tc.Errors.) 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 <=> -Winaccessible-code is enabled - -- at construction. See - -- Note [Avoid -Winaccessible-code when deriving] - -- in GHC.Tc.TyCl.Instance - - ic_env :: TcLclEnv, - -- Records the TcLClEnv at the time of creation. - -- - -- The TcLclEnv gives the source location - -- and error context for the implication, and - -- hence for all the given evidence variables. - - 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 :: Implication -implicationPrototype - = Implic { -- These fields must be initialised - ic_tclvl = panic "newImplic:tclvl" - , ic_binds = panic "newImplic:binds" - , ic_info = panic "newImplic:info" - , ic_env = panic "newImplic:env" - , ic_warn_inaccessible = panic "newImplic:warn_inaccessible" - - -- 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 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 - -isEmptyRewriterSet :: RewriterSet -> Bool -isEmptyRewriterSet (RewriterSet set) = isEmptyUniqSet set - -addRewriterSet :: RewriterSet -> CoercionHole -> RewriterSet -addRewriterSet = coerce (addOneToUniqSet @CoercionHole) - --- | Makes a 'RewriterSet' from all the coercion holes that occur in the --- given coercion. -rewriterSetFromCo :: Coercion -> RewriterSet -rewriterSetFromCo co = appEndo (rewriter_set_from_co co) emptyRewriterSet - --- | Makes a 'RewriterSet' from all the coercion holes that occur in the --- given type. -rewriterSetFromType :: Type -> RewriterSet -rewriterSetFromType ty = appEndo (rewriter_set_from_ty ty) emptyRewriterSet - --- | Makes a 'RewriterSet' from all the coercion holes that occur in the --- given types. -rewriterSetFromTypes :: [Type] -> RewriterSet -rewriterSetFromTypes tys = appEndo (rewriter_set_from_tys tys) emptyRewriterSet - -rewriter_set_from_ty :: Type -> Endo RewriterSet -rewriter_set_from_tys :: [Type] -> Endo RewriterSet -rewriter_set_from_co :: Coercion -> Endo RewriterSet -(rewriter_set_from_ty, rewriter_set_from_tys, rewriter_set_from_co, _) - = foldTyCo folder () - where - folder :: TyCoFolder () (Endo RewriterSet) - folder = TyCoFolder - { tcf_view = noView - , tcf_tyvar = \ _ tv -> rewriter_set_from_ty (tyVarKind tv) - , tcf_covar = \ _ cv -> rewriter_set_from_ty (varType cv) - , tcf_hole = \ _ hole -> coerce (`addOneToUniqSet` hole) S.<> - rewriter_set_from_ty (varType (coHoleCoVar hole)) - , tcf_tycobinder = \ _ _ _ -> () } - -{- -************************************************************************ -* * - 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' -ctFlavourRole :: Ct -> CtFlavourRole --- Uses short-cuts to role for special cases -ctFlavourRole (CDictCan { cc_ev = ev }) - = (ctEvFlavour ev, NomEq) -ctFlavourRole (CEqCan { cc_ev = ev, cc_eq_rel = eq_rel }) - = (ctEvFlavour ev, eq_rel) -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. We choose to allow the rewriting, but -every Wanted tracks the set of Wanteds it has been rewritten by. This is -called a RewriterSet, stored in the ctev_rewriters field of the CtWanted -constructor of CtEvidence. (Only Wanteds have RewriterSets.) - -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 rewriteEvidence and -rewriteEqEvidence (in GHC.Tc.Solver.Canonical) add this RewriterSet to -the rewritten constraint's rewriter set. - -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.Utils.anyUnfilledCoercionHoles 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. - -Wrinkle: In #22707, we have a case 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! - -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 :: DynFlags -> SubGoalDepth -> Bool -subGoalDepthExceeded dflags (SubGoalDepth d) - = mkIntWithInf d > reductionDepth dflags - -{- -************************************************************************ -* * - 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 :: TcLclEnv - , ctl_t_or_k :: Maybe TypeOrKind -- OK if we're not sure - , ctl_depth :: !SubGoalDepth } - - -- The TcLclEnv includes particularly - -- source location: tcl_loc :: RealSrcSpan - -- context: tcl_ctxt :: [ErrCtxt] - -- binder stack: tcl_bndrs :: TcBinderStack - -- level: tcl_tclvl :: TcLevel - -mkKindLoc :: TcType -> TcType -- original *types* being compared - -> CtLoc -> CtLoc -mkKindLoc s1 s2 loc = setCtLocOrigin (toKindLoc loc) - (KindEqOrigin s1 s2 (ctLocOrigin loc) - (ctLocTypeOrKind_maybe loc)) - --- | Take a CtLoc and moves it to the kind level -toKindLoc :: CtLoc -> CtLoc -toKindLoc loc = loc { ctl_t_or_k = Just KindLevel } - -mkGivenLoc :: TcLevel -> SkolemInfoAnon -> TcLclEnv -> CtLoc -mkGivenLoc tclvl skol_info env - = CtLoc { ctl_origin = GivenOrigin skol_info - , ctl_env = setLclEnvTcLevel env tclvl - , ctl_t_or_k = Nothing -- this only matters for error msgs - , ctl_depth = initialSubGoalDepth } - -ctLocEnv :: CtLoc -> TcLclEnv -ctLocEnv = ctl_env - -ctLocLevel :: CtLoc -> TcLevel -ctLocLevel loc = getLclEnvTcLevel (ctLocEnv loc) - -ctLocDepth :: CtLoc -> SubGoalDepth -ctLocDepth = ctl_depth - -ctLocOrigin :: CtLoc -> CtOrigin -ctLocOrigin = ctl_origin - -ctLocSpan :: CtLoc -> RealSrcSpan -ctLocSpan (CtLoc { ctl_env = lcl}) = getLclEnvLoc 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 (setLclEnvLoc 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 -> TcLclEnv -> 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 (getLclEnvLoc 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/ErrCtxt.hs b/GHC/Tc/Types/ErrCtxt.hs new file mode 100644 --- /dev/null +++ b/GHC/Tc/Types/ErrCtxt.hs @@ -0,0 +1,223 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE UndecidableInstances #-} + +module GHC.Tc.Types.ErrCtxt + ( ErrCtxt, ErrCtxtMsg(..) + , UserSigType(..), FunAppCtxtFunArg(..) + , TyConInstFlavour(..) + ) + where + +import GHC.Prelude +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, 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.Session - -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,22 +15,26 @@ -- * Evidence bindings TcEvBinds(..), EvBindsVar(..), - EvBindMap(..), emptyEvBindMap, extendEvBinds, + EvBindMap(..), emptyEvBindMap, extendEvBinds, unionEvBindMap, lookupEvBind, evBindMapBinds, foldEvBindMap, nonDetStrictFoldEvBindMap, filterEvBindMap, isEmptyEvBindMap, evBindMapToVarSet, varSetMinusEvBindMap, - EvBind(..), emptyTcEvBinds, isEmptyTcEvBinds, mkGivenEvBind, mkWantedEvBind, + EvBindInfo(..), EvBind(..), emptyTcEvBinds, isEmptyTcEvBinds, mkGivenEvBind, mkWantedEvBind, evBindVar, isCoEvBindsVar, -- * 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,27 +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.Builtin.Names +import GHC.Builtin.Types( unitTy ) +import GHC.Utils.FV import GHC.Utils.Misc import GHC.Utils.Panic import GHC.Utils.Outputable @@ -109,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 @@ -170,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 @@ -196,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] @@ -229,7 +253,7 @@ mk_wp_fun_co :: Mult -> TcCoercionR -> TcCoercionR -> TcCoercionR mk_wp_fun_co mult arg_co res_co - = mkNakedFunCo1 Representational FTF_T_T (multToCo mult) arg_co res_co + = mkNakedFunCo Representational FTF_T_T (multToCo mult) arg_co res_co -- FTF_T_T: WpFun is always (->) mkWpCastR :: TcCoercionR -> HsWrapper @@ -257,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 @@ -300,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, @@ -345,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 } @@ -357,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] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -416,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 @@ -447,24 +492,29 @@ instance Outputable EvBindMap where ppr (EvBindMap m) = ppr m +data EvBindInfo + = EvBindGiven { -- See Note [Tracking redundant constraints] in GHC.Tc.Solver + } + | EvBindWanted { ebi_canonical :: CanonicalEvidence -- See Note [Desugaring non-canonical evidence] + } + ----------------- -- All evidence is bound by EvBinds; no side effects data EvBind - = EvBind { eb_lhs :: EvVar - , eb_rhs :: EvTerm - , eb_is_given :: Bool -- True <=> given - -- See Note [Tracking redundant constraints] in GHC.Tc.Solver + = EvBind { eb_lhs :: EvVar + , eb_rhs :: EvTerm + , eb_info :: EvBindInfo } evBindVar :: EvBind -> EvVar evBindVar = eb_lhs -mkWantedEvBind :: EvVar -> EvTerm -> EvBind -mkWantedEvBind ev tm = EvBind { eb_is_given = False, eb_lhs = ev, eb_rhs = tm } +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 mkGivenEvBind :: EvVar -> EvTerm -> EvBind -mkGivenEvBind ev tm = EvBind { eb_is_given = True, eb_lhs = ev, eb_rhs = tm } +mkGivenEvBind ev tm = EvBind { eb_info = EvBindGiven, eb_lhs = ev, eb_rhs = tm } -- An EvTerm is, conceptually, a CoreExpr that implements the constraint. @@ -479,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 @@ -499,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] @@ -568,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 @@ -638,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) @@ -650,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.Interact.interactDict. +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 @@ -664,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.Canonical.canClassNC - 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 @@ -737,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) @@ -765,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.Interact.interactDict). + (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] @@ -805,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 {- ********************************************************************* * * @@ -831,42 +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_is_given = is_given, eb_rhs = rhs } <- ev_bind - , is_given - = 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] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -874,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 "<>")) @@ -915,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 @@ -940,12 +1043,14 @@ getUnique = ebv_uniq instance Outputable EvBind where - ppr (EvBind { eb_lhs = v, eb_rhs = e, eb_is_given = is_given }) + ppr (EvBind { eb_lhs = v, eb_rhs = e, eb_info = info }) = sep [ pp_gw <+> ppr v , nest 2 $ equals <+> ppr e ] + -- We cheat a bit and pretend EqVars are CoVars for the purposes of pretty printing where - pp_gw = brackets (if is_given then char 'G' else char 'W') - -- We cheat a bit and pretend EqVars are CoVars for the purposes of pretty printing + pp_gw = brackets $ case info of + EvBindGiven{} -> char 'G' + EvBindWanted{} -> char 'W' instance Outputable EvTerm where ppr (EvExpr e) = ppr e @@ -967,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 new file mode 100644 --- /dev/null +++ b/GHC/Tc/Types/LclEnv.hs @@ -0,0 +1,239 @@ +module GHC.Tc.Types.LclEnv ( + TcLclEnv(..) + , TcLclCtxt(..) + , modifyLclCtxt + + , getLclEnvArrowCtxt + , getLclEnvThBndrs + , getLclEnvTypeEnv + , getLclEnvBinderStack + , getLclEnvErrCtxt + , getLclEnvLoc + , getLclEnvRdrEnv + , getLclEnvTcLevel + , getLclEnvThLevel + , setLclEnvTcLevel + , setLclEnvLoc + , setLclEnvRdrEnv + , setLclEnvBinderStack + , setLclEnvErrCtxt + , setLclEnvThLevel + , setLclEnvTypeEnv + , modifyLclEnvTcLevel + + , lclEnvInGeneratedCode + + , addLclEnvErrCtxt + + , ArrowCtxt(..) + , ThBindEnv + , TcTypeEnv +) where + +import GHC.Prelude + +import GHC.Tc.Utils.TcType ( TcLevel ) +import GHC.Tc.Errors.Types ( TcRnMessage ) + +import GHC.Core.UsageEnv ( UsageEnv ) + +import GHC.Types.Name.Reader ( LocalRdrEnv ) +import GHC.Types.Name.Env ( NameEnv ) +import GHC.Types.SrcLoc ( RealSrcSpan ) +import GHC.Types.Basic ( TopLevelFlag ) + +import GHC.Types.Error ( Messages ) + +import GHC.Tc.Types.BasicTypes +import GHC.Tc.Types.TH +import GHC.Tc.Types.TcRef +import GHC.Tc.Types.ErrCtxt +import GHC.Tc.Types.Constraint ( WantedConstraints ) + +{- +************************************************************************ +* * + The local typechecker environment +* * +************************************************************************ + +Note [The Global-Env/Local-Env story] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +During type checking, we keep in the tcg_type_env + * All types and classes + * All Ids derived from types and classes (constructors, selectors) + +At the end of type checking, we zonk the local bindings, +and as we do so we add to the tcg_type_env + * Locally defined top-level Ids + +Why? Because they are now Ids not TcIds. This final GlobalEnv is + a) fed back (via the knot) to typechecking the + unfoldings of interface signatures + b) used in the ModDetails of this module +-} + +data TcLclEnv -- Changes as we move inside an expression + -- Discarded after typecheck/rename; not passed on to desugarer + = TcLclEnv { + -- The part that we sometimes restore using `restoreLclEnv`. + tcl_lcl_ctxt :: !TcLclCtxt, + + -- These are exactly the parts of TcLclEnv which are not set by `restoreLclEnv`. + + tcl_usage :: TcRef UsageEnv, -- Required multiplicity of bindings is accumulated here. + tcl_lie :: TcRef WantedConstraints, -- Place to accumulate type constraints + tcl_errs :: TcRef (Messages TcRnMessage) -- Place to accumulate diagnostics + } + +data TcLclCtxt + = TcLclCtxt { + tcl_loc :: RealSrcSpan, -- Source span + tcl_ctxt :: [ErrCtxt], -- Error context, innermost on top + 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 + + tcl_rdr :: LocalRdrEnv, -- Local name envt + -- Maintained during renaming, of course, but also during + -- type checking, solely so that when renaming a Template-Haskell + -- splice we have the right environment for the renamer. + -- + -- Does *not* include global name envt; may shadow it + -- Includes both ordinary variables and type variables; + -- they are kept distinct because tyvar have a different + -- occurrence constructor (Name.TvOcc) + -- We still need the unsullied global name env so that + -- we can look up record field names + + + 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) + -- We can't put this info in the TypeEnv because it's needed + -- (and extended) in the renamer, for untyped splices + + tcl_arrow_ctxt :: ArrowCtxt, -- Arrow-notation context + + tcl_env :: TcTypeEnv -- The local type environment: + -- Ids and TyVars defined in this module + } + +getLclEnvThLevel :: TcLclEnv -> ThLevel +getLclEnvThLevel = tcl_th_ctxt . tcl_lcl_ctxt + +setLclEnvThLevel :: ThLevel -> TcLclEnv -> TcLclEnv +setLclEnvThLevel l = modifyLclCtxt (\env -> env { tcl_th_ctxt = l }) + +getLclEnvThBndrs :: TcLclEnv -> ThBindEnv +getLclEnvThBndrs = tcl_th_bndrs . tcl_lcl_ctxt + +getLclEnvArrowCtxt :: TcLclEnv -> ArrowCtxt +getLclEnvArrowCtxt = tcl_arrow_ctxt . tcl_lcl_ctxt + +getLclEnvTypeEnv :: TcLclEnv -> TcTypeEnv +getLclEnvTypeEnv = tcl_env . tcl_lcl_ctxt + +setLclEnvTypeEnv :: TcTypeEnv -> TcLclEnv -> TcLclEnv +setLclEnvTypeEnv ty_env = modifyLclCtxt (\env -> env { tcl_env = ty_env}) + +setLclEnvTcLevel :: TcLevel -> TcLclEnv -> TcLclEnv +setLclEnvTcLevel lvl = modifyLclCtxt (\env -> env {tcl_tclvl = lvl }) + +modifyLclEnvTcLevel :: (TcLevel -> TcLevel) -> TcLclEnv -> TcLclEnv +modifyLclEnvTcLevel f = modifyLclCtxt (\env -> env { tcl_tclvl = f (tcl_tclvl env)}) + +getLclEnvTcLevel :: TcLclEnv -> TcLevel +getLclEnvTcLevel = tcl_tclvl . tcl_lcl_ctxt + +setLclEnvLoc :: RealSrcSpan -> TcLclEnv -> TcLclEnv +setLclEnvLoc loc = modifyLclCtxt (\lenv -> lenv { tcl_loc = loc }) + +getLclEnvLoc :: TcLclEnv -> RealSrcSpan +getLclEnvLoc = tcl_loc . tcl_lcl_ctxt + +getLclEnvErrCtxt :: TcLclEnv -> [ErrCtxt] +getLclEnvErrCtxt = tcl_ctxt . tcl_lcl_ctxt + +setLclEnvErrCtxt :: [ErrCtxt] -> TcLclEnv -> TcLclEnv +setLclEnvErrCtxt ctxt = modifyLclCtxt (\env -> env { tcl_ctxt = ctxt }) + +addLclEnvErrCtxt :: ErrCtxt -> TcLclEnv -> TcLclEnv +addLclEnvErrCtxt ctxt = modifyLclCtxt (\env -> env { tcl_ctxt = ctxt : (tcl_ctxt env) }) + +lclEnvInGeneratedCode :: TcLclEnv -> Bool +lclEnvInGeneratedCode = tcl_in_gen_code . tcl_lcl_ctxt + +getLclEnvBinderStack :: TcLclEnv -> TcBinderStack +getLclEnvBinderStack = tcl_bndrs . tcl_lcl_ctxt + +setLclEnvBinderStack :: TcBinderStack -> TcLclEnv -> TcLclEnv +setLclEnvBinderStack stack = modifyLclCtxt (\env -> env { tcl_bndrs = stack }) + +getLclEnvRdrEnv :: TcLclEnv -> LocalRdrEnv +getLclEnvRdrEnv = tcl_rdr . tcl_lcl_ctxt + +setLclEnvRdrEnv :: LocalRdrEnv -> TcLclEnv -> TcLclEnv +setLclEnvRdrEnv rdr_env = modifyLclCtxt (\env -> env { tcl_rdr = rdr_env }) + +modifyLclCtxt :: (TcLclCtxt -> TcLclCtxt) -> TcLclEnv -> TcLclEnv +modifyLclCtxt upd env = + let !res = upd (tcl_lcl_ctxt env) + in env { tcl_lcl_ctxt = res } + + + +type TcTypeEnv = NameEnv TcTyThing + +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 + -- cross-stage at arbitrary types if the Id is bound at top level. + -- + -- 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 +--------------------------- + +{- Note [Escaping the arrow scope] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In arrow notation, a variable bound by a proc (or enclosed let/kappa) +is not in scope to the left of an arrow tail (-<) or the head of (|..|). +For example + + proc x -> (e1 -< e2) + +Here, x is not in scope in e1, but it is in scope in e2. This can get +a bit complicated: + + let x = 3 in + proc y -> (proc z -> e1) -< e2 + +Here, x and z are in scope in e1, but y is not. + +We implement this by +recording the environment when passing a proc (using newArrowScope), +and returning to that (using escapeArrowScope) on the left of -< and the +head of (|..|). + +All this can be dealt with by the *renamer*. But the type checker needs +to be involved too. Example (arrowfail001) + class Foo a where foo :: a -> () + data Bar = forall a. Foo a => Bar a + get :: Bar -> () + get = proc x -> case x of Bar a -> foo -< a +Here the call of 'foo' gives rise to a (Foo a) constraint that should not +be captured by the pattern match on 'Bar'. Rather it should join the +constraints from further out. So we must capture the constraint bag +from further out in the ArrowCtxt that we push inwards. +-} + +data ArrowCtxt -- Note [Escaping the arrow scope] + = NoArrowCtxt + | ArrowCtxt LocalRdrEnv (TcRef WantedConstraints) diff --git a/GHC/Tc/Types/LclEnv.hs-boot b/GHC/Tc/Types/LclEnv.hs-boot new file mode 100644 --- /dev/null +++ b/GHC/Tc/Types/LclEnv.hs-boot @@ -0,0 +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,28 +16,41 @@ -- * 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, + -- * CallStack + isPushCallStackOrigin_maybe, + -- * FixedRuntimeRep origin - FixedRuntimeRepOrigin(..), FixedRuntimeRepContext(..), + FixedRuntimeRepOrigin(..), + FixedRuntimeRepContext(..), pprFixedRuntimeRepContext, - StmtOrigin(..), RepPolyFun(..), ArgPos(..), - ClsInstOrQC(..), NakedScFlag(..), + 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(..), SafeOverlapping ) where import GHC.Prelude @@ -46,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 @@ -64,11 +80,15 @@ import GHC.Utils.Panic import GHC.Stack import GHC.Utils.Monad +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 @@ -83,11 +103,22 @@ -- Also used for types in SPECIALISE pragmas Name -- Name of the function ReportRedundantConstraints - -- This is usually 'WantRCC', but 'NoRCC' for + -- See Note [Tracking redundant constraints] in GHC.Tc.Solver + -- This field is usually 'WantRCC', but 'NoRCC' for -- * Record selectors (not important here) -- * Class and instance methods. Here the code may legitimately -- be more polymorphic than the signature generated from the -- class declaration + -- * Functions whose type signature has hidden the constraints + -- behind a type synonym. E.g. + -- type Foo = forall a. Eq a => a -> a + -- id :: Foo + -- id x = x + -- Here we can't give a good location for the redundant constraints + -- (see lhsSigWcTypeContextSpan), so we don't report redundant + -- constraints at all. It's not clear that this a good choice; + -- perhaps we should report, just with a less informative SrcSpan. + -- c.f. #16154 | InfSigCtxt Name -- Inferred type for function | ExprSigCtxt -- Expression type signature @@ -102,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 @@ -126,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 @@ -134,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 @@ -163,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" @@ -186,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) @@ -255,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 @@ -267,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) @@ -278,7 +322,7 @@ | UnifyForAllSkol -- We are unifying two for-all types TcType -- The instantiated type *inside* the forall - | TyConSkol TyConFlavour Name -- bound in a type declaration of the given flavour + | TyConSkol (TyConFlavour TyCon) Name -- bound in a type declaration of the given flavour | DataConSkol Name -- bound as an existential in a Haskell98 datacon decl or -- as any variable in a GADT datacon decl @@ -297,10 +341,10 @@ -- -- We're hoping to be able to get rid of this entirely, but for the moment -- it's still needed. -unkSkol :: HasCallStack => SkolemInfo +unkSkol :: HasDebugCallStack => SkolemInfo unkSkol = SkolemInfo (mkUniqueGrimily 0) unkSkolAnon -unkSkolAnon :: HasCallStack => SkolemInfoAnon +unkSkolAnon :: HasDebugCallStack => SkolemInfoAnon unkSkolAnon = UnkSkol callStack -- | Wrap up the origin of a skolem type variable with a new 'Unique', @@ -314,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 @@ -333,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") @@ -410,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 * * @@ -433,6 +477,7 @@ = HsTypeRnThing (HsType GhcRn) | TypeThing Type | HsExprRnThing (HsExpr GhcRn) + | HsExprTcThing (HsExpr GhcTc) | NameThing Name -- | Some kind of type variable binder. @@ -446,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 @@ -467,7 +513,7 @@ ScDepth -- ^ The number of superclass selections necessary to -- get this constraint; see Note [Replacement vs keeping] - -- in GHC.Tc.Solver.Interact + -- in GHC.Tc.Solver.Dict Bool -- ^ True => "blocked": cannot use this to solve naked superclass Wanteds -- i.e. ones with (ScOrigin _ NakedSc) @@ -476,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 @@ -511,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 @@ -528,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 @@ -538,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 @@ -578,9 +620,8 @@ | IfThenElseOrigin -- An if-then-else expression | BracketOrigin -- An overloaded quotation bracket | StaticOrigin -- A static form - | Shouldn'tHappenOrigin String - -- the user should never see this one - | GhcBug20076 -- see #20076 + | ImpedanceMatching Id -- See Note [Impedance matching] in GHC.Tc.Gen.Bind + | Shouldn'tHappenOrigin String -- The user should never see this one -- | Testing whether the constraint associated with an instance declaration -- in a signature file is satisfied upon instantiation. @@ -590,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.Canonical | FRROrigin FixedRuntimeRepOrigin @@ -610,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 @@ -668,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 @@ -700,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 @@ -713,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 @@ -730,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 @@ -744,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 @@ -767,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))) @@ -806,22 +871,19 @@ , text "https://gitlab.haskell.org/ghc/ghc/wikis/report-a-bug >>" ] -pprCtOrigin GhcBug20076 - = vcat [ text "GHC Bug #20076 " - , text "Assuming you have a partial type signature, you can avoid this error" - , text "by either adding an extra-constraints wildcard (like `(..., _) => ...`," - , text "with the underscore at the end of the constraint), or by avoiding the" - , text "use of a simplifiable constraint in your partial type signature." ] - pprCtOrigin (ProvCtxtOrigin PSB{ psb_id = (L _ name) }) = hang (ctoHerald <+> text "the \"provided\" constraints claimed by") 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 [ ctoHerald <+> text "matching required constraints" + , text "in a binding group involving" <+> quotes (ppr x)] + pprCtOrigin (CycleBreakerOrigin orig) = pprCtOrigin orig @@ -845,80 +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 :: HasCallStack => 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 GhcBug20076 = text "GHC Bug #20076" -pprCtO (WantedSuperclassOrigin {}) = text "a superclass constraint" -pprCtO (InstanceSigOrigin {}) = text "a type signature in an instance" -pprCtO (AmbiguityCheckOrigin {}) = text "a type ambiguity check" +-- 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 @@ -927,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)) {- ************************************************************************ @@ -991,12 +1077,17 @@ = 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? } +instance Outputable FixedRuntimeRepOrigin where + ppr (FixedRuntimeRepOrigin { frr_type = ty, frr_context = cxt }) + = text "FrOrigin" <> braces (vcat [ text "frr_type:" <+> ppr ty + , text "frr_context:" <+> ppr cxt ]) + -- | The context in which a representation-polymorphism check was performed. -- -- Does not include the type on which the check was performed; see @@ -1017,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. @@ -1039,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. @@ -1088,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 @@ -1097,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' @@ -1112,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 @@ -1127,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 ] @@ -1166,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 @@ -1181,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 @@ -1207,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 * * ********************************************************************* -} @@ -1276,7 +1522,7 @@ ********************************************************************* -} -- | In what context are we calling 'matchExpectedFunTys' --- or 'matchActualFunTySigma'? +-- or 'matchActualFunTy'? -- -- Used for two things: -- @@ -1297,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. @@ -1315,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)) @@ -1336,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 @@ -1373,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" @@ -1392,12 +1628,50 @@ , 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" ] + +{- ******************************************************************* +* * + InstanceWhat +* * +**********************************************************************-} + +-- | Indicates if Instance met the Safe Haskell overlapping instances safety +-- check. +-- +-- See Note [Safe Haskell Overlapping Instances] in GHC.Tc.Solver +-- See Note [Safe Haskell Overlapping Instances Implementation] in GHC.Tc.Solver +type SafeOverlapping = Bool + +data InstanceWhat -- How did we solve this constraint? + = BuiltinEqInstance -- Built-in solver for (t1 ~ t2), (t1 ~~ t2), Coercible t1 t2 + -- See GHC.Tc.Solver.InertSet Note [Solved dictionaries] + + | BuiltinTypeableInstance TyCon -- Built-in solver for Typeable (T t1 .. tn) + -- 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) + + | LocalInstance -- Solved by a quantified constraint + -- See GHC.Tc.Solver.InertSet Note [Solved dictionaries] + + | TopLevInstance -- Solved by a top-level instance decl + { iw_dfun_id :: DFunId + , 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" + ppr BuiltinTypeableInstance {} = text "a built-in typeable instance" + ppr BuiltinEqInstance = text "a built-in equality instance" + ppr LocalInstance = text "a locally-quantified instance" + ppr (TopLevInstance { iw_dfun_id = dfun }) + = hang (text "instance" <+> pprSigmaType (idType dfun)) + 2 (text "--" <+> pprDefinedAt (idName dfun)) 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.Stack ( HasCallStack ) +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 :: HasCallStack => SkolemInfo +unkSkol :: HasDebugCallStack => SkolemInfo diff --git a/GHC/Tc/Types/TH.hs b/GHC/Tc/Types/TH.hs new file mode 100644 --- /dev/null +++ b/GHC/Tc/Types/TH.hs @@ -0,0 +1,130 @@ +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ViewPatterns #-} +module GHC.Tc.Types.TH ( + SpliceType(..) + , SpliceOrBracket(..) + , ThLevel(.., TypedBrack, UntypedBrack) + , PendingStuff(..) + , ThLevelIndex + , topLevel + , topAnnLevel + , topSpliceLevel + , thLevelIndex + , topLevelIndex + , spliceLevelIndex + , quoteLevelIndex + , thLevelIndexFromImportLevel + ) where + +import GHC.Prelude +import GHCi.RemoteTypes +import qualified GHC.Boot.TH.Syntax as TH +import GHC.Tc.Types.Evidence +import GHC.Utils.Outputable +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 +--------------------------- + +data SpliceType = Typed | Untyped +data SpliceOrBracket = IsSplice | IsBracket + +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: 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 + -- Haskell code for the splice. See Note [RunSplice ThLevel]. + -- + -- Contains a list of mod finalizers collected while executing the splice. + -- + -- 'addModFinalizer' inserts finalizers here, and from here they are taken + -- to construct an @HsSpliced@ annotation for untyped splices. See Note + -- [Delaying modFinalizers in untyped splices] in GHC.Rename.Splice. + -- + -- For typed splices, the typechecker takes finalizers from here and + -- inserts them in the list of finalizers in the global environment. + -- + -- See Note [Collecting modFinalizers in typed splices] in "GHC.Tc.Gen.Splice". + + | Comp -- Ordinary Haskell code + -- Binding level = 0 + + | Brack -- Inside brackets + ThLevel -- Enclosing level + PendingStuff + +data PendingStuff + = RnPending -- Renaming the inside of a bracket + (TcRef [PendingRnSplice]) -- Pending splices in here + + | RnPendingTyped -- Renaming the inside of a *typed* bracket + + | TcPending -- Typechecking the inside of a typed bracket + (TcRef [PendingTcSplice]) -- Accumulate pending splices here + (TcRef WantedConstraints) -- and type constraints here + QuoteWrapper -- A type variable and evidence variable + -- for the overall monad of + -- the bracket. Splices are checked + -- against this monad. The evidence + -- variable is used for desugaring + -- `lift`. + +isTypedPending :: PendingStuff -> Bool +isTypedPending (RnPending _) = False +isTypedPending (RnPendingTyped) = True +isTypedPending (TcPending _ _ _) = True + +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) + +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) + + +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' 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 +set 'RunSplice' when renaming or typechecking the splice, where 'Splice', +'Brack' or 'Comp' are used instead. + +-} + diff --git a/GHC/Tc/Types/TcRef.hs b/GHC/Tc/Types/TcRef.hs new file mode 100644 --- /dev/null +++ b/GHC/Tc/Types/TcRef.hs @@ -0,0 +1,37 @@ +module GHC.Tc.Types.TcRef (TcRef, newTcRef, readTcRef, writeTcRef, updTcRef, updTcRefM) where + +import GHC.Prelude + +import Control.Monad.IO.Class +import Data.IORef + +-- | Type alias for 'IORef'; the convention is we'll use this for mutable +-- bits of data in the typechecker which are updated during typechecking and +-- returned at the end. +type TcRef a = IORef a + +-- The following functions are all marked INLINE so that we +-- don't end up passing a Monad or MonadIO dictionary. + +newTcRef :: MonadIO m => a -> m (TcRef a) +newTcRef = \ a -> liftIO $ newIORef a +{-# INLINE newTcRef #-} + +readTcRef :: MonadIO m => TcRef a -> m a +readTcRef = \ ref -> liftIO $ readIORef ref +{-# INLINE readTcRef #-} + +writeTcRef :: MonadIO m => TcRef a -> a -> m () +writeTcRef = \ ref a -> liftIO $ writeIORef ref a +{-# INLINE writeTcRef #-} + +updTcRef :: MonadIO m => TcRef a -> (a -> a) -> m () +updTcRef = \ ref fn -> liftIO $ modifyIORef' ref fn +{-# INLINE updTcRef #-} + +updTcRefM :: MonadIO m => TcRef a -> (a -> m a) -> m () +updTcRefM ref upd + = do { contents <- readTcRef ref + ; !new_contents <- upd contents + ; writeTcRef ref new_contents } +{-# INLINE updTcRefM #-} 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 #-} @@ -20,7 +21,7 @@ import GHC.Driver.Env import GHC.Driver.Ppr -import GHC.Driver.Session +import GHC.Driver.DynFlags import GHC.Types.Basic (TypeOrKind(..)) import GHC.Types.Fixity (defaultFixity) @@ -47,14 +48,19 @@ import GHC.Unit.Module.Imported import GHC.Unit.Module.Deps +import GHC.Tc.Errors import GHC.Tc.Errors.Types +import {-# SOURCE #-} GHC.Tc.Module import GHC.Tc.Gen.Export 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 import GHC.Tc.Utils.Instantiate +import GHC.Tc.Utils.Unify import GHC.Tc.Utils.TcMType import GHC.Tc.Utils.TcType @@ -71,14 +77,10 @@ import GHC.Rename.Names import GHC.Rename.Fixity ( lookupFixityRn ) -import GHC.Tc.Utils.Env -import GHC.Tc.Errors -import GHC.Tc.Utils.Unify - import GHC.Utils.Error +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 @@ -86,36 +88,22 @@ import Control.Monad import Data.List (find) -import {-# SOURCE #-} GHC.Tc.Module - - -fixityMisMatch :: TyThing -> Fixity -> Fixity -> TcRnMessage -fixityMisMatch real_thing real_fixity sig_fixity = - mkTcRnUnknownMessage $ mkPlainError noHints $ - 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] - where - ppr_fix f = - ppr f <+> - (if f == defaultFixity - then parens (text "default") - else empty) +import GHC.Iface.Errors.Types +import Data.Function ((&)) checkHsigDeclM :: ModIface -> TyThing -> TyThing -> TcRn () checkHsigDeclM sig_iface sig_thing real_thing = do let name = getName real_thing -- TODO: Distinguish between signature merging and signature -- implementation cases. - checkBootDeclM False sig_thing real_thing + 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) $ addErrAt (nameSrcSpan name) - (fixityMisMatch real_thing real_fixity sig_fixity) + (TcRnHsigFixityMismatch real_thing real_fixity sig_fixity) -- | Given a 'ModDetails' of an instantiated signature (note that the -- 'ModDetails' must be knot-tied consistently with the actual implementation) @@ -127,7 +115,7 @@ -- a sufficient set of entities, since otherwise the renaming and then -- typechecking of the signature 'ModIface' would have failed. checkHsigIface :: TcGblEnv -> GlobalRdrEnv -> ModIface -> ModDetails -> TcRn () -checkHsigIface tcg_env gr sig_iface +checkHsigIface tcg_env gre_env sig_iface ModDetails { md_insts = sig_insts, md_fam_insts = sig_fam_insts, md_types = sig_type_env, md_exports = sig_exports } = do traceTc "checkHsigIface" $ vcat @@ -135,8 +123,8 @@ mapM_ check_export (map availName sig_exports) failIfErrsM -- See Note [Fail before checking instances in checkHsigIface] unless (null sig_fam_insts) $ - panic ("GHC.Tc.Module.checkHsigIface: Cannot handle family " ++ - "instances in hsig files yet...") + panic ("GHC.Tc.Utils.Backpack.checkHsigIface: " ++ + "Cannot handle family instances in hsig files yet...") -- Delete instances so we don't look them up when -- checking instance satisfiability -- TODO: this should not be necessary @@ -168,14 +156,14 @@ -- tcg_env (TODO: but maybe this isn't relevant anymore). r <- tcLookupImported_maybe name case r of - Failed err -> addErr (TcRnInterfaceLookupError name err) + Failed err -> addErr (TcRnInterfaceError err) Succeeded real_thing -> checkHsigDeclM sig_iface sig_thing real_thing -- The hsig did NOT define this function; that means it must -- be a reexport. In this case, make sure the 'Name' of the - -- reexport matches the 'Name exported here. - | [gre] <- lookupGlobalRdrEnv gr (nameOccName name) = do - let name' = greMangledName gre + -- reexport matches the 'Name' exported here. + | [gre] <- lookupGRE gre_env (LookupOccName (nameOccName name) SameNameSpace) = do + let name' = greName gre when (name /= name') $ do -- See Note [Error reporting bad reexport] -- TODO: Actually this error swizzle doesn't work @@ -188,11 +176,11 @@ -> getLocA e _ -> nameSrcSpan name addErrAt loc - (badReexportedBootThing False name name') + (TcRnBootMismatch Hsig $ BadReexportedBootThing name name') -- This should actually never happen, but whatever... | otherwise = addErrAt (nameSrcSpan name) - (missingBootThing False name "exported by") + (missingBootThing Hsig name MissingBootExport) -- Note [Fail before checking instances in checkHsigIface] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -223,24 +211,26 @@ -- TODO: This could be very well generalized to support instance -- declarations in boot files. tcg_env <- getGblEnv + lcl_env <- getLclEnv + -- NB: Have to tug on the interface, not necessarily -- tugged... but it didn't work? mapM_ tcLookupImported_maybe (nameSetElemsStable (orphNamesOfClsInst sig_inst)) -- Based off of 'simplifyDeriv' - let origin = InstProvidedOrigin (tcg_semantic_mod tcg_env) sig_inst (skol_info, tvs_skols, inst_theta, cls, inst_tys) <- tcSkolDFunType (idType dfun_id) (tclvl,cts) <- pushTcLevelM $ do + given_ids <- mapM newEvVar inst_theta + let given_loc = mkGivenLoc topTcLevel skol_info (mkCtLocEnv lcl_env) + givens = [ CtGiven $ + GivenCt { ctev_pred = idType given_id + -- Doesn't matter, make something up + , ctev_evar = given_id + , ctev_loc = given_loc } + | given_id <- given_ids ] + origin = InstProvidedOrigin (tcg_semantic_mod tcg_env) sig_inst wanted <- newWanted origin (Just TypeLevel) (mkClassPred cls inst_tys) - givens <- forM inst_theta $ \given -> do - loc <- getCtLocM origin (Just TypeLevel) - new_ev <- newEvVar given - return CtGiven { ctev_pred = given - -- Doesn't matter, make something up - , ctev_evar = new_ev - , ctev_loc = loc - } - return $ wanted : givens + return (wanted : givens) unsolved <- simplifyWantedsTcM cts (implic, _) <- buildImplicationFor tclvl skol_info tvs_skols [] unsolved @@ -278,7 +268,7 @@ reqs = requirementMerges unit_state modname holes <- forM reqs $ \(Module iuid mod_name) -> do initIfaceLoad hsc_env - . withException ctx + . withIfaceErr ctx $ moduleFreeHolesPrecise (text "findExtraSigImports") (mkModule (VirtUnit iuid) mod_name) return (uniqDSetToList (unionManyUniqDSets holes)) @@ -309,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 -> @@ -383,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 = ..., @@ -392,15 +382,14 @@ -- 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) - exported_occs = mkOccSet [ occName n + exported_occs = mkOccSet [ nameOccName n | a <- avails , n <- availNames a ] exported_decls = filter_decls exported_occs @@ -497,20 +486,11 @@ -- 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 -- all required signatures. -mergeSignatures :: HsParsedModule -> TcGblEnv -> ModIface -> TcRn TcGblEnv +mergeSignatures :: HasDebugCallStack => HsParsedModule -> TcGblEnv -> ModIface -> TcRn TcGblEnv mergeSignatures (HsParsedModule { hpm_module = L loc (HsModule { hsmodExports = mb_exports }), hpm_src_files = src_files }) @@ -537,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 @@ -547,7 +527,7 @@ let outer_mod = tcg_mod tcg_env let inner_mod = tcg_semantic_mod tcg_env - let mod_name = moduleName (tcg_mod tcg_env) + let mod_name = moduleName outer_mod let unit_state = hsc_units hsc_env let dflags = hsc_dflags hsc_env @@ -555,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 @@ -563,9 +543,8 @@ im = fst (getModuleInstantiation m) ctx = initSDocContext dflags defaultUserStyle fmap fst - . withException ctx - $ findAndReadIface hsc_env - (text "mergeSignatures") im m NotBoot + . withIfaceErr ctx + $ findAndReadIface hsc_env (text "mergeSignatures") im m NotBoot -- STEP 3: Get the unrenamed exports of all these interfaces, -- thin it according to the export list, and do shaping on them. @@ -650,12 +629,15 @@ -- because we need module -- LocalSig (from the local -- export list) to match it! - is_mod = mod_name, - 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 (Just ispec) as1) + rdr_env = mkGlobalRdrEnv $ gresFromAvails hsc_env (Just ispec) as1 setGblEnv tcg_env { tcg_rdr_env = rdr_env } $ exports_from_avail mb_exports rdr_env @@ -663,9 +645,9 @@ 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 think signatures from non signature packages + -- We can't thin signatures from non-signature packages _ -> return (ireq_iface, as1) -- 3(c). Only identifiers from signature packages are "ok" to -- import (that is, they are safe from a PVP perspective.) @@ -677,7 +659,7 @@ -- 3(d). Extend the name substitution (performing shaping) mb_r <- extend_ns nsubst as2 case mb_r of - Left err -> failWithTc (mkTcRnUnknownMessage $ mkPlainError noHints err) + Left err -> failWithTc (TcRnHsigShapeMismatch err) Right nsubst' -> return (nsubst',oks',(imod, thinned_iface):ifaces) nsubst0 = mkNameShape (moduleName inner_mod) (mi_exports lcl_iface0) ok_to_use0 = mkOccSet (exportOccs (mi_exports lcl_iface0)) @@ -688,9 +670,9 @@ <- foldM gen_subst (nsubst0, ok_to_use0, []) (zip reqs ireq_ifaces0) let thinned_ifaces = reverse rev_thinned_ifaces exports = nameShapeExports nsubst - rdr_env = mkGlobalRdrEnv (gresFromAvails Nothing exports) + rdr_env = mkGlobalRdrEnv (gresFromAvails hsc_env Nothing exports) _warn_occs = filter (not . (`elemOccSet` ok_to_use)) (exportOccs exports) - warns = NoWarnings + warns = emptyWarn {- -- TODO: Warnings are transitive, but this is not what we want here: -- if a module reexports an entity from a signature, that should be OK. @@ -713,15 +695,16 @@ -- reexports are picked up correctly tcg_imports = tcg_imports orig_tcg_env, tcg_exports = exports, - tcg_dus = usesOnly (availsToNameSetWithSelectors exports), + tcg_dus = usesOnly (availsToNameSet exports), tcg_warns = warns } $ do tcg_env <- getGblEnv -- 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 @@ -741,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 @@ -753,9 +736,9 @@ let ifaces = lcl_iface : ext_ifaces -- STEP 4.1: Merge fixities (we'll verify shortly) tcg_fix_env - let fix_env = mkNameEnv [ (greMangledName rdr_elt, FixItem occ f) + let fix_env = mkNameEnv [ (greName rdr_elt, FixItem occ f) | (occ, f) <- concatMap mi_fixities ifaces - , rdr_elt <- lookupGlobalRdrEnv rdr_env occ ] + , rdr_elt <- lookupGRE rdr_env (LookupOccName occ AllRelevantGREs) ] -- STEP 5: Typecheck the interfaces let type_env_var = tcg_type_env_var tcg_env @@ -870,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] @@ -890,11 +873,11 @@ n <- newDFunName (is_cls inst) (is_tys inst) (nameSrcSpan (is_dfun_name inst)) let dfun = setVarName (is_dfun inst) n return (dfun, inst { is_dfun_name = n, is_dfun = dfun }) - tcg_env <- return tcg_env { - tcg_insts = map snd dfun_insts, - tcg_type_env = extendTypeEnvWithIds (tcg_type_env tcg_env) (map fst dfun_insts) - } + tcg_env <- return $ + tcg_env { tcg_insts = map snd dfun_insts + , tcg_type_env = extendTypeEnvWithIds (tcg_type_env tcg_env) (map fst dfun_insts) } + addDependentFiles src_files return tcg_env @@ -927,25 +910,18 @@ logger = hsc_logger hsc_env exportOccs :: [AvailInfo] -> [OccName] -exportOccs = concatMap (map occName . 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" <+> ppr impl_mod <+> - text "implements signature" <+> ppr req_mod_name <+> - text "in" <+> ppr req_uid +exportOccs = concatMap (map nameOccName . availNames) -- | Check if module implements a signature. (The signature is -- always un-hashed, which is why its components are specified -- explicitly.) -checkImplements :: Module -> InstantiatedModule -> TcRn TcGblEnv +checkImplements :: HasDebugCallStack => Module -> InstantiatedModule -> TcRn TcGblEnv checkImplements impl_mod req_mod@(Module uid mod_name) = do hsc_env <- getTopEnv 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 @@ -957,7 +933,7 @@ impl_iface <- initIfaceTcRn $ loadSysInterface (text "checkImplements 1") impl_mod let impl_gr = mkGlobalRdrEnv - (gresFromAvails Nothing (mi_exports impl_iface)) + (gresFromAvails hsc_env Nothing (mi_exports impl_iface)) nsubst = mkNameShape (moduleName impl_mod) (mi_exports impl_iface) -- Load all the orphans, so the subsequent 'checkHsigIface' sees @@ -967,9 +943,9 @@ let avails = calculateAvails home_unit other_home_units impl_iface False{- safe -} NotBoot ImportedBySystem - fix_env = mkNameEnv [ (greMangledName rdr_elt, FixItem occ f) + fix_env = mkNameEnv [ (greName rdr_elt, FixItem occ f) | (occ, f) <- mi_fixities impl_iface - , rdr_elt <- lookupGlobalRdrEnv impl_gr occ ] + , rdr_elt <- lookupGRE impl_gr (LookupOccName occ AllRelevantGREs) ] updGblEnv (\tcg_env -> tcg_env { -- Setting tcg_rdr_env to treat all exported entities from -- the implementing module as in scope improves error messages, @@ -996,18 +972,15 @@ isig_mod sig_mod NotBoot isig_iface <- case mb_isig_iface of Succeeded (iface, _) -> return iface - Failed err -> failWithTc $ mkTcRnUnknownMessage $ mkPlainError noHints $ - hang (text "Could not find hi interface for signature" <+> - quotes (ppr isig_mod) <> colon) 4 err + Failed err -> + failWithTc $ TcRnInterfaceError $ + Can'tFindInterface err (LookingForSig isig_mod) -- STEP 3: Check that the implementing interface exports everything -- we need. (Notice we IGNORE the Modules in the AvailInfos.) forM_ (exportOccs (mi_exports isig_iface)) $ \occ -> - case lookupGlobalRdrEnv impl_gr occ of - [] -> addErr $ mkTcRnUnknownMessage $ mkPlainError noHints $ - quotes (ppr occ) - <+> text "is exported by the hsig file, but not exported by the implementing module" - <+> quotes (pprWithUnitState unit_state $ ppr impl_mod) + case lookupGRE impl_gr (LookupOccName occ SameNameSpace) of + [] -> addErr $ TcRnHsigMissingModuleExport occ unit_state impl_mod _ -> return () failIfErrsM 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. -- @@ -9,43 +10,44 @@ hasFixedRuntimeRep , hasFixedRuntimeRep_syntactic - -- * Making a type concrete - , makeTypeConcrete + , 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 ( isConcrete, 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 ) -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.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.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] ~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -83,7 +85,7 @@ Note [The Concrete mechanism] Instead of simply checking that a type `ty` is concrete (i.e. computing - 'isConcrete`), we emit an equality constraint: + 'isConcreteType`), we emit an equality constraint: co :: ty ~# concrete_ty @@ -179,7 +181,7 @@ - a concrete type constructor (as defined below), or - a concrete type variable (see Note [ConcreteTv] below), or - an application of a concrete type to another concrete type -GHC.Core.Type.isConcrete checks whether a type meets this definition. +GHC.Core.Type.isConcreteType checks whether a type meets this definition. Definition: a /concrete type constructor/ is defined by - a promoted data constructor @@ -215,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: @@ -376,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@ @@ -398,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. -- @@ -441,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 @@ -449,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. @@ -466,219 +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) 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 { (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. --- --- 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`. +-- | Which type variables of this 'Id' must be concrete when instantiated? -- --- This would be useful in startSolvingByUnification. -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 - | isConcrete 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) - ; lift $ - do { conc_tv <- setTcLevel (tcTyVarLevel tv) $ - newConcreteTyVar conc_orig kind - ; let conc_ty = mkTyVarTy conc_tv - ; 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, @@ -22,10 +24,12 @@ tcLookupLocatedGlobal, tcLookupGlobal, tcLookupGlobalOnly, tcLookupTyCon, tcLookupClass, tcLookupDataCon, tcLookupPatSyn, tcLookupConLike, + tcLookupRecSelParent, tcLookupLocatedGlobalId, tcLookupLocatedTyCon, tcLookupLocatedClass, tcLookupAxiom, - lookupGlobal, lookupGlobal_maybe, ioLookupDataCon, + lookupGlobal, lookupGlobal_maybe, addTypecheckedBinds, + failIllegalTyCon, failIllegalTyVar, -- Local environment tcExtendKindEnv, tcExtendKindEnvList, @@ -34,7 +38,6 @@ tcExtendIdEnv, tcExtendIdEnv1, tcExtendIdEnv2, tcExtendBinderStack, tcExtendLocalTypeEnv, isTypeClosedLetBndr, - tcCheckUsage, tcLookup, tcLookupLocated, tcLookupLocalIds, tcLookupId, tcLookupIdMaybe, tcLookupTyVar, @@ -43,13 +46,10 @@ getInLocalScope, wrongThingErr, pprBinders, - tcAddDataFamConPlaceholders, tcAddPatSynPlaceholders, + tcAddDataFamConPlaceholders, tcAddPatSynPlaceholders, tcAddKindSigPlaceholders, getTypeSigNames, tcExtendRecEnv, -- For knot-tying - -- Tidying - tcInitTidyEnv, tcInitOpenTidyEnv, - -- Instances tcLookupInstance, tcGetInstEnvs, @@ -60,20 +60,23 @@ tcGetDefaultTys, -- Template Haskell stuff - 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.Session +import GHC.Driver.Env.KnotVars +import GHC.Driver.DynFlags import GHC.Builtin.Names import GHC.Builtin.Types @@ -87,24 +90,26 @@ import GHC.Tc.Errors.Types import GHC.Tc.Utils.Monad -import GHC.Tc.Utils.TcMType import GHC.Tc.Utils.TcType -import GHC.Tc.Types.Evidence (HsWrapper, idHsWrapper) -import {-# SOURCE #-} GHC.Tc.Utils.Unify ( tcSubMult ) -import GHC.Tc.Types.Origin ( CtOrigin(UsageEnvironmentOf) ) +import {-# SOURCE #-} GHC.Tc.Utils.TcMType ( tcCheckUsage ) +import GHC.Tc.Types.LclEnv -import GHC.Core.UsageEnv import GHC.Core.InstEnv -import GHC.Core.DataCon ( DataCon, flSelector ) +import GHC.Core.DataCon ( DataCon, dataConTyCon, flSelector ) 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 @@ -113,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(..) ) @@ -124,18 +128,24 @@ 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.Var -import GHC.Types.Var.Env +import GHC.Types.Id.Info ( RecSelParent(..) ) import GHC.Types.Name.Reader import GHC.Types.TyThing -import GHC.Types.Error +import GHC.Types.Unique.Set ( nonDetEltsUniqSet ) import qualified GHC.LanguageExtensions as LangExt -import Data.IORef -import Data.List (intercalate) +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 GHC.Driver.Env.KnotVars +import Data.IORef +import Data.List ( intercalate ) +import qualified Data.List.NonEmpty as NE {- ********************************************************************* * * @@ -151,10 +161,13 @@ mb_thing <- lookupGlobal_maybe hsc_env name ; case mb_thing of Succeeded thing -> return thing - Failed msg -> pprPanic "lookupGlobal" msg + Failed err -> + let msg = case err of + Left name -> text "Could not find local name:" <+> ppr name + Right err -> pprDiagnostic err + in pprPanic "lookupGlobal" msg } - -lookupGlobal_maybe :: HscEnv -> Name -> IO (MaybeErr SDoc TyThing) +lookupGlobal_maybe :: HscEnv -> Name -> IO (MaybeErr (Either Name IfaceMessage) TyThing) -- This may look up an Id that one has previously looked up. -- If so, we are going to read its interface file, and add its bindings -- to the ExternalPackageTable. @@ -165,24 +178,26 @@ tcg_semantic_mod = homeModuleInstantiation mhome_unit mod ; if nameIsLocalOrFrom tcg_semantic_mod name - then (return - (Failed (text "Can't find local name: " <+> ppr name))) - -- Internal names can happen in GHCi - else - -- Try home package table and external package table - lookupImported_maybe hsc_env name + then return $ Failed $ Left name + -- Internal names can happen in GHCi + else do + res <- lookupImported_maybe hsc_env name + -- Try home package table and external package table + return $ case res of + Succeeded ok -> Succeeded ok + Failed err -> Failed (Right err) } -lookupImported_maybe :: HscEnv -> Name -> IO (MaybeErr SDoc TyThing) +lookupImported_maybe :: HscEnv -> Name -> IO (MaybeErr IfaceMessage TyThing) -- Returns (Failed err) if we can't find the interface file for the thing lookupImported_maybe hsc_env name = do { mb_thing <- lookupType hsc_env name ; case mb_thing of Just thing -> return (Succeeded thing) Nothing -> importDecl_maybe hsc_env name - } + } -importDecl_maybe :: HscEnv -> Name -> IO (MaybeErr SDoc TyThing) +importDecl_maybe :: HscEnv -> Name -> IO (MaybeErr IfaceMessage TyThing) importDecl_maybe hsc_env name | Just thing <- wiredInNameTyThing_maybe name = do { when (needWiredInHomeIface thing) @@ -192,31 +207,14 @@ | otherwise = initIfaceLoad hsc_env (importDecl name) -ioLookupDataCon :: HscEnv -> Name -> IO DataCon -ioLookupDataCon hsc_env name = do - mb_thing <- ioLookupDataCon_maybe hsc_env name - case mb_thing of - Succeeded thing -> return thing - Failed msg -> pprPanic "lookupDataConIO" msg - -ioLookupDataCon_maybe :: HscEnv -> Name -> IO (MaybeErr SDoc DataCon) -ioLookupDataCon_maybe hsc_env name = do - thing <- lookupGlobal hsc_env name - return $ case thing of - AConLike (RealDataCon con) -> Succeeded con - _ -> Failed $ - pprTcTyThingCategory (AGlobal thing) <+> quotes (ppr name) <+> - text "used as a data constructor" - addTypecheckedBinds :: TcGblEnv -> [LHsBinds GhcTc] -> TcGblEnv addTypecheckedBinds tcg_env binds | 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 } - {- ************************************************************************ * * @@ -233,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 @@ -257,7 +255,7 @@ do { mb_thing <- tcLookupImported_maybe name ; case mb_thing of Succeeded thing -> return thing - Failed msg -> failWithTc (TcRnInterfaceLookupError name msg) + Failed msg -> failWithTc (TcRnInterfaceError msg) }}} -- Look up only in this module's global env't. Don't look in imports, etc. @@ -274,51 +272,63 @@ thing <- tcLookupGlobal name case thing of AConLike (RealDataCon con) -> return con - _ -> wrongThingErr "data constructor" (AGlobal thing) name + _ -> wrongThingErr WrongThingDataCon (AGlobal thing) name tcLookupPatSyn :: Name -> TcM PatSyn tcLookupPatSyn name = do thing <- tcLookupGlobal name case thing of AConLike (PatSynCon ps) -> return ps - _ -> wrongThingErr "pattern synonym" (AGlobal thing) name + _ -> 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 - _ -> wrongThingErr "constructor-like thing" (AGlobal thing) name + ATyCon {} -> failIllegalTyCon WL_ConLike qname + _ -> wrongThingErr WrongThingConLike (AGlobal thing) name +tcLookupRecSelParent :: HsRecUpdParent GhcRn -> TcM RecSelParent +tcLookupRecSelParent (RnRecUpdParent { rnRecUpdCons = cons }) + = case any_con of + PatSynName ps -> + RecSelPatSyn <$> tcLookupPatSyn ps + DataConName dc -> + RecSelData . dataConTyCon <$> tcLookupDataCon dc + where + any_con = head $ nonDetEltsUniqSet cons + -- Any constructor will give the same result here. + tcLookupClass :: Name -> TcM Class tcLookupClass name = do thing <- tcLookupGlobal name case thing of ATyCon tc | Just cls <- tyConClass_maybe tc -> return cls - _ -> wrongThingErr "class" (AGlobal thing) name + _ -> wrongThingErr WrongThingClass (AGlobal thing) name tcLookupTyCon :: Name -> TcM TyCon tcLookupTyCon name = do thing <- tcLookupGlobal name case thing of ATyCon tc -> return tc - _ -> wrongThingErr "type constructor" (AGlobal thing) name + _ -> wrongThingErr WrongThingTyCon (AGlobal thing) name tcLookupAxiom :: Name -> TcM (CoAxiom Branched) tcLookupAxiom name = do thing <- tcLookupGlobal name case thing of ACoAxiom ax -> return ax - _ -> wrongThingErr "axiom" (AGlobal thing) name + _ -> 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). @@ -326,20 +336,30 @@ tcLookupInstance :: Class -> [Type] -> TcM ClsInst tcLookupInstance cls tys = do { instEnv <- tcGetInstEnvs - ; case lookupUniqueInstEnv instEnv cls tys of - Left err -> - failWithTc $ mkTcRnUnknownMessage - $ mkPlainError noHints (text "Couldn't match instance:" <+> err) - Right (inst, tys) - | uniqueTyVars tys -> return inst - | otherwise -> failWithTc (mkTcRnUnknownMessage $ mkPlainError noHints errNotExact) + ; let inst = lookupUniqueInstEnv instEnv cls tys >>= \ (inst, tys) -> + if uniqueTyVars tys then Right inst else Left LookupInstErrNotExact + ; case inst of + Right i -> return i + Left err -> failWithTc (TcRnLookupInstance cls tys err) } where - errNotExact = text "Not an exact match (i.e., some variables get instantiated)" - 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) @@ -352,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 @@ -408,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 @@ -448,7 +559,7 @@ -} tcLookupLocated :: LocatedA Name -> TcM TcTyThing -tcLookupLocated = addLocMA tcLookup +tcLookupLocated = addLocM tcLookup tcLookupLcl_maybe :: Name -> TcM (Maybe TcTyThing) tcLookupLcl_maybe name @@ -460,7 +571,7 @@ local_env <- getLclTypeEnv case lookupNameEnv local_env name of Just thing -> return thing - Nothing -> (AGlobal <$> tcLookupGlobal name) + Nothing -> AGlobal <$> tcLookupGlobal name tcLookupTyVar :: Name -> TcM TcTyVar tcLookupTyVar name @@ -493,7 +604,7 @@ -- the same level as the lookup. Only used in one place... tcLookupLocalIds ns = do { env <- getLclEnv - ; return (map (lookup (tcl_env env)) ns) } + ; return (map (lookup (getLclEnvTypeEnv env)) ns) } where lookup lenv name = case lookupNameEnv lenv name of @@ -510,6 +621,7 @@ ATcTyCon tc -> return tc _ -> pprPanic "tcLookupTcTyCon" (ppr name) + getInLocalScope :: TcM (Name -> Bool) getInLocalScope = do { lcl_env <- getLclTypeEnv ; return (`elemNameEnv` lcl_env) } @@ -520,7 +632,7 @@ -- No need to update the global tyvars, or tcl_th_bndrs, or tcl_rdr tcExtendKindEnvList things thing_inside = do { traceTc "tcExtendKindEnvList" (ppr things) - ; updLclEnv upd_env thing_inside } + ; updLclCtxt upd_env thing_inside } where upd_env env = env { tcl_env = extendNameEnvList (tcl_env env) things } @@ -528,7 +640,7 @@ -- A variant of tcExtendKindEvnList tcExtendKindEnv extra_env thing_inside = do { traceTc "tcExtendKindEnv" (ppr extra_env) - ; updLclEnv upd_env thing_inside } + ; updLclCtxt upd_env thing_inside } where upd_env env = env { tcl_env = tcl_env env `plusNameEnv` extra_env } @@ -581,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 @@ -601,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 @@ -639,9 +755,9 @@ -- that are bound together with extra_env and should not be regarded -- as free in the types of extra_env. = do { traceTc "tc_extend_local_env" (ppr extra_env) - ; updLclEnv upd_lcl_env thing_inside } + ; updLclCtxt upd_lcl_env thing_inside } where - upd_lcl_env env0@(TcLclEnv { 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 }) @@ -651,74 +767,20 @@ -- (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 :: TcLclEnv -> [(Name, TcTyThing)] -> TcLclEnv -tcExtendLocalTypeEnv lcl_env@(TcLclEnv { tcl_env = lcl_type_env }) tc_ty_things +tcExtendLocalTypeEnv :: [(Name, TcTyThing)] -> TcLclCtxt -> TcLclCtxt +tcExtendLocalTypeEnv tc_ty_things lcl_env@(TcLclCtxt { tcl_env = lcl_type_env }) = lcl_env { tcl_env = extendNameEnvList lcl_type_env tc_ty_things } --- | @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) -tcCheckUsage name id_mult thing_inside - = do { (local_usage, result) <- tcCollectingUsage thing_inside - ; wrapper <- check_then_add_usage local_usage - ; return (result, wrapper) } - where - check_then_add_usage :: UsageEnv -> TcM HsWrapper - -- 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 - 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 } - - -- This is gross. The problem is in test case typecheck/should_compile/T18998: - -- f :: a %1-> Id n a -> Id n a - -- f x (MkId _) = MkId x - -- where MkId is a GADT constructor. Multiplicity polymorphism of constructors - -- invents a new multiplicity variable p[2] for the application MkId x. This - -- variable is at level 2, bumped because of the GADT pattern-match (MkId _). - -- We eventually unify the variable with One, due to the call to tcSubMult in - -- tcCheckUsage. But by then, we're at TcLevel 1, and so the level-check - -- fails. - -- - -- What to do? If we did inference "for real", the sub-multiplicity constraint - -- would end up in the implication of the GADT pattern-match, and all would - -- be well. But we don't have a real sub-multiplicity constraint to put in - -- the implication. (Multiplicity inference works outside the usual generate- - -- constraints-and-solve scheme.) Here, where the multiplicity arrives, we - -- must promote all multiplicity variables to reflect this outer TcLevel. - -- It's reminiscent of floating a constraint, really, so promotion is - -- appropriate. The promoteTcType function works only on types of kind TYPE rr, - -- so we can't use it here. Thus, this dirtiness. - -- - -- It works nicely in practice. - -- - -- We use a set to avoid calling promoteMetaTyVarTo twice on the same - -- metavariable. This happened in #19400. - promote_mult m = do { fvs <- zonkTyCoVarsAndFV (tyCoVarsOfType m) - ; any_promoted <- promoteTyVarSet fvs - ; if any_promoted then zonkTcType m else return m - } - {- ********************************************************************* * * The TcBinderStack @@ -728,42 +790,9 @@ tcExtendBinderStack :: [TcBinder] -> TcM a -> TcM a tcExtendBinderStack bndrs thing_inside = do { traceTc "tcExtendBinderStack" (ppr bndrs) - ; updLclEnv (\env -> env { tcl_bndrs = bndrs ++ tcl_bndrs env }) + ; updLclCtxt (\env -> env { tcl_bndrs = bndrs ++ tcl_bndrs env }) thing_inside } -tcInitTidyEnv :: TcM TidyEnv --- We initialise the "tidy-env", used for tidying types before printing, --- by building a reverse map from the in-scope type variables to the --- OccName that the programmer originally used for them -tcInitTidyEnv - = do { lcl_env <- getLclEnv - ; go emptyTidyEnv (tcl_bndrs lcl_env) } - where - go (env, subst) [] - = return (env, subst) - go (env, subst) (b : bs) - | TcTvBndr name tyvar <- b - = do { let (env', occ') = tidyOccName env (nameOccName name) - name' = tidyNameOcc name occ' - tyvar1 = setTyVarName tyvar name' - ; tyvar2 <- zonkTcTyVarToTcTyVar tyvar1 - -- Be sure to zonk here! Tidying applies to zonked - -- types, so if we don't zonk we may create an - -- ill-kinded type (#14175) - ; go (env', extendVarEnv subst tyvar tyvar2) bs } - | otherwise - = go (env, subst) bs - --- | Get a 'TidyEnv' that includes mappings for all vars free in the given --- type. Useful when tidying open types. -tcInitOpenTidyEnv :: [TyCoVar] -> TcM TidyEnv -tcInitOpenTidyEnv tvs - = do { env1 <- tcInitTidyEnv - ; let env2 = tidyFreeTyCoVars env1 tvs - ; return env2 } - - - {- ********************************************************************* * * Adding placeholders @@ -798,6 +827,12 @@ | PSB{ psb_id = L _ name } <- pat_syns ] thing_inside +tcAddKindSigPlaceholders :: LHsKind GhcRn -> TcM a -> TcM a +tcAddKindSigPlaceholders kind_sig thing_inside + = tcExtendKindEnvList [ (name, APromotionErr TypeVariablePE) + | name <- hsScopedKvs kind_sig ] + thing_inside + getTypeSigNames :: [LSig GhcRn] -> NameSet -- Get the names that have a user type sig getTypeSigNames sigs @@ -886,45 +921,6 @@ ************************************************************************ -} -checkWellStaged :: SDoc -- 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 - = stageRestrictionError pp_thing - - | otherwise -- Badly staged - = failWithTc $ -- E.g. \x -> $(f x) - mkTcRnUnknownMessage $ mkPlainError noHints $ - text "Stage error:" <+> pp_thing <+> - hsep [text "is bound at stage" <+> ppr bind_lvl, - text "but used at stage" <+> ppr use_lvl] - -stageRestrictionError :: SDoc -> TcM a -stageRestrictionError pp_thing - = failWithTc $ - mkTcRnUnknownMessage $ mkPlainError noHints $ - sep [ text "GHC stage restriction:" - , nest 2 (vcat [ pp_thing <+> text "is used in a top-level splice, quasi-quote, or annotation," - , text "and must be imported, not defined locally"])] - -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 @@ -933,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 {- ************************************************************************ @@ -945,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: @@ -1077,7 +1122,7 @@ = do { is_boot <- tcIsHsBootOrSig ; mod <- getModule ; let info_string = occNameString (getOccName clas) ++ - concatMap (occNameString.getDFunTyKey) tys + concatMap (occNameString . getDFunTyKey) tys ; dfun_occ <- chooseUniqueOccTc (mkDFunOcc info_string is_boot) ; newGlobalBinder mod dfun_occ loc } @@ -1168,30 +1213,32 @@ notFound :: Name -> TcM TyThing notFound name = do { lcl_env <- getLclEnv - ; let stage = tcl_th_ctxt 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 -> stageRestrictionError (quotes (ppr name)) - _ -> failWithTc $ - mkTcRnUnknownMessage $ mkPlainError noHints $ - vcat[text "GHC internal error:" <+> quotes (ppr name) <+> - text "is not in scope during type checking, but it passed the renamer", - text "tcl_env of environment:" <+> ppr (tcl_env 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 :: String -> TcTyThing -> Name -> TcM a -wrongThingErr expected thing name - = let msg = mkTcRnUnknownMessage $ mkPlainError noHints $ - (pprTcTyThingCategory thing <+> quotes (ppr name) <+> - text "used as a" <+> text expected) - in failWithTc msg +wrongThingErr :: WrongThingSort -> TcTyThing -> Name -> TcM a +wrongThingErr expected thing name = + failWithTc (TcRnTyThingUsedWrong expected thing name) {- Note [Out of scope might be a staging error] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ diff --git a/GHC/Tc/Utils/Env.hs-boot b/GHC/Tc/Utils/Env.hs-boot deleted file mode 100644 --- a/GHC/Tc/Utils/Env.hs-boot +++ /dev/null @@ -1,10 +0,0 @@ -module GHC.Tc.Utils.Env where - -import GHC.Tc.Types( TcM ) -import GHC.Types.Var.Env( TidyEnv ) - --- Annoyingly, there's a recursion between tcInitTidyEnv --- (which does zonking and hence needs GHC.Tc.Utils.TcMType) and --- addErrTc etc which live in GHC.Tc.Utils.Monad. Rats. -tcInitTidyEnv :: TcM TidyEnv - 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 @@ -1,5 +1,6 @@ {-# LANGUAGE FlexibleContexts, RecursiveDo #-} {-# LANGUAGE DisambiguateRecordFields #-} +{-# LANGUAGE LambdaCase #-} {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} @@ -10,7 +11,7 @@ -} module GHC.Tc.Utils.Instantiate ( - topSkolemise, + topSkolemise, skolemiseRequired, topInstantiate, instantiateSigma, instCall, instDFunType, instStupidTheta, instTyVarsWith, @@ -18,7 +19,7 @@ tcInstType, tcInstTypeBndrs, tcSkolemiseInvisibleBndrs, - tcInstSkolTyVars, tcInstSkolTyVarsX, + tcInstSkolTyVars, tcInstSkolTyVarsX, tcInstSkolTyVarBndrsX, tcSkolDFunType, tcSuperSkolTyVars, tcInstSuperSkolTyVarsX, freshenTyVarBndrs, freshenCoVarBndrsX, @@ -27,7 +28,7 @@ newOverloadedLit, mkOverLit, - newClsInst, + newClsInst, newFamInst, tcGetInsts, tcGetInstEnvs, getOverlapFlag, tcExtendLocalInstEnv, instCallConstraints, newMethodFromName, @@ -43,25 +44,22 @@ import GHC.Driver.Session import GHC.Driver.Env -import GHC.Builtin.Types ( heqDataCon, eqDataCon, integerTyConName ) +import GHC.Builtin.Types ( integerTyConName ) import GHC.Builtin.Names import GHC.Hs import GHC.Hs.Syn.Type ( hsLitType ) import GHC.Core.InstEnv -import GHC.Core.Predicate -import GHC.Core ( Expr(..), isOrphan ) -- For the Coercion constructor +import GHC.Core.FamInstEnv +import GHC.Core ( isOrphan ) -- For the Coercion constructor import GHC.Core.Type -import GHC.Core.Multiplicity -import GHC.Core.TyCo.Rep 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, unifyKind ) -import GHC.Tc.Utils.Zonk import GHC.Tc.Utils.Monad import GHC.Tc.Types.Constraint import GHC.Tc.Types.Origin @@ -72,27 +70,30 @@ import GHC.Tc.Utils.TcMType import GHC.Tc.Utils.TcType 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 @@ -102,7 +103,7 @@ {- ************************************************************************ * * - Creating and emittind constraints + Creating and emitting constraints * * ************************************************************************ -} @@ -132,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))) } {- ************************************************************************ @@ -144,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) @@ -166,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 @@ -180,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 } @@ -196,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 @@ -206,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 => ... @@ -216,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 @@ -234,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 @@ -305,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 @@ -374,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 @@ -387,71 +507,21 @@ go n subst kind | n > 0 - , Just (bndr, body) <- tcSplitPiTy_maybe kind - , isInvisiblePiTyBinder bndr - = do { (subst', arg) <- tcInstInvisibleTyBinder subst bndr + , Just (bndr, body) <- tcSplitForAllTyVarBinder_maybe kind + , isInvisibleForAllTyFlag (binderFlag bndr) + = do { (subst', arg) <- tcInstInvisibleTyBinder subst (binderVar bndr) ; (args, inner_ty) <- go (n-1) subst' body ; return (arg:args, inner_ty) } | otherwise = return ([], substTy subst kind) -tcInstInvisibleTyBinder :: Subst -> PiTyVarBinder -> TcM (Subst, TcType) +tcInstInvisibleTyBinder :: Subst -> TyVar -> TcM (Subst, TcType) -- Called only to instantiate kinds, in user-written type signatures -tcInstInvisibleTyBinder subst (Named (Bndr tv _)) +tcInstInvisibleTyBinder subst tv = do { (subst', tv') <- newMetaTyVarX subst tv ; return (subst', mkTyVarTy tv') } -tcInstInvisibleTyBinder subst (Anon ty af) - | Just (mk, k1, k2) <- get_eq_tys_maybe (substTy subst (scaledThing ty)) - -- For kinds like (k1 ~ k2) => blah, we want to emit a unification - -- constraint for (k1 ~# k2) and return the argument (Eq# k1 k2) - -- See Note [Constraints in kinds] in GHC.Core.TyCo.Rep - -- Equality is the *only* constraint currently handled in types. - = assert (isInvisibleFunArg af) $ - do { co <- unifyKind Nothing k1 k2 - ; return (subst, mk co) } - - | otherwise -- This should never happen - -- See GHC.Core.TyCo.Rep Note [Constraints in kinds] - = pprPanic "tcInvisibleTyBinder" (ppr ty) - -------------------------------- -get_eq_tys_maybe :: Type - -> Maybe ( Coercion -> Type - -- Given a coercion proving t1 ~# t2, produce the - -- right instantiation for the PiTyVarBinder at hand - , Type -- t1 - , Type -- t2 - ) --- See Note [Constraints in kinds] in GHC.Core.TyCo.Rep -get_eq_tys_maybe ty - -- Lifted heterogeneous equality (~~) - | Just (tc, [_, _, k1, k2]) <- splitTyConApp_maybe ty - , tc `hasKey` heqTyConKey - = Just (mkHEqBoxTy k1 k2, k1, k2) - - -- Lifted homogeneous equality (~) - | Just (tc, [_, k1, k2]) <- splitTyConApp_maybe ty - , tc `hasKey` eqTyConKey - = Just (mkEqBoxTy k1 k2, k1, k2) - - | otherwise - = Nothing - --- | This takes @a ~# b@ and returns @a ~~ b@. -mkHEqBoxTy :: Type -> Type -> TcCoercion -> Type -mkHEqBoxTy ty1 ty2 co - = mkTyConApp (promoteDataCon heqDataCon) [k1, k2, ty1, ty2, mkCoercionTy co] - where k1 = typeKind ty1 - k2 = typeKind ty2 - --- | This takes @a ~# b@ and returns @a ~ b@. -mkEqBoxTy :: Type -> Type -> TcCoercion -> Type -mkEqBoxTy ty1 ty2 co - = mkTyConApp (promoteDataCon eqDataCon) [k, ty1, ty2, mkCoercionTy co] - where k = typeKind ty1 - {- ********************************************************************* * * SkolemTvs (immutable) @@ -511,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) } @@ -522,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 @@ -545,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"; @@ -721,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 @@ -737,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) @@ -789,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) @@ -812,15 +891,10 @@ hasFixedRuntimeRepRes std_nm user_nm_expr sigma1 return (std_nm, unLoc expr) -syntaxNameCtxt :: HsExpr GhcRn -> CtOrigin -> Type -> SrcSpan -> TidyEnv - -> TcRn (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) {- ************************************************************************ @@ -860,35 +934,60 @@ {- ************************************************************************ * * - Instances + Class instances * * ************************************************************************ -} -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 - use x = OverlapFlag { isSafeOverlap = safeLanguageOn dflags - , overlapMode = x } - default_oflag | incoherent_ok = use (Incoherent NoSourceText) - | overlap_ok = use (Overlaps NoSourceText) - | otherwise = use (NoOverlap NoSourceText) + ; let overlap_ok = xopt LangExt.OverlappingInstances dflags + incoherent_ok = xopt LangExt.IncoherentInstances dflags + noncanonical_incoherence = not $ gopt Opt_SpecialiseIncoherents dflags - final_oflag = setOverlapModeMaybe default_oflag overlap_mode - ; return final_oflag } + overlap_mode + | Just m <- overlap_mode_prag = m + | incoherent_ok = Incoherent NoSourceText + | overlap_ok = Overlaps NoSourceText + | otherwise = NoOverlap NoSourceText + -- 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 + + ; 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 @@ -902,11 +1001,13 @@ -- helpful to use the same names ; oflag <- getOverlapFlag overlap_mode - ; let inst = mkLocalInstance dfun oflag tvs' clas tys' - ; when (isOrphan (is_orphan inst)) $ - addDiagnostic (TcRnOrphanInstance inst) - ; return inst } + ; let cls_inst = mkLocalClsInst dfun oflag tvs' clas tys' warn + ; when (isOrphan (is_orphan cls_inst)) $ + addDiagnostic (TcRnOrphanInstance $ Left cls_inst) + + ; return cls_inst } + tcExtendLocalInstEnv :: [ClsInst] -> TcM a -> TcM a -- Add new locally-defined instances tcExtendLocalInstEnv dfuns thing_inside @@ -968,9 +1069,9 @@ ; return (extendInstEnv home_ie' ispec, ispec : my_insts) } -{- -Note [Signature files and type class instances] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +{- Note [Signature files and type class instances] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Instances in signature files do not have an effect when compiling: when you compile a signature against an implementation, you will see the instances WHETHER OR NOT the instance is declared in @@ -1016,10 +1117,41 @@ ************************************************************************ * * - Errors and tracing + Family instances * * ************************************************************************ -} + +-- All type variables in a FamInst must be fresh. This function +-- creates the fresh variables and applies the necessary substitution +-- It is defined here to avoid a dependency from FamInstEnv on the monad +-- code. + +newFamInst :: FamFlavor -> CoAxiom Unbranched -> TcM FamInst +-- Freshen the type variables of the FamInst branches +newFamInst flavor axiom + | CoAxBranch { cab_tvs = tvs + , cab_cvs = cvs + , cab_lhs = lhs + , cab_rhs = rhs } <- coAxiomSingleBranch axiom + = do { -- Freshen the type variables + (subst, tvs') <- freshenTyVarBndrs tvs + ; (subst, cvs') <- freshenCoVarBndrsX subst cvs + ; let lhs' = substTys subst lhs + rhs' = substTy subst rhs + + ; let fam_inst = mkLocalFamInst flavor axiom tvs' cvs' lhs' rhs' + ; when (isOrphan (fi_orphan fam_inst)) $ + addDiagnostic (TcRnOrphanInstance $ Right fam_inst) + + ; return fam_inst } + + +{- ********************************************************************* +* * + Errors and tracing +* * +********************************************************************* -} traceDFuns :: [ClsInst] -> TcRn () traceDFuns ispecs 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,6 +1,3 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE ExplicitForAll #-} -{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE RecordWildCards #-} {-# OPTIONS_GHC -fno-warn-orphans #-} @@ -18,12 +15,13 @@ -- * Simple accessors discardResult, - getTopEnv, updTopEnv, getGblEnv, updGblEnv, - setGblEnv, getLclEnv, updLclEnv, setLclEnv, restoreLclEnv, + 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, @@ -41,7 +39,7 @@ newSysName, newSysLocalId, newSysLocalIds, -- * Accessing input/output - newTcRef, readTcRef, writeTcRef, updTcRef, + newTcRef, readTcRef, writeTcRef, updTcRef, updTcRefM, -- * Debugging traceTc, traceRn, traceOptTcRn, dumpOptTcRn, @@ -53,21 +51,22 @@ -- * Typechecker global environment getIsGHCi, getGHCiMonad, getInteractivePrintName, - tcIsHsBootOrSig, tcIsHsig, tcSelfBootInfo, getGlobalRdrEnv, + tcHscSource, tcIsHsBootOrSig, tcIsHsig, tcSelfBootInfo, getGlobalRdrEnv, getRdrEnvs, getImports, - getFixityEnv, extendFixityEnv, getRecFieldEnv, + getFixityEnv, extendFixityEnv, getDeclaredDefaultTys, addDependentFiles, -- * Error management - getSrcSpanM, setSrcSpan, setSrcSpanA, addLocM, addLocMA, inGeneratedCode, - wrapLocM, wrapLocAM, wrapLocFstM, wrapLocFstMA, wrapLocSndM, wrapLocSndMA, wrapLocM_, + getSrcSpanM, setSrcSpan, setSrcSpanA, addLocM, + inGeneratedCode, setInGeneratedCode, + wrapLocM, wrapLocFstM, wrapLocFstMA, wrapLocSndM, wrapLocSndMA, wrapLocM_, wrapLocMA_,wrapLocMA, getErrsVar, setErrsVar, addErr, failWith, failAt, addErrAt, addErrs, - checkErr, + checkErr, checkErrAt, addMessages, discardWarnings, mkDetailedMessage, @@ -77,21 +76,24 @@ -- * Shared error message stuff: renamer and typechecker recoverM, mapAndRecoverM, mapAndReportM, foldAndRecoverM, attemptM, tryTc, - askNoErrs, discardErrs, tryTcDiscardingErrs, + askNoErrs, discardErrs, + tryTcDiscardingErrs, + tryTcDiscardingErrs', checkNoErrs, whenNoErrs, ifErrsM, failIfErrsM, -- * Context management for the type checker getErrCtxt, setErrCtxt, addErrCtxt, addErrCtxtM, addLandmarkErrCtxt, - addLandmarkErrCtxtM, popErrCtxt, getCtLocM, setCtLocM, + addLandmarkErrCtxtM, popErrCtxt, getCtLocM, setCtLocM, mkCtLocEnv, -- * Diagnostic message generation (type checker) addErrTc, addErrTcM, failWithTc, failWithTcM, checkTc, checkTcM, + checkJustTc, checkJustTcM, failIfTc, failIfTcM, - mkErrInfo, + mkErrCtxt, addTcRnDiagnostic, addDetailedDiagnostic, mkTcRnMessage, reportDiagnostic, reportDiagnostics, warnIf, diagnosticTc, diagnosticTcM, @@ -99,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, emitInsoluble, + emitImplication, emitImplications, ensureReflMultiplicityCo, emitDelayedErrors, emitHole, emitHoles, emitNotConcreteError, discardConstraints, captureConstraints, tryCaptureConstraints, pushLevelAndCaptureConstraints, @@ -115,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 @@ -138,11 +140,17 @@ forkM, setImplicitEnvM, - withException, + withException, withIfaceErr, -- * Stuff for cost centres. getCCIndexM, getCCIndexTcM, + -- * Zonking + liftZonkM, newZonkAnyType, + + -- * Complete matches + localAndImportedCompleteMatches, getCompleteMatchesTcM, + -- * Types etc. module GHC.Tc.Types, module GHC.Data.IOEnv @@ -152,12 +160,19 @@ 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 import GHC.Hs hiding (LIE) @@ -165,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 @@ -189,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 @@ -215,14 +239,10 @@ import Data.IORef import Control.Monad -import GHC.Tc.Errors.Types -import {-# SOURCE #-} GHC.Tc.Utils.Env ( tcInitTidyEnv ) - import qualified Data.Map as Map -import GHC.Driver.Env.KnotVars -import GHC.Linker.Types -import GHC.Types.Unique.DFM +import GHC.Core.Coercion (isReflCo) + {- ************************************************************************ * * @@ -246,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 [] ; @@ -300,21 +320,19 @@ tcg_src = hsc_src, tcg_rdr_env = emptyGlobalRdrEnv, tcg_fix_env = emptyNameEnv, - tcg_field_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, @@ -332,7 +350,7 @@ tcg_sigs = emptyNameSet, tcg_ksigs = emptyNameSet, tcg_ev_binds = emptyBag, - tcg_warns = NoWarnings, + tcg_warns = emptyWarn, tcg_anns = [], tcg_tcs = [], tcg_insts = [], @@ -342,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, @@ -377,20 +395,22 @@ ; errs_var <- newIORef emptyMessages ; usage_var <- newIORef zeroUE ; let lcl_env = TcLclEnv { - tcl_errs = errs_var, + tcl_lcl_ctxt = TcLclCtxt { tcl_loc = loc, -- tcl_loc should be over-ridden very soon! 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, - tcl_usage = usage_var, tcl_bndrs = [], - tcl_lie = lie_var, tcl_tclvl = topTcLevel + }, + tcl_usage = usage_var, + tcl_lie = lie_var, + tcl_errs = errs_var } ; maybe_res <- initTcRnIf 'a' hsc_env gbl_env lcl_env $ @@ -427,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 @@ -477,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 } @@ -494,6 +501,8 @@ updLclEnv upd = updEnv (\ env@(Env { env_lcl = lcl }) -> env { env_lcl = upd lcl }) +updLclCtxt :: (TcLclCtxt -> TcLclCtxt) -> TcRnIf gbl TcLclEnv a -> TcRnIf gbl TcLclEnv a +updLclCtxt upd = updLclEnv (modifyLclCtxt upd) setLclEnv :: lcl' -> TcRnIf gbl lcl' a -> TcRnIf gbl lcl a setLclEnv lcl_env = updEnv (\ env -> env { env_lcl = lcl_env }) @@ -573,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) @@ -662,6 +674,16 @@ Failed err -> liftIO $ throwGhcExceptionIO (ProgramError (renderWithContext ctx err)) Succeeded result -> return result +withIfaceErr :: MonadIO m => SDocContext -> m (MaybeErr MissingInterfaceError a) -> m a +withIfaceErr ctx do_this = do + r <- do_this + case r of + Failed err -> do + let opts = defaultDiagnosticOpts @IfaceMessage + msg = missingInterfaceErrorDiagnostic opts err + liftIO $ throwGhcExceptionIO (ProgramError (renderWithContext ctx msg)) + Succeeded result -> return result + {- ************************************************************************ * * @@ -672,17 +694,18 @@ newArrowScope :: TcM a -> TcM a newArrowScope - = updLclEnv $ \env -> env { tcl_arrow_ctxt = ArrowCtxt (tcl_rdr env) (tcl_lie env) } + = updLclEnv $ \env -> + modifyLclCtxt (\ctx -> ctx { tcl_arrow_ctxt = ArrowCtxt (getLclEnvRdrEnv env) (tcl_lie env) } ) env -- Return to the stored environment (from the enclosing proc) escapeArrowScope :: TcM a -> TcM a escapeArrowScope = updLclEnv $ \ env -> - case tcl_arrow_ctxt env of + case getLclEnvArrowCtxt env of NoArrowCtxt -> env - ArrowCtxt rdr_env lie -> env { tcl_arrow_ctxt = NoArrowCtxt - , tcl_lie = lie - , tcl_rdr = rdr_env } + ArrowCtxt rdr_env lie -> env { tcl_lcl_ctxt = (tcl_lcl_ctxt env) { tcl_arrow_ctxt = NoArrowCtxt + , tcl_rdr = rdr_env } + , tcl_lie = lie } {- ************************************************************************ @@ -729,9 +752,9 @@ newSysLocalIds :: FastString -> [Scaled TcType] -> TcRnIf gbl lcl [TcId] newSysLocalIds fs tys - = do { us <- newUniqueSupply + = do { us <- getUniquesM ; let mkId' n (Scaled w t) = mkSysLocal fs n w t - ; return (zipWith mkId' (uniqsFromSupply us) tys) } + ; return (zipWith mkId' us tys) } instance MonadUnique (IOEnv (Env gbl lcl)) where getUniqueM = newUnique @@ -740,27 +763,6 @@ {- ************************************************************************ * * - Accessing input/output -* * -************************************************************************ --} - -newTcRef :: a -> TcRnIf gbl lcl (TcRef a) -newTcRef = newMutVar - -readTcRef :: TcRef a -> TcRnIf gbl lcl a -readTcRef = readMutVar - -writeTcRef :: TcRef a -> a -> TcRnIf gbl lcl () -writeTcRef = writeMutVar - -updTcRef :: TcRef a -> (a -> a) -> TcRnIf gbl lcl () --- Returns () -updTcRef ref fn = liftIO $ modifyIORef' ref fn - -{- -************************************************************************ -* * Debugging * * ************************************************************************ @@ -917,8 +919,11 @@ getInteractivePrintName = do { hsc <- getTopEnv; return (ic_int_print $ hsc_IC hsc) } tcIsHsBootOrSig :: TcRn Bool -tcIsHsBootOrSig = do { env <- getGblEnv; return (isHsBootOrSig (tcg_src env)) } +tcIsHsBootOrSig = isHsBootOrSig <$> tcHscSource +tcHscSource :: TcRn HscSource +tcHscSource = do { env <- getGblEnv; return (tcg_src env)} + tcIsHsig :: TcRn Bool tcIsHsig = do { env <- getGblEnv; return (isHsigFile (tcg_src env)) } @@ -929,7 +934,7 @@ getGlobalRdrEnv = do { env <- getGblEnv; return (tcg_rdr_env env) } getRdrEnvs :: TcRn (GlobalRdrEnv, LocalRdrEnv) -getRdrEnvs = do { (gbl,lcl) <- getEnvs; return (tcg_rdr_env gbl, tcl_rdr lcl) } +getRdrEnvs = do { (gbl,lcl) <- getEnvs; return (tcg_rdr_env gbl, getLclEnvRdrEnv lcl) } getImports :: TcRn ImportAvails getImports = do { env <- getGblEnv; return (tcg_imports env) } @@ -942,10 +947,7 @@ = updGblEnv (\env@(TcGblEnv { tcg_fix_env = old_fix_env }) -> env {tcg_fix_env = extendNameEnvList old_fix_env new_bit}) -getRecFieldEnv :: TcRn RecFieldEnv -getRecFieldEnv = do { env <- getGblEnv; return (tcg_field_env env) } - -getDeclaredDefaultTys :: TcRn (Maybe [Type]) +getDeclaredDefaultTys :: TcRn DefaultEnv getDeclaredDefaultTys = do { env <- getGblEnv; return (tcg_default env) } addDependentFiles :: [FilePath] -> TcRn () @@ -964,43 +966,47 @@ getSrcSpanM :: TcRn SrcSpan -- Avoid clash with Name.getSrcLoc -getSrcSpanM = do { env <- getLclEnv; return (RealSrcSpan (tcl_loc env) Strict.Nothing) } +getSrcSpanM = do { env <- getLclEnv; return (RealSrcSpan (getLclEnvLoc env) Strict.Nothing) } -- See Note [Error contexts in generated code] inGeneratedCode :: TcRn Bool -inGeneratedCode = tcl_in_gen_code <$> getLclEnv +inGeneratedCode = lclEnvInGeneratedCode <$> getLclEnv setSrcSpan :: SrcSpan -> TcRn a -> TcRn a -- See Note [Error contexts in generated code] -- for the tcl_in_gen_code manipulation setSrcSpan (RealSrcSpan loc _) thing_inside - = updLclEnv (\env -> env { tcl_loc = loc, tcl_in_gen_code = False }) + = updLclCtxt (\env -> env { tcl_loc = loc, tcl_in_gen_code = False }) thing_inside setSrcSpan loc@(UnhelpfulSpan _) thing_inside | isGeneratedSrcSpan loc - = updLclEnv (\env -> env { tcl_in_gen_code = True }) thing_inside + = setInGeneratedCode thing_inside | otherwise = thing_inside -setSrcSpanA :: SrcSpanAnn' 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 +-- | Mark the inner computation as being done inside generated code. +-- +-- See Note [Error contexts in generated code] +setInGeneratedCode :: TcRn a -> TcRn a +setInGeneratedCode thing_inside = + updLclCtxt (\env -> env { tcl_in_gen_code = True }) thing_inside -addLocMA :: (a -> TcM b) -> GenLocated (SrcSpanAnn' ann) a -> TcM b -addLocMA fn (L loc a) = setSrcSpanA loc $ fn a +setSrcSpanA :: EpAnn ann -> TcRn a -> TcRn a +setSrcSpanA l = setSrcSpan (locA l) -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) } @@ -1015,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 @@ -1032,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 @@ -1066,12 +1072,12 @@ -- tidying is not an issue, but it's all lazy so the extra -- work doesn't matter addErrAt loc msg = do { ctxt <- getErrCtxt - ; tidy_env <- tcInitTidyEnv - ; err_info <- mkErrInfo tidy_env ctxt - ; let detailed_msg = mkDetailedMessage (ErrInfo err_info Outputable.empty) msg + ; tidy_env <- liftZonkM $ tcInitTidyEnv + ; 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 @@ -1084,6 +1090,9 @@ -- Add the error if the bool is False checkErr ok msg = unless ok (addErr msg) +checkErrAt :: SrcSpan -> Bool -> TcRnMessage -> TcRn () +checkErrAt loc ok msg = unless ok (addErrAt loc msg) + addMessages :: Messages TcRnMessage -> TcRn () addMessages msgs1 = do { errs_var <- getErrsVar @@ -1201,32 +1210,34 @@ Note [Error contexts in generated code] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -* setSrcSpan sets tc_in_gen_code to True if the SrcSpan is GeneratedSrcSpan, +* setSrcSpan sets tcl_in_gen_code to True if the SrcSpan is GeneratedSrcSpan, and back to False when we get a useful SrcSpan -* When tc_in_gen_code is True, addErrCtxt becomes a no-op. +* When tcl_in_gen_code is True, addErrCtxt becomes a no-op. So typically it's better to do setSrcSpan /before/ addErrCtxt. -See Note [Rebindable syntax and HsExpansion] in GHC.Hs.Expr for -more discussion of this fancy footwork. +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. -} getErrCtxt :: TcM [ErrCtxt] -getErrCtxt = do { env <- getLclEnv; return (tcl_ctxt env) } +getErrCtxt = do { env <- getLclEnv; return (getLclEnvErrCtxt env) } setErrCtxt :: [ErrCtxt] -> TcM a -> TcM a {-# INLINE setErrCtxt #-} -- Note [Inlining addErrCtxt] -setErrCtxt ctxt = updLclEnv (\ env -> env { tcl_ctxt = ctxt }) +setErrCtxt ctxt = updLclEnv (setLclEnvErrCtxt ctxt) -- | 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 -> TcM (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) @@ -1234,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 -> TcM (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) @@ -1250,14 +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 -updCtxt ctxt env@(TcLclEnv { tcl_ctxt = ctxts, tcl_in_gen_code = in_gen }) - | in_gen = env - | otherwise = env { tcl_ctxt = ctxt : ctxts } +-- 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@(TcLclEnv { tcl_ctxt = ctxt }) -> - env { tcl_ctxt = pop ctxt }) +popErrCtxt thing_inside = updLclEnv (\env -> setLclEnvErrCtxt (pop $ getLclEnvErrCtxt env) env) $ + thing_inside where pop [] = [] pop (_:msgs) = msgs @@ -1266,18 +1277,27 @@ getCtLocM origin t_or_k = do { env <- getLclEnv ; return (CtLoc { ctl_origin = origin - , ctl_env = env + , ctl_env = mkCtLocEnv env , ctl_t_or_k = t_or_k , ctl_depth = initialSubGoalDepth }) } +mkCtLocEnv :: TcLclEnv -> CtLocEnv +mkCtLocEnv lcl_env = + CtLocEnv { ctl_bndrs = getLclEnvBinderStack lcl_env + , ctl_ctxt = getLclEnvErrCtxt lcl_env + , ctl_loc = getLclEnvLoc lcl_env + , ctl_tclvl = getLclEnvTcLevel lcl_env + , ctl_in_gen_code = lclEnvInGeneratedCode lcl_env + , ctl_rdr = getLclEnvRdrEnv lcl_env + } + setCtLocM :: CtLoc -> TcM a -> TcM a -- Set the SrcSpan and error context from the CtLoc setCtLocM (CtLoc { ctl_env = lcl }) thing_inside - = updLclEnv (\env -> env { tcl_loc = tcl_loc lcl - , tcl_bndrs = tcl_bndrs lcl - , tcl_ctxt = tcl_ctxt lcl }) - thing_inside - + = updLclEnv (\env -> setLclEnvLoc (ctl_loc lcl) + $ setLclEnvErrCtxt (ctl_ctxt lcl) + $ setLclEnvBinderStack (ctl_bndrs lcl) + $ env) thing_inside {- ********************************************************************* * * @@ -1315,7 +1335,7 @@ capture_messages :: TcM r -> TcM (r, Messages TcRnMessage) -- capture_messages simply captures and returns the --- errors arnd warnings generated by thing_inside +-- errors and warnings generated by thing_inside -- Precondition: thing_inside must not throw an exception! -- Reason for precondition: an exception would blow past the place -- where we read the msg_var, and we'd lose the constraints altogether @@ -1365,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 @@ -1406,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 } @@ -1505,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 } {- @@ -1534,8 +1572,19 @@ tidy up the message; we then use it to tidy the context messages -} +{- + +Note [Reporting warning diagnostics] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We use functions below to report warnings. For the most part, +we do /not/ need to check any warning flags before doing so. +See https://gitlab.haskell.org/ghc/ghc/-/wikis/Errors-as-(structured)-values +for the design. + +-} + addErrTc :: TcRnMessage -> TcM () -addErrTc err_msg = do { env0 <- tcInitTidyEnv +addErrTc err_msg = do { env0 <- liftZonkM tcInitTidyEnv ; addErrTcM (env0, err_msg) } addErrTcM :: (TidyEnv, TcRnMessage) -> TcM () @@ -1562,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 @@ -1579,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 @@ -1597,29 +1649,30 @@ -- | Display a diagnostic in the current context. addDiagnosticTc :: TcRnMessage -> TcM () addDiagnosticTc msg - = do { env0 <- tcInitTidyEnv ; - addDiagnosticTcM (env0, msg) } + = do { env0 <- liftZonkM tcInitTidyEnv + ; addDiagnosticTcM (env0, msg) } -- | Display a diagnostic in a given context. 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 <- tcInitTidyEnv + 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 @@ -1629,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 @@ -1647,7 +1700,6 @@ ; mkTcRnMessage loc (TcRnMessageWithInfo unit_state msg) >>= reportDiagnostic } - {- ----------------------------------- Other helper functions @@ -1657,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 @@ -1670,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) <- ctxt env + = 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 @@ -1708,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 @@ -1720,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 @@ -1731,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) @@ -1757,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 @@ -1776,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) } @@ -1816,12 +1917,6 @@ do { lie_var <- getConstraintVar ; updTcRef lie_var (`addImplics` ct) } -emitInsoluble :: Ct -> TcM () -emitInsoluble ct - = do { traceTc "emitInsoluble" (ppr ct) - ; lie_var <- getConstraintVar - ; updTcRef lie_var (`addInsols` unitBag ct) } - emitDelayedErrors :: Bag DelayedError -> TcM () emitDelayedErrors errs = do { traceTc "emitDelayedErrors" (ppr errs) @@ -1846,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 @@ -1856,29 +1960,29 @@ = do { tclvl <- getTcLevel ; let tclvl' = pushTcLevel tclvl ; traceTc "pushLevelAndCaptureConstraints {" (ppr tclvl') - ; (res, lie) <- updLclEnv (\env -> env { tcl_tclvl = tclvl' }) $ + ; (res, lie) <- updLclEnv (setLclEnvTcLevel tclvl') $ captureConstraints thing_inside ; traceTc "pushLevelAndCaptureConstraints }" (ppr tclvl') ; return (tclvl', lie, res) } pushTcLevelM_ :: TcM a -> TcM a -pushTcLevelM_ x = updLclEnv (\ env -> env { tcl_tclvl = pushTcLevel (tcl_tclvl env) }) x +pushTcLevelM_ = updLclEnv (modifyLclEnvTcLevel pushTcLevel) pushTcLevelM :: TcM a -> TcM (TcLevel, a) -- See Note [TcLevel assignment] in GHC.Tc.Utils.TcType pushTcLevelM thing_inside = do { tclvl <- getTcLevel ; let tclvl' = pushTcLevel tclvl - ; res <- updLclEnv (\env -> env { tcl_tclvl = tclvl' }) thing_inside + ; res <- updLclEnv (setLclEnvTcLevel tclvl') thing_inside ; return (tclvl', res) } getTcLevel :: TcM TcLevel getTcLevel = do { env <- getLclEnv - ; return (tcl_tclvl env) } + ; return $! getLclEnvTcLevel env } setTcLevel :: TcLevel -> TcM a -> TcM a setTcLevel tclvl thing_inside - = updLclEnv (\env -> env { tcl_tclvl = tclvl }) thing_inside + = updLclEnv (setLclEnvTcLevel tclvl) thing_inside isTouchableTcM :: TcTyVar -> TcM Bool isTouchableTcM tv @@ -1886,15 +1990,13 @@ ; return (isTouchableMetaTyVar lvl tv) } getLclTypeEnv :: TcM TcTypeEnv -getLclTypeEnv = do { env <- getLclEnv; return (tcl_env env) } +getLclTypeEnv = do { env <- getLclEnv; return (getLclEnvTypeEnv env) } setLclTypeEnv :: TcLclEnv -> TcM a -> TcM a -- Set the local type envt, but do *not* disturb other fields, -- notably the lie_var setLclTypeEnv lcl_env thing_inside - = updLclEnv upd thing_inside - where - upd env = env { tcl_env = tcl_env lcl_env } + = updLclEnv (setLclEnvTypeEnv (getLclEnvTypeEnv lcl_env)) thing_inside traceTcConstraints :: String -> TcM () traceTcConstraints msg @@ -1989,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 @@ -2023,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 @@ -2041,19 +2163,39 @@ ; traceRn "keep alive" (ppr name) ; updTcRef (tcg_keep env) (`extendNameSet` name) } -getStage :: TcM ThStage -getStage = do { env <- getLclEnv; return (tcl_th_ctxt 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 (tcl_th_bndrs env) name of - Nothing -> return Nothing - Just (top_lvl, bind_lvl) -> return (Just (top_lvl, bind_lvl, tcl_th_ctxt env)) } + ; case lookupNameEnv (getLclEnvThBndrs env) name of + 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 (\ env -> env { tcl_th_ctxt = 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 () @@ -2104,11 +2246,11 @@ -} getLocalRdrEnv :: RnM LocalRdrEnv -getLocalRdrEnv = do { env <- getLclEnv; return (tcl_rdr env) } +getLocalRdrEnv = do { env <- getLclEnv; return (getLclEnvRdrEnv env) } setLocalRdrEnv :: LocalRdrEnv -> RnM a -> RnM a setLocalRdrEnv rdr_env thing_inside - = updLclEnv (\env -> env {tcl_rdr = rdr_env}) thing_inside + = updLclEnv (setLclEnvRdrEnv rdr_env) thing_inside {- ************************************************************************ @@ -2281,3 +2423,39 @@ -- | See 'getCCIndexM'. getCCIndexTcM :: FastString -> TcM CostCentreIndex getCCIndexTcM = getCCIndexM tcg_cc_st + +-------------------------------------------------------------------------------- + +-- | Lift a computation from the dedicated zonking monad 'ZonkM' to the +-- full-fledged 'TcM' monad. +liftZonkM :: ZonkM a -> TcM a +liftZonkM (ZonkM f) = + do { logger <- getLogger + ; name_ppr_ctx <- getNamePprCtx + ; lvl <- getTcLevel + ; src_span <- getSrcSpanM + ; bndrs <- getLclEnvBinderStack <$> getLclEnv + ; let zge = ZonkGblEnv { zge_logger = logger + , zge_name_ppr_ctx = name_ppr_ctx + , zge_src_span = src_span + , zge_tc_level = lvl + , 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,2840 +1,2483 @@ -{-# LANGUAGE MultiWayIf #-} -{-# LANGUAGE RecursiveDo #-} -{-# LANGUAGE TupleSections #-} - -{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 - --} - --- | Monadic type operations --- --- This module contains monadic operations over types that contain mutable type --- variables. -module GHC.Tc.Utils.TcMType ( - TcTyVar, TcKind, TcType, TcTauType, TcThetaType, TcTyVarSet, - - -------------------------------- - -- Creating new mutable type variables - newFlexiTyVar, - newNamedFlexiTyVar, - newFlexiTyVarTy, -- Kind -> TcM TcType - newFlexiTyVarTys, -- Int -> Kind -> TcM [TcType] - newOpenFlexiTyVar, newOpenFlexiTyVarTy, newOpenTypeKind, - newOpenBoxedTypeKind, - newMetaKindVar, newMetaKindVars, newMetaTyVarTyAtLevel, - newAnonMetaTyVar, newConcreteTyVar, cloneMetaTyVar, - newCycleBreakerTyVar, - - newMultiplicityVar, - readMetaTyVar, writeMetaTyVar, writeMetaTyVarRef, - newTauTvDetailsAtLevel, newMetaDetails, newMetaTyVarName, - isFilledMetaTyVar_maybe, isFilledMetaTyVar, isUnfilledMetaTyVar, - - -------------------------------- - -- Creating new evidence variables - newEvVar, newEvVars, newDict, - newWantedWithLoc, newWanted, newWanteds, cloneWanted, cloneWC, cloneWantedCtEv, - emitWanted, emitWantedEq, emitWantedEvVar, emitWantedEvVars, - emitWantedEqs, - newTcEvBinds, newNoTcEvBinds, addTcEvBind, - emitNewExprHole, - - newCoercionHole, fillCoercionHole, isFilledCoercionHole, - unpackCoercionHole, unpackCoercionHole_maybe, - checkCoercionHole, - - ConcreteHole, newConcreteHole, - - newImplication, - - -------------------------------- - -- Instantiation - newMetaTyVars, newMetaTyVarX, newMetaTyVarsX, - newMetaTyVarTyVarX, - newTyVarTyVar, cloneTyVarTyVar, - newPatSigTyVar, newSkolemTyVar, newWildCardX, - - -------------------------------- - -- Expected types - ExpType(..), ExpSigmaType, ExpRhoType, - mkCheckExpType, newInferExpType, newInferExpTypeFRR, - tcInfer, tcInferFRR, - readExpType, readExpType_maybe, readScaledExpType, - expTypeToType, scaledExpTypeToType, - checkingExpType_maybe, checkingExpType, - inferResultToType, ensureMonoType, promoteTcType, - - -------------------------------- - -- Zonking and tidying - zonkTidyTcType, zonkTidyTcTypes, zonkTidyOrigin, zonkTidyOrigins, - zonkTidyFRRInfos, - tidyEvVar, tidyCt, tidyHole, tidyDelayedError, - zonkTcTyVar, zonkTcTyVars, - zonkTcTyVarToTcTyVar, zonkTcTyVarsToTcTyVars, - zonkInvisTVBinder, - zonkTyCoVarsAndFV, zonkTcTypeAndFV, zonkDTyCoVarSetAndFV, - zonkTyCoVarsAndFVList, - - zonkTcType, zonkTcTypes, zonkCo, - zonkTyCoVarKind, - zonkEvVar, zonkWC, zonkImplication, zonkSimples, - zonkId, zonkCoVar, - zonkCt, zonkSkolemInfo, zonkSkolemInfoAnon, - - --------------------------------- - -- Promotion, defaulting, skolemisation - defaultTyVar, promoteMetaTyVarTo, promoteTyVarSet, - quantifyTyVars, isQuantifiableTv, - zonkAndSkolemise, skolemiseQuantifiedTyVar, - doNotQuantifyTyVars, - - candidateQTyVarsOfType, candidateQTyVarsOfKind, - candidateQTyVarsOfTypes, candidateQTyVarsOfKinds, - candidateQTyVarsWithBinders, - CandidatesQTvs(..), delCandidates, - candidateKindVars, partitionCandidates, - - ------------------------------ - -- Representation polymorphism - checkTypeHasFixedRuntimeRep, - - ------------------------------ - -- Other - anyUnfilledCoercionHoles - ) where - -import GHC.Prelude - -import GHC.Driver.Session -import qualified GHC.LanguageExtensions as LangExt - -import GHC.Tc.Types.Origin -import GHC.Tc.Types.Constraint -import GHC.Tc.Types.Evidence -import GHC.Tc.Utils.Monad -- TcType, amongst others -import GHC.Tc.Utils.TcType -import GHC.Tc.Errors.Types -import GHC.Tc.Errors.Ppr - -import GHC.Core.TyCo.Rep -import GHC.Core.TyCo.Ppr -import GHC.Core.Type -import GHC.Core.TyCon -import GHC.Core.Coercion -import GHC.Core.Class -import GHC.Core.Predicate -import GHC.Core.InstEnv (ClsInst(is_tys)) - -import GHC.Types.Var -import GHC.Types.Id as Id -import GHC.Types.Name -import GHC.Types.Var.Set - -import GHC.Builtin.Types -import GHC.Types.Error -import GHC.Types.Var.Env -import GHC.Types.Unique.Set -import GHC.Types.Basic ( TypeOrKind(..) - , NonStandardDefaultingStrategy(..) - , DefaultingStrategy(..), defaultNonStandardTyVars ) - -import GHC.Data.FastString -import GHC.Data.Bag -import GHC.Data.Pair - -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 -import GHC.Data.Maybe -import qualified Data.Semigroup as Semi -import GHC.Types.Name.Reader - -{- -************************************************************************ -* * - Kind variables -* * -************************************************************************ --} - -newMetaKindVar :: TcM TcKind -newMetaKindVar - = do { details <- newMetaDetails TauTv - ; name <- newMetaTyVarName (fsLit "k") - -- All MetaKindVars are called "k" - -- They may be jiggled by tidying - ; let kv = mkTcTyVar name liftedTypeKind details - ; traceTc "newMetaKindVar" (ppr kv) - ; return (mkTyVarTy kv) } - -newMetaKindVars :: Int -> TcM [TcKind] -newMetaKindVars n = replicateM n newMetaKindVar - -{- -************************************************************************ -* * - Evidence variables; range over constraints we can abstract over -* * -************************************************************************ --} - -newEvVars :: TcThetaType -> TcM [EvVar] -newEvVars theta = mapM newEvVar theta - --------------- - -newEvVar :: TcPredType -> TcRnIf gbl lcl EvVar --- Creates new *rigid* variables for predicates -newEvVar ty = do { name <- newSysName (predTypeOccName ty) - ; return (mkLocalIdOrCoVar name ManyTy ty) } - --- | Create a new Wanted constraint with the given 'CtLoc'. -newWantedWithLoc :: CtLoc -> PredType -> TcM CtEvidence -newWantedWithLoc loc pty - = do dst <- case classifyPredType pty of - EqPred {} -> HoleDest <$> newCoercionHole pty - _ -> EvVarDest <$> newEvVar pty - return $ CtWanted { 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. -newWanted :: CtOrigin -> Maybe TypeOrKind -> PredType -> TcM CtEvidence --- Deals with both equality and non-equality predicates -newWanted orig t_or_k pty - = do loc <- getCtLocM orig t_or_k - newWantedWithLoc loc pty - --- | Create new Wanted constraints with the given 'CtOrigin', --- and location information taken from the 'TcM' environment. -newWanteds :: CtOrigin -> ThetaType -> TcM [CtEvidence] -newWanteds orig = mapM (newWanted orig Nothing) - ----------------------------------------------- --- Cloning constraints ----------------------------------------------- - -cloneWantedCtEv :: CtEvidence -> TcM CtEvidence -cloneWantedCtEv ctev@(CtWanted { ctev_pred = pty, ctev_dest = HoleDest _ }) - | isEqPrimPred pty - = do { co_hole <- newCoercionHole pty - ; return (ctev { ctev_dest = HoleDest co_hole }) } - | otherwise - = pprPanic "cloneWantedCtEv" (ppr pty) -cloneWantedCtEv ctev = return ctev - -cloneWanted :: Ct -> TcM Ct -cloneWanted ct = mkNonCanonical <$> cloneWantedCtEv (ctEvidence ct) - -cloneWC :: WantedConstraints -> TcM WantedConstraints --- Clone all the evidence bindings in --- a) the ic_bind field of any implications --- b) the CoercionHoles of any wanted constraints --- so that solving the WantedConstraints will not have any visible side --- effect, /except/ from causing unifications -cloneWC wc@(WC { wc_simple = simples, wc_impl = implics }) - = do { simples' <- mapBagM cloneWanted simples - ; implics' <- mapBagM cloneImplication implics - ; return (wc { wc_simple = simples', wc_impl = implics' }) } - -cloneImplication :: Implication -> TcM Implication -cloneImplication implic@(Implic { ic_binds = binds, ic_wanted = inner_wanted }) - = do { binds' <- cloneEvBindsVar binds - ; inner_wanted' <- cloneWC inner_wanted - ; return (implic { ic_binds = binds', ic_wanted = inner_wanted' }) } - ----------------------------------------------- --- Emitting constraints ----------------------------------------------- - --- | Emits a new Wanted. Deals with both equalities and non-equalities. -emitWanted :: CtOrigin -> TcPredType -> TcM EvTerm -emitWanted origin pty - = do { ev <- newWanted origin Nothing pty - ; emitSimple $ mkNonCanonical ev - ; return $ ctEvTerm ev } - -emitWantedEqs :: CtOrigin -> [(TcType,TcType)] -> TcM () --- Emit some new wanted nominal equalities -emitWantedEqs origin pairs - | null pairs - = return () - | otherwise - = mapM_ (uncurry (emitWantedEq origin TypeLevel Nominal)) pairs - --- | Emits a new equality constraint -emitWantedEq :: CtOrigin -> TypeOrKind -> Role -> TcType -> TcType -> TcM Coercion -emitWantedEq origin t_or_k role ty1 ty2 - = 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 = rewriterSetFromTypes [ty1, ty2] } - ; return (HoleCo hole) } - where - pty = mkPrimEqPredRole role ty1 ty2 - --- | Creates a new EvVar and immediately emits it as a Wanted. --- No equality predicates here. -emitWantedEvVar :: CtOrigin -> TcPredType -> TcM EvVar -emitWantedEvVar origin ty - = do { new_cv <- newEvVar ty - ; loc <- getCtLocM origin Nothing - ; let ctev = CtWanted { ctev_dest = EvVarDest new_cv - , ctev_pred = ty - , ctev_loc = loc - , ctev_rewriters = emptyRewriterSet } - ; emitSimple $ mkNonCanonical 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 -emitNewExprHole occ ty - = do { u <- newUnique - ; ref <- newTcRef (pprPanic "unfilled unbound-variable evidence" (ppr u)) - ; let her = HER ref ty u - - ; loc <- getCtLocM (ExprHoleOrigin (Just occ)) (Just TypeLevel) - - ; let hole = Hole { hole_sort = ExprHole her - , hole_occ = occ - , hole_ty = ty - , hole_loc = loc } - ; emitHole hole - ; return her } - -newDict :: Class -> [TcType] -> TcM DictId -newDict cls tys - = do { name <- newSysName (mkDictOcc (getOccName cls)) - ; return (mkLocalId name ManyTy (mkClassPred cls tys)) } - -predTypeOccName :: PredType -> OccName -predTypeOccName ty = case classifyPredType ty of - ClassPred cls _ -> mkDictOcc (getOccName cls) - EqPred {} -> mkVarOccFS (fsLit "co") - IrredPred {} -> mkVarOccFS (fsLit "irred") - ForAllPred {} -> mkVarOccFS (fsLit "df") - --- | Create a new 'Implication' with as many sensible defaults for its fields --- as possible. Note that the 'ic_tclvl', 'ic_binds', and 'ic_info' fields do --- /not/ have sensible defaults, so they are initialized with lazy thunks that --- will 'panic' if forced, so one should take care to initialize these fields --- after creation. --- --- This is monadic to look up the 'TcLclEnv', which is used to initialize --- 'ic_env', and to set the -Winaccessible-code flag. See --- Note [Avoid -Winaccessible-code when deriving] in "GHC.Tc.TyCl.Instance". -newImplication :: TcM Implication -newImplication - = do env <- getLclEnv - warn_inaccessible <- woptM Opt_WarnInaccessibleCode - return (implicationPrototype { ic_env = env - , ic_warn_inaccessible = warn_inaccessible }) - -{- -************************************************************************ -* * - Coercion holes -* * -************************************************************************ --} - -newCoercionHole :: TcPredType -> TcM CoercionHole -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 } } - --- | Put a value in a coercion hole -fillCoercionHole :: CoercionHole -> Coercion -> TcM () -fillCoercionHole (CoercionHole { ch_ref = ref, ch_co_var = cv }) co = do - when debugIsOn $ do - cts <- readTcRef ref - whenIsJust cts $ \old_co -> - pprPanic "Filling a filled coercion hole" (ppr cv $$ ppr co $$ ppr old_co) - traceTc "Filling coercion hole" (ppr cv <+> text ":=" <+> ppr co) - writeTcRef ref (Just co) - --- | Is a coercion hole filled in? -isFilledCoercionHole :: CoercionHole -> TcM Bool -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 - --- | 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 -> TcM Coercion -checkCoercionHole cv co - | debugIsOn - = do { cv_ty <- zonkTcType (varType cv) - -- co is already zonked, but cv might not be - ; return $ - assertPpr (ok cv_ty) - (text "Bad coercion hole" <+> - ppr cv <> colon <+> vcat [ ppr t1, ppr t2, ppr role - , ppr cv_ty ]) - co } - | otherwise - = return co - - where - (Pair t1 t2, role) = coercionKindRole co - ok cv_ty | EqPred cv_rel cv_t1 cv_t2 <- classifyPredType cv_ty - = t1 `eqType` cv_t1 - && t2 `eqType` cv_t2 - && role == eqRelRole cv_rel - | otherwise - = False - --- | A coercion hole used to store evidence for `Concrete#` constraints. --- --- See Note [The Concrete mechanism]. -type ConcreteHole = CoercionHole - --- | Create a new (initially unfilled) coercion hole, --- to hold evidence for a @'Concrete#' (ty :: ki)@ constraint. -newConcreteHole :: Kind -- ^ Kind of the thing we want to ensure is concrete (e.g. 'runtimeRepTy') - -> Type -- ^ Thing we want to ensure is concrete (e.g. some 'RuntimeRep') - -> TcM (ConcreteHole, TcType) - -- ^ where to put the evidence, and a metavariable to store - -- the concrete type -newConcreteHole ki ty - = do { concrete_ty <- newFlexiTyVarTy ki - ; let co_ty = mkHeteroPrimEqPred ki ki ty concrete_ty - ; hole <- newCoercionHole co_ty - ; return (hole, concrete_ty) } - -{- ********************************************************************** -* - ExpType functions -* -********************************************************************** -} - -{- Note [ExpType] -~~~~~~~~~~~~~~~~~ -An ExpType is used as the "expected type" when type-checking an expression. -An ExpType can hold a "hole" that can be filled in by the type-checker. -This allows us to have one tcExpr that works in both checking mode and -synthesis mode (that is, bidirectional type-checking). Previously, this -was achieved by using ordinary unification variables, but we don't need -or want that generality. (For example, #11397 was caused by doing the -wrong thing with unification variables.) Instead, we observe that these -holes should - -1. never be nested -2. never appear as the type of a variable -3. be used linearly (never be duplicated) - -By defining ExpType, separately from Type, we can achieve goals 1 and 2 -statically. - -See also [wiki:typechecking] - -Note [TcLevel of ExpType] -~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - - data G a where - MkG :: G Bool - - foo MkG = True - -This is a classic untouchable-variable / ambiguous GADT return type -scenario. But, with ExpTypes, we'll be inferring the type of the RHS. -We thus must track a TcLevel in an Inferring ExpType. If we try to -fill the ExpType and find that the TcLevels don't work out, we fill -the ExpType with a tau-tv at the low TcLevel, hopefully to be worked -out later by some means -- see fillInferResult, and Note [fillInferResult] - -This behaviour triggered in test gadt/gadt-escape1. - -Note [FixedRuntimeRep context in ExpType] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Sometimes, we want to be sure that we fill an ExpType with a type -that has a syntactically fixed RuntimeRep (in the sense of -Note [Fixed RuntimeRep] in GHC.Tc.Utils.Concrete). - -Example: - - pattern S a = (a :: (T :: TYPE R)) - -We have to infer a type for `a` which has a syntactically fixed RuntimeRep. -When it comes time to filling in the inferred type, we do the appropriate -representation-polymorphism check, much like we do a level check -as explained in Note [TcLevel of ExpType]. - -See test case T21325. --} - --- actual data definition is in GHC.Tc.Utils.TcType - -newInferExpType :: TcM ExpType -newInferExpType = new_inferExpType Nothing - -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 - - | otherwise - -> new_inferExpType (Just frr_orig) } - -new_inferExpType :: Maybe FixedRuntimeRepContext -> TcM ExpType -new_inferExpType mb_frr_orig - = 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 })) } - --- | 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. -readExpType_maybe :: ExpType -> TcM (Maybe TcType) -readExpType_maybe (Check ty) = return (Just ty) -readExpType_maybe (Infer (IR { ir_ref = ref})) = readMutVar ref - --- | Same as readExpType, but for Scaled ExpTypes -readScaledExpType :: Scaled ExpType -> TcM (Scaled Type) -readScaledExpType (Scaled m exp_ty) - = do { ty <- readExpType exp_ty - ; return (Scaled m ty) } - --- | Extract a type out of an ExpType. Otherwise, panics. -readExpType :: ExpType -> TcM TcType -readExpType exp_ty - = do { mb_ty <- readExpType_maybe exp_ty - ; case mb_ty of - Just ty -> return ty - Nothing -> pprPanic "Unknown expected type" (ppr exp_ty) } - --- | Returns the expected type when in checking mode. -checkingExpType_maybe :: ExpType -> Maybe TcType -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) - -scaledExpTypeToType :: Scaled ExpType -> TcM (Scaled TcType) -scaledExpTypeToType (Scaled m exp_ty) - = do { ty <- expTypeToType exp_ty - ; return (Scaled m ty) } - --- | Extracts the expected type if there is one, or generates a new --- TauTv if there isn't. -expTypeToType :: ExpType -> TcM TcType -expTypeToType (Check ty) = return ty -expTypeToType (Infer inf_res) = inferResultToType inf_res - -inferResultToType :: InferResult -> TcM Type -inferResultToType (IR { ir_uniq = u, ir_lvl = tc_lvl - , ir_ref = ref - , ir_frr = mb_frr }) - = do { mb_inferred_ty <- readTcRef ref - ; tau <- case mb_inferred_ty of - Just ty -> do { ensureMonoType ty - -- See Note [inferResultToType] - ; return ty } - Nothing -> do { tau <- new_meta - ; writeMutVar ref (Just tau) - ; return tau } - ; traceTc "Forcing ExpType to be monomorphic:" - (ppr u <+> text ":=" <+> ppr tau) - ; return tau } - where - -- See Note [TcLevel of ExpType] - new_meta = case mb_frr of - Nothing -> do { rr <- newMetaTyVarTyAtLevel tc_lvl runtimeRepTy - ; newMetaTyVarTyAtLevel tc_lvl (mkTYPEapp rr) } - Just frr -> mdo { rr <- newConcreteTyVarAtLevel conc_orig tc_lvl runtimeRepTy - ; tau <- newMetaTyVarTyAtLevel tc_lvl (mkTYPEapp rr) - ; let conc_orig = ConcreteFRR $ FixedRuntimeRepOrigin tau frr - ; return tau } - -{- 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] above, and -Note [fillInferResult] in GHC.Tc.Utils.Unify. --} - --- | 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 --- runtime representation. -tcInfer :: (ExpSigmaType -> TcM a) -> TcM (a, TcSigmaType) -tcInfer = tc_infer Nothing - --- | Like 'tcInfer', 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) - -tc_infer :: Maybe FixedRuntimeRepContext -> (ExpSigmaType -> TcM a) -> TcM (a, TcSigmaType) -tc_infer mb_frr tc_check - = do { res_ty <- new_inferExpType mb_frr - ; result <- tc_check res_ty - ; res_ty <- readExpType res_ty - ; return (result, res_ty) } - -{- ********************************************************************* -* * - Promoting types -* * -********************************************************************* -} - -ensureMonoType :: TcType -> TcM () --- Assuming that the argument type is of kind (TYPE r), --- ensure that it is a /monotype/ --- If it is not a monotype we can see right away (since unification --- variables and type-function applications stand for monotypes), but --- we emit a Wanted equality just to delay the error message until later -ensureMonoType res_ty - | isTauTy res_ty -- isTauTy doesn't need zonking or anything - = return () - | otherwise - = do { mono_ty <- newOpenFlexiTyVarTy - ; let eq_orig = TypeEqOrigin { uo_actual = res_ty - , uo_expected = mono_ty - , uo_thing = Nothing - , uo_visible = False } - - ; _co <- emitWantedEq eq_orig TypeLevel Nominal res_ty mono_ty - ; return () } - -promoteTcType :: TcLevel -> TcType -> TcM (TcCoercionN, TcType) --- See Note [Promoting a type] --- See also Note [fillInferResult] --- promoteTcType level ty = (co, ty') --- * Returns ty' whose max level is just 'level' --- and whose kind is ~# to the kind of 'ty' --- and whose kind has form TYPE rr --- * and co :: ty ~ ty' --- * and emits constraints to justify the coercion --- --- NB: we expect that 'ty' has already kind (TYPE rr) for --- some rr::RuntimeRep. It is, after all, the type of a term. -promoteTcType dest_lvl ty - = do { cur_lvl <- getTcLevel - ; if (cur_lvl `sameDepthAs` dest_lvl) - then return (mkNomReflCo ty, ty) - else promote_it } - where - promote_it :: TcM (TcCoercion, TcType) - promote_it -- Emit a constraint (alpha :: TYPE rr) ~ ty - -- where alpha and rr are fresh and from level dest_lvl - = do { rr <- newMetaTyVarTyAtLevel dest_lvl runtimeRepTy - ; prom_ty <- newMetaTyVarTyAtLevel dest_lvl (mkTYPEapp rr) - ; let eq_orig = TypeEqOrigin { uo_actual = ty - , uo_expected = prom_ty - , uo_thing = Nothing - , uo_visible = False } - - ; co <- emitWantedEq eq_orig TypeLevel Nominal ty prom_ty - ; return (co, prom_ty) } - -{- Note [Promoting a type] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider (#12427) - - data T where - MkT :: (Int -> Int) -> a -> T - - h y = case y of MkT v w -> v - -We'll infer the RHS type with an expected type ExpType of - (IR { ir_lvl = l, ir_ref = ref, ... ) -where 'l' is the TcLevel of the RHS of 'h'. Then the MkT pattern -match will increase the level, so we'll end up in tcSubType, trying to -unify the type of v, - v :: Int -> Int -with the expected type. But this attempt takes place at level (l+1), -rightly so, since v's type could have mentioned existential variables, -(like w's does) and we want to catch that. - -So we - - create a new meta-var alpha[l+1] - - fill in the InferRes ref cell 'ref' with alpha - - emit an equality constraint, thus - [W] alpha[l+1] ~ (Int -> Int) - -That constraint will float outwards, as it should, unless v's -type mentions a skolem-captured variable. - -This approach fails if v has a higher rank type; see -Note [Promotion and higher rank types] - - -Note [Promotion and higher rank types] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -If v had a higher-rank type, say v :: (forall a. a->a) -> Int, -then we'd emit an equality - [W] alpha[l+1] ~ ((forall a. a->a) -> Int) -which will sadly fail because we can't unify a unification variable -with a polytype. But there is nothing really wrong with the program -here. - -We could just about solve this by "promote the type" of v, to expose -its polymorphic "shape" while still leaving constraints that will -prevent existential escape. But we must be careful! Exposing -the "shape" of the type is precisely what we must NOT do under -a GADT pattern match! So in this case we might promote the type -to - (forall a. a->a) -> alpha[l+1] -and emit the constraint - [W] alpha[l+1] ~ Int -Now the promoted type can fill the ref cell, while the emitted -equality can float or not, according to the usual rules. - -But that's not quite right! We are exposing the arrow! We could -deal with that too: - (forall a. mu[l+1] a a) -> alpha[l+1] -with constraints - [W] alpha[l+1] ~ Int - [W] mu[l+1] ~ (->) -Here we abstract over the '->' inside the forall, in case that -is subject to an equality constraint from a GADT match. - -Note that we kept the outer (->) because that's part of -the polymorphic "shape". And because of impredicativity, -GADT matches can't give equalities that affect polymorphic -shape. - -This reasoning just seems too complicated, so I decided not -to do it. These higher-rank notes are just here to record -the thinking. --} - - -{- ********************************************************************* -* * - MetaTvs (meta type variables; mutable) -* * -********************************************************************* -} - -{- Note [TyVarTv] -~~~~~~~~~~~~~~~~~ -A TyVarTv can unify with type *variables* only, including other TyVarTvs and -skolems. They are used in two places: - -1. In kind signatures, see GHC.Tc.TyCl - Note [Inferring kinds for type declarations] - and Note [Using TyVarTvs for kind-checking GADTs] - -2. In partial type signatures. See GHC.Tc.Types - Note [Quantified variables in partial type signatures] - -Sometimes, they can unify with type variables that the user would -rather keep distinct; see #11203 for an example. So, any client of -this function needs to either allow the TyVarTvs to unify with each -other or check that they don't. In the case of (1) the check is done -in GHC.Tc.TyCl.swizzleTcTyConBndrs. In case of (2) it's done by -findDupTyVarTvs in GHC.Tc.Gen.Bind.chooseInferredQuantifiers. - -Historical note: Before #15050 this (under the name SigTv) was also -used for ScopedTypeVariables in patterns, to make sure these type -variables only refer to other type variables, but this restriction was -dropped, and ScopedTypeVariables can now refer to full types (GHC -Proposal 29). --} - -newMetaTyVarName :: FastString -> TcM Name --- Makes a /System/ Name, which is eagerly eliminated by --- the unifier; see GHC.Tc.Utils.Unify.nicer_to_update_tv1, and --- GHC.Tc.Solver.Canonical.canEqTyVarTyVar (nicer_to_update_tv2) -newMetaTyVarName str - = do { uniq <- newUnique - ; return (mkSystemName uniq (mkTyVarOccFS str)) } - -cloneMetaTyVarName :: Name -> TcM Name -cloneMetaTyVarName name - = do { uniq <- newUnique - ; return (mkSystemName uniq (nameOccName name)) } - -- See Note [Name of an instantiated type variable] - -{- Note [Name of an instantiated type variable] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -At the moment we give a unification variable a System Name, which -influences the way it is tidied; see TypeRep.tidyTyVarBndr. --} - -metaInfoToTyVarName :: MetaInfo -> FastString -metaInfoToTyVarName meta_info = - case meta_info of - TauTv -> fsLit "t" - TyVarTv -> fsLit "a" - RuntimeUnkTv -> fsLit "r" - CycleBreakerTv -> fsLit "b" - ConcreteTv {} -> fsLit "c" - -newAnonMetaTyVar :: MetaInfo -> Kind -> TcM TcTyVar -newAnonMetaTyVar mi = newNamedAnonMetaTyVar (metaInfoToTyVarName mi) mi - -newNamedAnonMetaTyVar :: FastString -> MetaInfo -> Kind -> TcM TcTyVar --- Make a new meta tyvar out of thin air -newNamedAnonMetaTyVar tyvar_name meta_info kind - - = do { name <- newMetaTyVarName tyvar_name - ; details <- newMetaDetails meta_info - ; let tyvar = mkTcTyVar name kind details - ; traceTc "newAnonMetaTyVar" (ppr tyvar) - ; return tyvar } - --- makes a new skolem tv -newSkolemTyVar :: SkolemInfo -> Name -> Kind -> TcM TcTyVar -newSkolemTyVar skol_info name kind - = do { lvl <- getTcLevel - ; return (mkTcTyVar name kind (SkolemTv skol_info lvl False)) } - -newTyVarTyVar :: Name -> Kind -> TcM TcTyVar --- See Note [TyVarTv] --- Does not clone a fresh unique -newTyVarTyVar name kind - = do { details <- newMetaDetails TyVarTv - ; let tyvar = mkTcTyVar name kind details - ; traceTc "newTyVarTyVar" (ppr tyvar) - ; return tyvar } - -cloneTyVarTyVar :: Name -> Kind -> TcM TcTyVar --- See Note [TyVarTv] --- Clones a fresh unique -cloneTyVarTyVar name kind - = do { details <- newMetaDetails TyVarTv - ; uniq <- newUnique - ; let name' = name `setNameUnique` uniq - tyvar = mkTcTyVar name' kind details - -- Don't use cloneMetaTyVar, which makes a SystemName - -- We want to keep the original more user-friendly Name - -- In practical terms that means that in error messages, - -- when the Name is tidied we get 'a' rather than 'a0' - ; traceTc "cloneTyVarTyVar" (ppr tyvar) - ; return tyvar } - --- | Create a new metavariable, of the given kind, which can only be unified --- with a concrete type. --- --- Invariant: the kind must be concrete, as per Note [ConcreteTv]. --- This is checked with an assertion. -newConcreteTyVar :: HasDebugCallStack => ConcreteTvOrigin -> TcKind -> TcM TcTyVar -newConcreteTyVar reason kind = - assertPpr (isConcrete kind) - (text "newConcreteTyVar: non-concrete kind" <+> ppr kind) - $ newAnonMetaTyVar (ConcreteTv reason) kind - -newPatSigTyVar :: Name -> Kind -> TcM TcTyVar -newPatSigTyVar 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) - ; return tyvar } - -cloneAnonMetaTyVar :: MetaInfo -> TyVar -> TcKind -> TcM TcTyVar --- Make a fresh MetaTyVar, basing the name --- on that of the supplied TyVar -cloneAnonMetaTyVar info tv kind - = do { details <- newMetaDetails info - ; name <- cloneMetaTyVarName (tyVarName tv) - ; let tyvar = mkTcTyVar name kind details - ; traceTc "cloneAnonMetaTyVar" (ppr tyvar <+> dcolon <+> ppr (tyVarKind tyvar)) - ; return tyvar } - --- Make a new CycleBreakerTv. See Note [Type equality cycles] --- in GHC.Tc.Solver.Canonical. -newCycleBreakerTyVar :: TcKind -> TcM TcTyVar -newCycleBreakerTyVar kind - = do { details <- newMetaDetails CycleBreakerTv - ; name <- newMetaTyVarName (fsLit "cbv") - ; return (mkTcTyVar name kind details) } - -newMetaDetails :: MetaInfo -> TcM TcTyVarDetails -newMetaDetails info - = do { ref <- newMutVar Flexi - ; tclvl <- getTcLevel - ; return (MetaTv { mtv_info = info - , mtv_ref = ref - , mtv_tclvl = tclvl }) } - -newTauTvDetailsAtLevel :: TcLevel -> TcM TcTyVarDetails -newTauTvDetailsAtLevel tclvl - = do { ref <- newMutVar Flexi - ; return (MetaTv { mtv_info = TauTv - , mtv_ref = ref - , mtv_tclvl = tclvl }) } - -newConcreteTvDetailsAtLevel :: ConcreteTvOrigin -> TcLevel -> TcM TcTyVarDetails -newConcreteTvDetailsAtLevel conc_orig tclvl - = do { ref <- newMutVar Flexi - ; return (MetaTv { mtv_info = ConcreteTv conc_orig - , mtv_ref = ref - , mtv_tclvl = tclvl }) } - -cloneMetaTyVar :: TcTyVar -> TcM TcTyVar -cloneMetaTyVar tv - = assert (isTcTyVar tv) $ - do { ref <- newMutVar Flexi - ; name' <- cloneMetaTyVarName (tyVarName tv) - ; let details' = case tcTyVarDetails tv of - details@(MetaTv {}) -> details { mtv_ref = ref } - _ -> pprPanic "cloneMetaTyVar" (ppr tv) - tyvar = mkTcTyVar name' (tyVarKind tv) details' - ; traceTc "cloneMetaTyVar" (ppr tyvar) - ; return tyvar } - --- Works for both type and kind variables -readMetaTyVar :: TyVar -> TcM MetaDetails -readMetaTyVar tyvar = assertPpr (isMetaTyVar tyvar) (ppr tyvar) $ - readMutVar (metaTyVarRef tyvar) - -isFilledMetaTyVar_maybe :: TcTyVar -> TcM (Maybe Type) -isFilledMetaTyVar_maybe tv --- TODO: This should be an assertion that tv is definitely a TcTyVar but it fails --- at the moment (Jan 22) - | isTcTyVar tv - , MetaTv { mtv_ref = ref } <- tcTyVarDetails tv - = do { cts <- readTcRef ref - ; case cts of - Indirect ty -> return (Just ty) - Flexi -> return Nothing } - | otherwise - = return Nothing - -isFilledMetaTyVar :: TyVar -> TcM Bool --- True of a filled-in (Indirect) meta type variable -isFilledMetaTyVar tv = isJust <$> isFilledMetaTyVar_maybe tv - -isUnfilledMetaTyVar :: TyVar -> TcM Bool --- True of a un-filled-in (Flexi) meta type variable --- NB: Not the opposite of isFilledMetaTyVar -isUnfilledMetaTyVar tv - | MetaTv { mtv_ref = ref } <- tcTyVarDetails tv - = do { details <- readMutVar ref - ; return (isFlexi details) } - | otherwise = return False - --------------------- --- Works with both type and kind variables -writeMetaTyVar :: HasDebugCallStack => TcTyVar -> TcType -> TcM () --- Write into a currently-empty MetaTyVar - -writeMetaTyVar tyvar ty - | not debugIsOn - = writeMetaTyVarRef tyvar (metaTyVarRef tyvar) ty - --- Everything from here on only happens if DEBUG is on - | not (isTcTyVar tyvar) - = massertPpr False (text "Writing to non-tc tyvar" <+> ppr tyvar) - - | MetaTv { mtv_ref = ref } <- tcTyVarDetails tyvar - = writeMetaTyVarRef tyvar ref ty - - | otherwise - = massertPpr False (text "Writing to non-meta tyvar" <+> ppr tyvar) - --------------------- -writeMetaTyVarRef :: HasDebugCallStack => TcTyVar -> TcRef MetaDetails -> TcType -> TcM () --- Here the tyvar is for error checking only; --- the ref cell must be for the same tyvar -writeMetaTyVarRef tyvar ref ty - | not debugIsOn - = do { traceTc "writeMetaTyVar" (ppr tyvar <+> dcolon <+> ppr (tyVarKind tyvar) - <+> text ":=" <+> ppr ty) - ; writeTcRef ref (Indirect ty) } - - -- Everything from here on only happens if DEBUG is on - -- Need to zonk 'ty' because we may only recently have promoted - -- its free meta-tyvars (see Solver.Interact.tryToSolveByUnification) - | otherwise - = do { meta_details <- readMutVar ref; - -- Zonk kinds to allow the error check to work - ; zonked_tv_kind <- zonkTcType tv_kind - ; zonked_ty <- zonkTcType ty - ; let zonked_ty_kind = typeKind zonked_ty - zonked_ty_lvl = tcTypeLevel zonked_ty - level_check_ok = not (zonked_ty_lvl `strictlyDeeperThan` tv_lvl) - level_check_msg = ppr zonked_ty_lvl $$ ppr tv_lvl $$ ppr tyvar $$ ppr ty - kind_check_ok = zonked_ty_kind `eqType` zonked_tv_kind - -- Note [Extra-constraint holes in partial type signatures] in GHC.Tc.Gen.HsType - - kind_msg = hang (text "Ill-kinded update to meta tyvar") - 2 ( ppr tyvar <+> text "::" <+> (ppr tv_kind $$ ppr zonked_tv_kind) - <+> text ":=" - <+> ppr ty <+> text "::" <+> (ppr zonked_ty_kind) ) - - ; traceTc "writeMetaTyVar" (ppr tyvar <+> text ":=" <+> ppr ty) - - -- Check for double updates - ; massertPpr (isFlexi meta_details) (double_upd_msg meta_details) - - -- Check for level OK - ; massertPpr level_check_ok level_check_msg - - -- Check Kinds ok - ; massertPpr kind_check_ok kind_msg - - -- Do the write - ; writeMutVar ref (Indirect ty) } - where - tv_kind = tyVarKind tyvar - - tv_lvl = tcTyVarLevel tyvar - - - double_upd_msg details = hang (text "Double update of meta tyvar") - 2 (ppr tyvar $$ ppr details) - -{- -************************************************************************ -* * - MetaTvs: TauTvs -* * -************************************************************************ - -Note [Never need to instantiate coercion variables] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -With coercion variables sloshing around in types, it might seem that we -sometimes need to instantiate coercion variables. This would be problematic, -because coercion variables inhabit unboxed equality (~#), and the constraint -solver thinks in terms only of boxed equality (~). The solution is that -we never need to instantiate coercion variables in the first place. - -The tyvars that we need to instantiate come from the types of functions, -data constructors, and patterns. These will never be quantified over -coercion variables, except for the special case of the promoted Eq#. But, -that can't ever appear in user code, so we're safe! --} - - -newMultiplicityVar :: TcM TcType -newMultiplicityVar = newFlexiTyVarTy multiplicityTy - -newFlexiTyVar :: Kind -> TcM TcTyVar -newFlexiTyVar kind = newAnonMetaTyVar TauTv kind - --- | Create a new flexi ty var with a specific name -newNamedFlexiTyVar :: FastString -> Kind -> TcM TcTyVar -newNamedFlexiTyVar fs kind = newNamedAnonMetaTyVar fs TauTv kind - -newFlexiTyVarTy :: Kind -> TcM TcType -newFlexiTyVarTy kind = do - tc_tyvar <- newFlexiTyVar kind - return (mkTyVarTy tc_tyvar) - -newFlexiTyVarTys :: Int -> Kind -> TcM [TcType] -newFlexiTyVarTys n kind = replicateM n (newFlexiTyVarTy kind) - -newOpenTypeKind :: TcM TcKind -newOpenTypeKind - = do { rr <- newFlexiTyVarTy runtimeRepTy - ; 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 -newOpenFlexiTyVarTy :: TcM TcType -newOpenFlexiTyVarTy - = do { tv <- newOpenFlexiTyVar - ; return (mkTyVarTy tv) } - -newOpenFlexiTyVar :: TcM TcTyVar -newOpenFlexiTyVar - = do { kind <- newOpenTypeKind - ; newFlexiTyVar kind } - -newOpenBoxedTypeKind :: TcM TcKind -newOpenBoxedTypeKind - = do { lev <- newFlexiTyVarTy (mkTyConTy levityTyCon) - ; let rr = mkTyConApp boxedRepDataConTyCon [lev] - ; return (mkTYPEapp rr) } - -newMetaTyVars :: [TyVar] -> TcM (Subst, [TcTyVar]) --- Instantiate with META type variables --- Note that this works for a sequence of kind, type, and coercion variables --- variables. Eg [ (k:*), (a:k->k) ] --- Gives [ (k7:*), (a8:k7->k7) ] -newMetaTyVars = newMetaTyVarsX emptySubst - -- emptySubst has an empty in-scope set, but that's fine here - -- Since the tyvars are freshly made, they cannot possibly be - -- captured by any existing for-alls. - -newMetaTyVarsX :: Subst -> [TyVar] -> TcM (Subst, [TcTyVar]) --- Just like newMetaTyVars, but start with an existing substitution. -newMetaTyVarsX subst = mapAccumLM newMetaTyVarX subst - -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 - -newMetaTyVarTyVarX :: Subst -> TyVar -> TcM (Subst, TcTyVar) --- Just like newMetaTyVarX, but make a TyVarTv -newMetaTyVarTyVarX = new_meta_tv_x TyVarTv - -newWildCardX :: Subst -> TyVar -> TcM (Subst, TcTyVar) -newWildCardX subst tv - = do { new_tv <- newAnonMetaTyVar TauTv (substTy subst (tyVarKind tv)) - ; return (extendTvSubstWithClone subst tv new_tv, new_tv) } - -new_meta_tv_x :: MetaInfo -> Subst -> TyVar -> TcM (Subst, TcTyVar) -new_meta_tv_x info subst tv - = do { new_tv <- cloneAnonMetaTyVar info tv substd_kind - ; 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 - -newMetaTyVarTyAtLevel :: TcLevel -> TcKind -> TcM TcType -newMetaTyVarTyAtLevel tc_lvl kind - = do { details <- newTauTvDetailsAtLevel tc_lvl - ; name <- newMetaTyVarName (fsLit "p") - ; return (mkTyVarTy (mkTcTyVar name kind details)) } - -newConcreteTyVarAtLevel :: ConcreteTvOrigin -> TcLevel -> TcKind -> TcM TcType -newConcreteTyVarAtLevel conc_orig tc_lvl kind - = do { details <- newConcreteTvDetailsAtLevel conc_orig tc_lvl - ; name <- newMetaTyVarName (fsLit "c") - ; return (mkTyVarTy (mkTcTyVar name kind details)) } - - -{- ********************************************************************* -* * - Finding variables to quantify over -* * -********************************************************************* -} - -{- Note [Dependent type variables] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In Haskell type inference we quantify over type variables; but we only -quantify over /kind/ variables when -XPolyKinds is on. Without -XPolyKinds -we default the kind variables to *. - -So, to support this defaulting, and only for that reason, when -collecting the free vars of a type (in candidateQTyVarsOfType and friends), -prior to quantifying, we must keep the type and kind variables separate. - -But what does that mean in a system where kind variables /are/ type -variables? It's a fairly arbitrary distinction based on how the -variables appear: - - - "Kind variables" appear in the kind of some other free variable - or in the kind of a locally quantified type variable - (forall (a :: kappa). ...) or in the kind of a coercion - (a |> (co :: kappa1 ~ kappa2)). - - These are the ones we default to * if -XPolyKinds is off - - - "Type variables" are all free vars that are not kind variables - -E.g. In the type T k (a::k) - 'k' is a kind variable, because it occurs in the kind of 'a', - even though it also appears at "top level" of the type - 'a' is a type variable, because it doesn't - -We gather these variables using a CandidatesQTvs record: - DV { dv_kvs: Variables free in the kind of a free type variable - or of a forall-bound type variable - , dv_tvs: Variables syntactically free in the type } - -So: dv_kvs are the kind variables of the type - (dv_tvs - dv_kvs) are the type variable of the type - -Note that - -* A variable can occur in both. - T k (x::k) The first occurrence of k makes it - show up in dv_tvs, the second in dv_kvs - -* We include any coercion variables in the "dependent", - "kind-variable" set because we never quantify over them. - -* The "kind variables" might depend on each other; e.g - (k1 :: k2), (k2 :: *) - The "type variables" do not depend on each other; if - one did, it'd be classified as a kind variable! - -Note [CandidatesQTvs determinism and order] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -* Determinism: when we quantify over type variables we decide the - order in which they appear in the final type. Because the order of - type variables in the type can end up in the interface file and - affects some optimizations like worker-wrapper, we want this order to - be deterministic. - - To achieve that we use deterministic sets of variables that can be - converted to lists in a deterministic order. For more information - about deterministic sets see Note [Deterministic UniqFM] in GHC.Types.Unique.DFM. - -* Order: as well as being deterministic, we use an - accumulating-parameter style for candidateQTyVarsOfType so that we - add variables one at a time, left to right. That means we tend to - produce the variables in left-to-right order. This is just to make - it bit more predictable for the programmer. - -Note [Naughty quantification candidates] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider (#14880, dependent/should_compile/T14880-2), suppose -we are trying to generalise this type: - - forall arg. ... (alpha[tau]:arg) ... - -We have a metavariable alpha whose kind mentions a skolem variable -bound inside the very type we are generalising. -This can arise while type-checking a user-written type signature -(see the test case for the full code). - -We cannot generalise over alpha! That would produce a type like - forall {a :: arg}. forall arg. ...blah... -The fact that alpha's kind mentions arg renders it completely -ineligible for generalisation. - -However, we are not going to learn any new constraints on alpha, -because its kind isn't even in scope in the outer context (but see Wrinkle). -So alpha is entirely unconstrained. - -What then should we do with alpha? During generalization, every -metavariable is either (A) promoted, (B) generalized, or (C) zapped -(according to Note [Recipe for checking a signature] in GHC.Tc.Gen.HsType). - - * We can't generalise it. - * We can't promote it, because its kind prevents that - * We can't simply leave it be, because this type is about to - go into the typing environment (as the type of some let-bound - variable, say), and then chaos erupts when we try to instantiate. - -Previously, we zapped it to Any. This worked, but it had the unfortunate -effect of causing Any sometimes to appear in error messages. If this -kind of signature happens, the user probably has made a mistake -- no -one really wants Any in their types. So we now error. This must be -a hard error (failure in the monad) to avoid other messages from mentioning -Any. - -We do this eager erroring in candidateQTyVars, which always precedes -generalisation, because at that moment we have a clear picture of what -skolems are in scope within the type itself (e.g. that 'forall arg'). - -This change is inspired by and described in Section 7.2 of "Kind Inference -for Datatypes", POPL'20. - -NB: this is all rather similar to, but sadly not the same as - Note [Error on unconstrained meta-variables] - -Wrinkle: - -We must make absolutely sure that alpha indeed is not -from an outer context. (Otherwise, we might indeed learn more information -about it.) This can be done easily: we just check alpha's TcLevel. -That level must be strictly greater than the ambient TcLevel in order -to treat it as naughty. We say "strictly greater than" because the call to -candidateQTyVars is made outside the bumped TcLevel, as stated in the -comment to candidateQTyVarsOfType. The level check is done in go_tv -in collect_cand_qtvs. Skipping this check caused #16517. - --} - -data CandidatesQTvs - -- See Note [Dependent type variables] - -- See Note [CandidatesQTvs determinism and order] - -- - -- Invariants: - -- * All variables are fully zonked, including their kinds - -- * All variables are at a level greater than the ambient level - -- See Note [Use level numbers for quantification] - -- - -- This *can* contain skolems. For example, in `data X k :: k -> Type` - -- we need to know that the k is a dependent variable. This is done - -- by collecting the candidates in the kind after skolemising. It also - -- comes up when generalizing a associated type instance, where instance - -- variables are skolems. (Recall that associated type instances are generalized - -- independently from their enclosing class instance, and the associated - -- type instance may be generalized by more, fewer, or different variables - -- than the class instance.) - -- - = DV { dv_kvs :: DTyVarSet -- "kind" metavariables (dependent) - , dv_tvs :: DTyVarSet -- "type" metavariables (non-dependent) - -- A variable may appear in both sets - -- E.g. T k (x::k) The first occurrence of k makes it - -- show up in dv_tvs, the second in dv_kvs - -- See Note [Dependent type variables] - - , dv_cvs :: CoVarSet - -- These are covars. Included only so that we don't repeatedly - -- look at covars' kinds in accumulator. Not used by quantifyTyVars. - } - -instance Semi.Semigroup CandidatesQTvs where - (DV { dv_kvs = kv1, dv_tvs = tv1, dv_cvs = cv1 }) - <> (DV { dv_kvs = kv2, dv_tvs = tv2, dv_cvs = cv2 }) - = DV { dv_kvs = kv1 `unionDVarSet` kv2 - , dv_tvs = tv1 `unionDVarSet` tv2 - , dv_cvs = cv1 `unionVarSet` cv2 } - -instance Monoid CandidatesQTvs where - mempty = DV { dv_kvs = emptyDVarSet, dv_tvs = emptyDVarSet, dv_cvs = emptyVarSet } - mappend = (Semi.<>) - -instance Outputable CandidatesQTvs where - ppr (DV {dv_kvs = kvs, dv_tvs = tvs, dv_cvs = cvs }) - = text "DV" <+> braces (pprWithCommas id [ text "dv_kvs =" <+> ppr kvs - , text "dv_tvs =" <+> ppr tvs - , text "dv_cvs =" <+> ppr cvs ]) - -isEmptyCandidates :: CandidatesQTvs -> Bool -isEmptyCandidates (DV { dv_kvs = kvs, dv_tvs = tvs }) - = isEmptyDVarSet kvs && isEmptyDVarSet tvs - --- | Extract out the kind vars (in order) and type vars (in order) from --- a 'CandidatesQTvs'. The lists are guaranteed to be distinct. Keeping --- the lists separate is important only in the -XNoPolyKinds case. -candidateVars :: CandidatesQTvs -> ([TcTyVar], [TcTyVar]) -candidateVars (DV { dv_kvs = dep_kv_set, dv_tvs = nondep_tkv_set }) - = (dep_kvs, nondep_tvs) - where - dep_kvs = scopedSort $ dVarSetElems dep_kv_set - -- scopedSort: put the kind variables into - -- well-scoped order. - -- E.g. [k, (a::k)] not the other way round - - nondep_tvs = dVarSetElems (nondep_tkv_set `minusDVarSet` dep_kv_set) - -- See Note [Dependent type variables] - -- The `minus` dep_tkvs removes any kind-level vars - -- e.g. T k (a::k) Since k appear in a kind it'll - -- be in dv_kvs, and is dependent. So remove it from - -- dv_tvs which will also contain k - -- NB kinds of tvs are already zonked - -candidateKindVars :: CandidatesQTvs -> TyVarSet -candidateKindVars dvs = dVarSetToVarSet (dv_kvs dvs) - -delCandidates :: CandidatesQTvs -> [Var] -> CandidatesQTvs -delCandidates (DV { dv_kvs = kvs, dv_tvs = tvs, dv_cvs = cvs }) vars - = DV { dv_kvs = kvs `delDVarSetList` vars - , dv_tvs = tvs `delDVarSetList` vars - , dv_cvs = cvs `delVarSetList` vars } - -partitionCandidates :: CandidatesQTvs -> (TyVar -> Bool) -> (TyVarSet, CandidatesQTvs) --- The selected TyVars are returned as a non-deterministic TyVarSet -partitionCandidates dvs@(DV { dv_kvs = kvs, dv_tvs = tvs }) pred - = (extracted, dvs { dv_kvs = rest_kvs, dv_tvs = rest_tvs }) - where - (extracted_kvs, rest_kvs) = partitionDVarSet pred kvs - (extracted_tvs, rest_tvs) = partitionDVarSet pred tvs - extracted = dVarSetToVarSet extracted_kvs `unionVarSet` dVarSetToVarSet extracted_tvs - -candidateQTyVarsWithBinders :: [TyVar] -> Type -> TcM CandidatesQTvs --- (candidateQTyVarsWithBinders tvs ty) returns the candidateQTyVars --- of (forall tvs. ty), but do not treat 'tvs' as bound for the purpose --- of Note [Naughty quantification candidates]. Why? --- Because we are going to scoped-sort the quantified variables --- in among the tvs -candidateQTyVarsWithBinders bound_tvs ty - = do { kvs <- candidateQTyVarsOfKinds (map tyVarKind bound_tvs) - ; all_tvs <- collect_cand_qtvs ty False emptyVarSet kvs ty - ; return (all_tvs `delCandidates` bound_tvs) } - --- | Gathers free variables to use as quantification candidates (in --- 'quantifyTyVars'). This might output the same var --- in both sets, if it's used in both a type and a kind. --- The variables to quantify must have a TcLevel strictly greater than --- the ambient level. (See Wrinkle in Note [Naughty quantification candidates]) --- See Note [CandidatesQTvs determinism and order] --- See Note [Dependent type variables] -candidateQTyVarsOfType :: TcType -- not necessarily zonked - -> TcM CandidatesQTvs -candidateQTyVarsOfType ty = collect_cand_qtvs ty False emptyVarSet mempty ty - --- | Like 'candidateQTyVarsOfType', but over a list of types --- The variables to quantify must have a TcLevel strictly greater than --- the ambient level. (See Wrinkle in Note [Naughty quantification candidates]) -candidateQTyVarsOfTypes :: [Type] -> TcM CandidatesQTvs -candidateQTyVarsOfTypes tys = foldlM (\acc ty -> collect_cand_qtvs ty False emptyVarSet acc ty) - mempty tys - --- | Like 'candidateQTyVarsOfType', but consider every free variable --- to be dependent. This is appropriate when generalizing a *kind*, --- instead of a type. (That way, -XNoPolyKinds will default the variables --- to Type.) -candidateQTyVarsOfKind :: TcKind -- Not necessarily zonked - -> TcM CandidatesQTvs -candidateQTyVarsOfKind ty = collect_cand_qtvs ty True emptyVarSet mempty ty - -candidateQTyVarsOfKinds :: [TcKind] -- Not necessarily zonked - -> TcM CandidatesQTvs -candidateQTyVarsOfKinds tys = foldM (\acc ty -> collect_cand_qtvs ty True emptyVarSet acc ty) - mempty tys - -collect_cand_qtvs - :: TcType -- original type that we started recurring into; for errors - -> Bool -- True <=> consider every fv in Type to be dependent - -> VarSet -- Bound variables (locals only) - -> CandidatesQTvs -- Accumulating parameter - -> Type -- Not necessarily zonked - -> TcM CandidatesQTvs - --- Key points: --- * Looks through meta-tyvars as it goes; --- no need to zonk in advance --- --- * Needs to be monadic anyway, because it handles naughty --- quantification; see Note [Naughty quantification candidates] --- --- * Returns fully-zonked CandidateQTvs, including their kinds --- so that subsequent dependency analysis (to build a well --- scoped telescope) works correctly - -collect_cand_qtvs orig_ty is_dep bound dvs ty - = go dvs ty - where - is_bound tv = tv `elemVarSet` bound - - ----------------- - go :: CandidatesQTvs -> TcType -> TcM CandidatesQTvs - -- Uses accumulating-parameter style - go dv (AppTy t1 t2) = foldlM go dv [t1, t2] - go dv (TyConApp tc tys) = go_tc_args dv (tyConBinders tc) tys - go dv (FunTy _ w arg res) = foldlM go dv [w, arg, res] - go dv (LitTy {}) = return dv - go dv (CastTy ty co) = do dv1 <- go dv ty - collect_cand_qtvs_co orig_ty bound dv1 co - go dv (CoercionTy co) = collect_cand_qtvs_co orig_ty bound dv co - - go dv (TyVarTy tv) - | is_bound tv = return dv - | otherwise = do { m_contents <- isFilledMetaTyVar_maybe tv - ; case m_contents of - Just ind_ty -> go dv ind_ty - Nothing -> go_tv dv tv } - - go dv (ForAllTy (Bndr tv _) ty) - = do { dv1 <- collect_cand_qtvs orig_ty True bound dv (tyVarKind tv) - ; collect_cand_qtvs orig_ty is_dep (bound `extendVarSet` tv) dv1 ty } - - -- This makes sure that we default e.g. the alpha in Proxy alpha (Any alpha). - -- Tested in polykinds/NestedProxies. - -- We just might get this wrong in AppTy, but I don't think that's possible - -- with -XNoPolyKinds. And fixing it would be non-performant, as we'd need - -- to look at kinds. - go_tc_args dv (tc_bndr:tc_bndrs) (ty:tys) - = do { dv1 <- collect_cand_qtvs orig_ty (is_dep || isNamedTyConBinder tc_bndr) - bound dv ty - ; go_tc_args dv1 tc_bndrs tys } - go_tc_args dv _bndrs tys -- _bndrs might be non-empty: undersaturation - -- tys might be non-empty: oversaturation - -- either way, the foldlM is correct - = foldlM go dv tys - - ----------------- - go_tv dv@(DV { dv_kvs = kvs, dv_tvs = tvs }) tv - | tv `elemDVarSet` kvs - = return dv -- We have met this tyvar already - - | not is_dep - , tv `elemDVarSet` tvs - = return dv -- We have met this tyvar already - - | otherwise - = do { tv_kind <- zonkTcType (tyVarKind tv) - -- This zonk is annoying, but it is necessary, both to - -- ensure that the collected candidates have zonked kinds - -- (#15795) and to make the naughty check - -- (which comes next) works correctly - - ; let tv_kind_vars = tyCoVarsOfType tv_kind - ; cur_lvl <- getTcLevel - ; if | tcTyVarLevel tv <= cur_lvl - -> 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 - _ -> False - -> return dv -- Skip inner skolems; ToDo: explain - - | intersectsVarSet bound tv_kind_vars - -- the tyvar must not be from an outer context, but we have - -- already checked for this. - -- See Note [Naughty quantification candidates] - -> do { traceTc "Naughty quantifier" $ - vcat [ ppr tv <+> dcolon <+> ppr tv_kind - , text "bound:" <+> pprTyVars (nonDetEltsUniqSet bound) - , text "fvs:" <+> pprTyVars (nonDetEltsUniqSet tv_kind_vars) ] - - ; let escapees = intersectVarSet bound tv_kind_vars - ; naughtyQuantification orig_ty tv escapees } - - | otherwise - -> do { let tv' = tv `setTyVarKind` tv_kind - dv' | is_dep = dv { dv_kvs = kvs `extendDVarSet` tv' } - | otherwise = dv { dv_tvs = tvs `extendDVarSet` tv' } - -- See Note [Order of accumulation] - - -- See Note [Recurring into kinds for candidateQTyVars] - ; collect_cand_qtvs orig_ty True bound dv' tv_kind } } - -collect_cand_qtvs_co :: TcType -- original type at top of recursion; for errors - -> VarSet -- bound variables - -> CandidatesQTvs -> Coercion - -> TcM CandidatesQTvs -collect_cand_qtvs_co orig_ty bound = go_co - where - go_co dv (Refl ty) = collect_cand_qtvs orig_ty True bound dv ty - go_co dv (GRefl _ ty mco) = do dv1 <- collect_cand_qtvs orig_ty True bound dv ty - go_mco dv1 mco - 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 bound dv1 t1 - collect_cand_qtvs orig_ty True bound dv2 t2 - 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 - go_co dv (LRCo _ co) = go_co dv co - go_co dv (InstCo co1 co2) = foldlM go_co dv [co1, co2] - go_co dv (KindCo co) = go_co dv co - go_co dv (SubCo co) = go_co dv co - - go_co dv (HoleCo hole) - = do m_co <- 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) - = do { dv1 <- go_co dv kind_co - ; collect_cand_qtvs_co orig_ty (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 - | cv `elemVarSet` cvs = return dv - - -- See Note [Recurring into kinds for candidateQTyVars] - | otherwise = collect_cand_qtvs orig_ty True bound - (dv { dv_cvs = cvs `extendVarSet` cv }) - (idType cv) - - is_bound tv = tv `elemVarSet` bound - -{- Note [Order of accumulation] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -You might be tempted (like I was) to use unitDVarSet and mappend -rather than extendDVarSet. However, the union algorithm for -deterministic sets depends on (roughly) the size of the sets. The -elements from the smaller set end up to the right of the elements from -the larger one. When sets are equal, the left-hand argument to -`mappend` goes to the right of the right-hand argument. - -In our case, if we use unitDVarSet and mappend, we learn that the free -variables of (a -> b -> c -> d) are [b, a, c, d], and we then quantify -over them in that order. (The a comes after the b because we union the -singleton sets as ({a} `mappend` {b}), producing {b, a}. Thereafter, -the size criterion works to our advantage.) This is just annoying to -users, so I use `extendDVarSet`, which unambiguously puts the new -element to the right. - -Note that the unitDVarSet/mappend implementation would not be wrong -against any specification -- just suboptimal and confounding to users. - -Note [Recurring into kinds for candidateQTyVars] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -First, read Note [Closing over free variable kinds] in GHC.Core.TyCo.FVs, paying -attention to the end of the Note about using an empty bound set when -traversing a variable's kind. - -That Note concludes with the recommendation that we empty out the bound -set when recurring into the kind of a type variable. Yet, we do not do -this here. I have two tasks in order to convince you that this code is -right. First, I must show why it is safe to ignore the reasoning in that -Note. Then, I must show why is is necessary to contradict the reasoning in -that Note. - -Why it is safe: There can be no -shadowing in the candidateQ... functions: they work on the output of -type inference, which is seeded by the renamer and its insistence to -use different Uniques for different variables. (In contrast, the Core -functions work on the output of optimizations, which may introduce -shadowing.) Without shadowing, the problem studied by -Note [Closing over free variable kinds] in GHC.Core.TyCo.FVs cannot happen. - -Why it is necessary: -Wiping the bound set would be just plain wrong here. Consider - - forall k1 k2 (a :: k1). Proxy k2 (a |> (hole :: k1 ~# k2)) - -We really don't want to think k1 and k2 are free here. (It's true that we'll -never be able to fill in `hole`, but we don't want to go off the rails just -because we have an insoluble coercion hole.) So: why is it wrong to wipe -the bound variables here but right in Core? Because the final statement -in Note [Closing over free variable kinds] in GHC.Core.TyCo.FVs is wrong: not -every variable is either free or bound. A variable can be a hole, too! -The reasoning in that Note then breaks down. - -And the reasoning applies just as well to free non-hole variables, so we -retain the bound set always. - --} - -{- ********************************************************************* -* * - Quantification -* * -************************************************************************ - -Note [quantifyTyVars] -~~~~~~~~~~~~~~~~~~~~~ -quantifyTyVars is given the free vars of a type that we -are about to wrap in a forall. - -It takes these free type/kind variables (partitioned into dependent and -non-dependent variables) skolemises metavariables with a TcLevel greater -than the ambient level (see Note [Use level numbers for quantification]). - -* This function distinguishes between dependent and non-dependent - variables only to keep correct defaulting behavior with -XNoPolyKinds. - With -XPolyKinds, it treats both classes of variables identically. - -* quantifyTyVars never quantifies over - - a coercion variable (or any tv mentioned in the kind of a covar) - - a runtime-rep variable - -Note [Use level numbers for quantification] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The level numbers assigned to metavariables are very useful. Not only -do they track touchability (Note [TcLevel invariants] in GHC.Tc.Utils.TcType), -but they also allow us to determine which variables to -generalise. The rule is this: - - When generalising, quantify only metavariables with a TcLevel greater - than the ambient level. - -This works because we bump the level every time we go inside a new -source-level construct. In a traditional generalisation algorithm, we -would gather all free variables that aren't free in an environment. -However, if a variable is in that environment, it will always have a lower -TcLevel: it came from an outer scope. So we can replace the "free in -environment" check with a level-number check. - -Here is an example: - - f x = x + (z True) - where - z y = x * x - -We start by saying (x :: alpha[1]). When inferring the type of z, we'll -quickly discover that z :: alpha[1]. But it would be disastrous to -generalise over alpha in the type of z. So we need to know that alpha -comes from an outer environment. By contrast, the type of y is beta[2], -and we are free to generalise over it. What's the difference between -alpha[1] and beta[2]? Their levels. beta[2] has the right TcLevel for -generalisation, and so we generalise it. alpha[1] does not, and so -we leave it alone. - -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 -and in GHC.Tc.Gen.HsType.kindGeneralizeSome, both of which exclude -certain otherwise-eligible variables from being generalised. - -Using level numbers for quantification is implemented in the candidateQTyVars... -functions, by adding only those variables with a level strictly higher than -the ambient level to the set of candidates. - -Note [quantifyTyVars determinism] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The results of quantifyTyVars are wrapped in a forall and can end up in the -interface file. One such example is inferred type signatures. They also affect -the results of optimizations, for example worker-wrapper. This means that to -get deterministic builds quantifyTyVars needs to be deterministic. - -To achieve this CandidatesQTvs is backed by deterministic sets which allows them -to be later converted to a list in a deterministic order. - -For more information about deterministic sets see -Note [Deterministic UniqFM] in GHC.Types.Unique.DFM. --} - -quantifyTyVars :: SkolemInfo - -> NonStandardDefaultingStrategy - -> CandidatesQTvs -- See Note [Dependent type variables] - -- Already zonked - -> TcM [TcTyVar] --- See Note [quantifyTyVars] --- Can be given a mixture of TcTyVars and TyVars, in the case of --- associated type declarations. Also accepts covars, but *never* returns any. --- According to Note [Use level numbers for quantification] and the --- invariants on CandidateQTvs, we do not have to filter out variables --- free in the environment here. Just quantify unconditionally, subject --- to the restrictions in Note [quantifyTyVars]. -quantifyTyVars skol_info ns_strat dvs - -- short-circuit common case - | isEmptyCandidates dvs - = do { traceTc "quantifyTyVars has nothing to quantify" empty - ; return [] } - - | otherwise - = do { traceTc "quantifyTyVars {" - ( vcat [ text "ns_strat =" <+> ppr ns_strat - , text "dvs =" <+> ppr dvs ]) - - ; undefaulted <- defaultTyVars ns_strat dvs - ; final_qtvs <- mapMaybeM zonk_quant undefaulted - - ; traceTc "quantifyTyVars }" - (vcat [ text "undefaulted:" <+> pprTyVars undefaulted - , text "final_qtvs:" <+> pprTyVars final_qtvs ]) - - -- We should never quantify over coercion variables; check this - ; let co_vars = filter isCoVar final_qtvs - ; massertPpr (null co_vars) (ppr co_vars) - - ; return final_qtvs } - where - -- zonk_quant returns a tyvar if it should be quantified over; - -- otherwise, it returns Nothing. The latter case happens for - -- non-meta-tyvars - zonk_quant tkv - | not (isTyVar tkv) - = return Nothing -- this can happen for a covar that's associated with - -- a coercion hole. Test case: typecheck/should_compile/T2494 - - | 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 -> TcM TcTyCoVar --- A tyvar binder is never a unification variable (TauTv), --- rather it is always a skolem. It *might* be a TyVarTv. --- (Because non-CUSK type declarations use TyVarTvs.) --- Regardless, it may have a kind that has not yet been zonked, --- and may include kind unification variables. -zonkAndSkolemise skol_info tyvar - | isTyVarTyVar tyvar - -- We want to preserve the binding location of the original TyVarTv. - -- This is important for error messages. If we don't do this, then - -- we get bad locations in, e.g., typecheck/should_fail/T2688 - = do { zonked_tyvar <- zonkTcTyVarToTcTyVar tyvar - ; skolemiseQuantifiedTyVar skol_info zonked_tyvar } - - | otherwise - = assertPpr (isImmutableTyVar tyvar || isCoVar tyvar) (pprTyVar tyvar) $ - zonkTyCoVarKind tyvar - -skolemiseQuantifiedTyVar :: SkolemInfo -> TcTyVar -> TcM TcTyVar --- The quantified type variables often include meta type variables --- we want to freeze them into ordinary type variables --- The meta tyvar is updated to point to the new skolem TyVar. Now any --- bound occurrences of the original type variable will get zonked to --- the immutable version. --- --- We leave skolem TyVars alone; they are immutable. --- --- This function is called on both kind and type variables, --- but kind variables *only* if PolyKinds is on. - -skolemiseQuantifiedTyVar skol_info tv - = case tcTyVarDetails tv of - MetaTv {} -> skolemiseUnboundMetaTyVar skol_info tv - - SkolemTv _ lvl _ -- It might be a skolem type variable, - -- for example from a user type signature - -- But it might also be a shared meta-variable across several - -- type declarations, each with its own skol_info. The first - -- will skolemise it, but the other uses must update its - -- skolem info (#22379) - -> do { kind <- zonkTcType (tyVarKind tv) - ; let details = SkolemTv skol_info lvl False - name = tyVarName tv - ; return (mkTcTyVar name kind details) } - - _other -> pprPanic "skolemiseQuantifiedTyVar" (ppr tv) -- RuntimeUnk - --- | Default a type variable using the given defaulting strategy. --- --- See Note [Type variable defaulting options] in GHC.Types.Basic. -defaultTyVar :: DefaultingStrategy - -> TcTyVar -- If it's a MetaTyVar then it is unbound - -> TcM Bool -- True <=> defaulted away altogether -defaultTyVar def_strat tv - | not (isMetaTyVar tv) - || isTyVarTyVar tv - -- Do not default TyVarTvs. Doing so would violate the invariants - -- on TyVarTvs; see Note [TyVarTv] in GHC.Tc.Utils.TcMType. - -- #13343 is an example; #14555 is another - -- See Note [Inferring kinds for type declarations] in GHC.Tc.TyCl - = return False - - | isRuntimeRepVar tv - , default_ns_vars - = do { traceTc "Defaulting a RuntimeRep var to LiftedRep" (ppr tv) - ; writeMetaTyVar tv liftedRepTy - ; return True } - | isLevityVar tv - , default_ns_vars - = do { traceTc "Defaulting a Levity var to Lifted" (ppr tv) - ; writeMetaTyVar tv liftedDataConTy - ; return True } - | isMultiplicityVar tv - , default_ns_vars - = do { traceTc "Defaulting a Multiplicity var to Many" (ppr tv) - ; writeMetaTyVar tv manyDataConTy - ; return True } - - | isConcreteTyVar tv - -- We don't want to quantify; but neither can we default to - -- anything sensible. (If it has kind RuntimeRep or Levity, as is - -- often the case, it'll have been caught earlier by earlier - -- cases. So in this exotic situation we just promote. Not very - -- satisfing, but it's very much a corner case: #23051) - -- We should really implement the plan in #20686. - = do { lvl <- getTcLevel - ; _ <- promoteMetaTyVarTo lvl tv - ; return True } - - | DefaultKindVars <- def_strat -- -XNoPolyKinds and this is a kind var: we must default it - = default_kind_var tv - - | otherwise - = return False - - where - default_ns_vars :: Bool - default_ns_vars = defaultNonStandardTyVars def_strat - default_kind_var :: TyVar -> TcM Bool - -- defaultKindVar is used exclusively with -XNoPolyKinds - -- See Note [Defaulting with -XNoPolyKinds] - -- It takes an (unconstrained) meta tyvar and defaults it. - -- Works only on vars of type *; for other kinds, it issues an error. - default_kind_var kv - | isLiftedTypeKind (tyVarKind kv) - = do { traceTc "Defaulting a kind var to *" (ppr kv) - ; writeMetaTyVar kv liftedTypeKind - ; return True } - | otherwise - = do { addErr $ mkTcRnUnknownMessage $ mkPlainError noHints $ - (vcat [ text "Cannot default kind variable" <+> quotes (ppr kv') - , text "of kind:" <+> ppr (tyVarKind kv') - , text "Perhaps enable PolyKinds or add a kind signature" ]) - -- 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 - -- Note [Recipe for checking a signature] - -- Otherwise we get level-number assertion failures. It doesn't matter much - -- 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: --- --- - 'RuntimeRep' tyvars default to 'LiftedRep' --- - 'Levity' tyvars default to 'Lifted' --- - 'Multiplicity' tyvars default to 'Many' --- - 'Type' tyvars from dv_kvs default to 'Type', when -XNoPolyKinds --- (under -XNoPolyKinds, non-defaulting vars in dv_kvs is an error) -defaultTyVars :: NonStandardDefaultingStrategy - -> CandidatesQTvs -- ^ all candidates for quantification - -> TcM [TcTyVar] -- ^ those variables not defaulted -defaultTyVars ns_strat dvs - = do { poly_kinds <- xoptM LangExt.PolyKinds - ; let - def_tvs, def_kvs :: DefaultingStrategy - def_tvs = NonStandardDefaulting ns_strat - def_kvs - | poly_kinds = def_tvs - | otherwise = DefaultKindVars - -- As -XNoPolyKinds precludes polymorphic kind variables, we default them. - -- For example: - -- - -- type F :: Type -> Type - -- type family F a where - -- F (a -> b) = b - -- - -- Here we get `a :: TYPE r`, so to accept this program when -XNoPolyKinds is enabled - -- we must default the kind variable `r :: RuntimeRep`. - -- Test case: T20584. - ; defaulted_kvs <- mapM (defaultTyVar def_kvs) dep_kvs - ; defaulted_tvs <- mapM (defaultTyVar def_tvs) nondep_tvs - ; let undefaulted_kvs = [ kv | (kv, False) <- dep_kvs `zip` defaulted_kvs ] - undefaulted_tvs = [ tv | (tv, False) <- nondep_tvs `zip` defaulted_tvs ] - ; return (undefaulted_kvs ++ undefaulted_tvs) } - -- NB: kvs before tvs because tvs may depend on kvs - where - (dep_kvs, nondep_tvs) = candidateVars dvs - -skolemiseUnboundMetaTyVar :: SkolemInfo -> TcTyVar -> TcM TyVar --- We have a Meta tyvar with a ref-cell inside it --- Skolemise it, so that we are totally out of Meta-tyvar-land --- We create a skolem TcTyVar, not a regular TyVar --- See Note [Zonking to Skolem] --- --- Its level should be one greater than the ambient level, which will typically --- be the same as the level on the meta-tyvar. But not invariably; for example --- f :: (forall a b. SameKind a b) -> Int --- The skolems 'a' and 'b' are bound by tcTKTelescope, at level 2; and they each --- have a level-2 kind unification variable, since it might get unified with another --- of the level-2 skolems e.g. 'k' in this version --- f :: (forall k (a :: k) b. SameKind a b) -> Int --- So when we quantify the kind vars at the top level of the signature, the ambient --- level is 1, but we will quantify over kappa[2]. - -skolemiseUnboundMetaTyVar skol_info tv - = assertPpr (isMetaTyVar tv) (ppr tv) $ - do { check_empty tv - ; tc_lvl <- getTcLevel -- Get the location and level from "here" - ; here <- getSrcSpanM -- i.e. where we are generalising - ; kind <- zonkTcType (tyVarKind tv) - ; let tv_name = tyVarName tv - -- See Note [Skolemising and identity] - final_name | isSystemName tv_name - = mkInternalName (nameUnique tv_name) - (nameOccName tv_name) here - | otherwise - = tv_name - details = SkolemTv skol_info (pushTcLevel tc_lvl) False - final_tv = mkTcTyVar final_name kind details - - ; traceTc "Skolemising" (ppr tv <+> text ":=" <+> ppr final_tv) - ; writeMetaTyVar tv (mkTyVarTy final_tv) - ; return final_tv } - where - check_empty tv -- [Sept 04] Check for non-empty. - = when debugIsOn $ -- See Note [Silly Type Synonyms] - do { cts <- readMetaTyVar tv - ; case cts of - Flexi -> return () - Indirect ty -> warnPprTrace True "skolemiseUnboundMetaTyVar" (ppr tv $$ ppr ty) $ - return () } - -{- Note [Error on unconstrained meta-variables] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - -* type C :: Type -> Type -> Constraint - class (forall a. a b ~ a c) => C b c - -* type T = forall a. Proxy a - -* data (forall a. a b ~ a c) => T b c - -* type instance F Int = Proxy Any - where Any :: forall k. k - -In the first three cases we will infer a :: Type -> kappa, but then -we get no further information on kappa. In the last, we will get - Proxy kappa Any -but again will get no further info on kappa. - -What do do? - A. We could choose kappa := Type. But this only works when the kind of kappa - is Type (true in this example, but not always). - B. We could default to Any. - C. We could quantify. - D. We could error. - -We choose (D), as described in #17567, and implement this choice in -doNotQuantifyTyVars. Discussion of alternativs A-C is below. - -NB: this is all rather similar to, but sadly not the same as - Note [Naughty quantification candidates] - -To do this, we must take an extra step before doing the final zonk to create -e.g. a TyCon. (There is no problem in the final term-level zonk. See the -section on alternative (B) below.) This extra step is needed only for -constructs that do not quantify their free meta-variables, such as a class -constraint or right-hand side of a type synonym. - -Specifically: before the final zonk, every construct must either call -quantifyTyVars or doNotQuantifyTyVars. The latter issues an error -if it is passed any free variables. (Exception: we still default -RuntimeRep and Multiplicity variables.) - -Because no meta-variables remain after quantifying or erroring, we perform -the zonk with NoFlexi, which panics upon seeing a meta-variable. - -Alternatives A-C, not implemented: - -A. As stated above, this works only sometimes. We might have a free - meta-variable of kind Nat, for example. - -B. This is what we used to do, but it caused Any to appear in error - messages sometimes. See #17567 for several examples. Defaulting to - Any during the final, whole-program zonk is OK, though, because - we are completely done type-checking at that point. No chance to - leak into an error message. - -C. Examine the class declaration at the top of this Note again. - Where should we quantify? We might imagine quantifying and - putting the kind variable in the forall of the quantified constraint. - But what if there are nested foralls? Which one should get the - variable? Other constructs have other problems. (For example, - the right-hand side of a type family instance equation may not - be a poly-type.) - - More broadly, the GHC AST defines a set of places where it performs - implicit lexical generalization. For example, in a type - signature - - f :: Proxy a -> Bool - - the otherwise-unbound a is lexically quantified, giving us - - f :: forall a. Proxy a -> Bool - - The places that allow lexical quantification are marked in the AST with - HsImplicitBndrs. HsImplicitBndrs offers a binding site for otherwise-unbound - variables. - - Later, during type-checking, we discover that a's kind is unconstrained. - We thus quantify *again*, to - - f :: forall {k} (a :: k). Proxy @k a -> Bool - - It is this second quantification that this Note is really about -- - let's call it *inferred quantification*. - So there are two sorts of implicit quantification in types: - 1. Lexical quantification: signalled by HsImplicitBndrs, occurs over - variables mentioned by the user but with no explicit binding site, - suppressed by a user-written forall (by the forall-or-nothing rule, - in Note [forall-or-nothing rule] in GHC.Hs.Type). - 2. Inferred quantification: no signal in HsSyn, occurs over unconstrained - variables invented by the type-checker, possible only with -XPolyKinds, - unaffected by forall-or-nothing rule - These two quantifications are performed in different compiler phases, and are - essentially unrelated. However, it is convenient - for programmers to remember only one set of implicit quantification - sites. So, we choose to use the same places (those with HsImplicitBndrs) - for lexical quantification as for inferred quantification of unconstrained - meta-variables. Accordingly, there is no quantification in a class - constraint, or the other constructs that call doNotQuantifyTyVars. --} - -doNotQuantifyTyVars :: CandidatesQTvs - -> (TidyEnv -> TcM (TidyEnv, SDoc)) - -- ^ like "the class context (D a b, E foogle)" - -> TcM () --- See Note [Error on unconstrained meta-variables] -doNotQuantifyTyVars dvs where_found - | isEmptyCandidates dvs - = traceTc "doNotQuantifyTyVars has nothing to error on" empty - - | otherwise - = do { traceTc "doNotQuantifyTyVars" (ppr dvs) - ; undefaulted <- defaultTyVars DefaultNonStandardTyVars dvs - -- could have regular TyVars here, in an associated type RHS, or - -- bound by a type declaration head. So filter looking only for - -- metavars. e.g. b and c in `class (forall a. a b ~ a c) => C b c` - -- are OK - ; let leftover_metas = filter isMetaTyVar undefaulted - ; unless (null leftover_metas) $ - do { let (tidy_env1, tidied_tvs) = tidyOpenTyCoVars emptyTidyEnv leftover_metas - ; (tidy_env2, where_doc) <- where_found tidy_env1 - ; let msg = mkTcRnUnknownMessage $ - mkPlainError noHints $ - pprWithExplicitKindsWhen True $ - vcat [ text "Uninferrable type variable" - <> plural tidied_tvs - <+> pprWithCommas pprTyVar tidied_tvs - <+> text "in" - , where_doc ] - ; failWithTcM (tidy_env2, msg) } - ; traceTc "doNotQuantifyTyVars success" empty } - -{- Note [Defaulting with -XNoPolyKinds] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - - data Compose f g a = Mk (f (g a)) - -We infer - - Compose :: forall k1 k2. (k2 -> *) -> (k1 -> k2) -> k1 -> * - Mk :: forall k1 k2 (f :: k2 -> *) (g :: k1 -> k2) (a :: k1). - f (g a) -> Compose k1 k2 f g a - -Now, in another module, we have -XNoPolyKinds -XDataKinds in effect. -What does 'Mk mean? Pre GHC-8.0 with -XNoPolyKinds, -we just defaulted all kind variables to *. But that's no good here, -because the kind variables in 'Mk aren't of kind *, so defaulting to * -is ill-kinded. - -After some debate on #11334, we decided to issue an error in this case. -The code is in defaultKindVar. - -Note [What is a meta variable?] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -A "meta type-variable", also know as a "unification variable" is a placeholder -introduced by the typechecker for an as-yet-unknown monotype. - -For example, when we see a call `reverse (f xs)`, we know that we calling - reverse :: forall a. [a] -> [a] -So we know that the argument `f xs` must be a "list of something". But what is -the "something"? We don't know until we explore the `f xs` a bit more. So we set -out what we do know at the call of `reverse` by instantiating its type with a fresh -meta tyvar, `alpha` say. So now the type of the argument `f xs`, and of the -result, is `[alpha]`. The unification variable `alpha` stands for the -as-yet-unknown type of the elements of the list. - -As type inference progresses we may learn more about `alpha`. For example, suppose -`f` has the type - f :: forall b. b -> [Maybe b] -Then we instantiate `f`'s type with another fresh unification variable, say -`beta`; and equate `f`'s result type with reverse's argument type, thus -`[alpha] ~ [Maybe beta]`. - -Now we can solve this equality to learn that `alpha ~ Maybe beta`, so we've -refined our knowledge about `alpha`. And so on. - -If you found this Note useful, you may also want to have a look at -Section 5 of "Practical type inference for higher rank types" (Peyton Jones, -Vytiniotis, Weirich and Shields. J. Functional Programming. 2011). - -Note [What is zonking?] -~~~~~~~~~~~~~~~~~~~~~~~ -GHC relies heavily on mutability in the typechecker for efficient operation. -For this reason, throughout much of the type checking process meta type -variables (the MetaTv constructor of TcTyVarDetails) are represented by mutable -variables (known as TcRefs). - -Zonking is the process of ripping out these mutable variables and replacing them -with a real Type. This involves traversing the entire type expression, but the -interesting part of replacing the mutable variables occurs in zonkTyVarOcc. - -There are two ways to zonk a Type: - - * zonkTcTypeToType, which is intended to be used at the end of type-checking - for the final zonk. It has to deal with unfilled metavars, either by filling - it with a value like Any or failing (determined by the UnboundTyVarZonker - used). - - * zonkTcType, which will happily ignore unfilled metavars. This is the - appropriate function to use while in the middle of type-checking. - -Note [Zonking to Skolem] -~~~~~~~~~~~~~~~~~~~~~~~~ -We used to zonk quantified type variables to regular TyVars. However, this -leads to problems. Consider this program from the regression test suite: - - eval :: Int -> String -> String -> String - eval 0 root actual = evalRHS 0 root actual - - evalRHS :: Int -> a - evalRHS 0 root actual = eval 0 root actual - -It leads to the deferral of an equality (wrapped in an implication constraint) - - forall a. () => ((String -> String -> String) ~ a) - -which is propagated up to the toplevel (see GHC.Tc.Solver.tcSimplifyInferCheck). -In the meantime `a' is zonked and quantified to form `evalRHS's signature. -This has the *side effect* of also zonking the `a' in the deferred equality -(which at this point is being handed around wrapped in an implication -constraint). - -Finally, the equality (with the zonked `a') will be handed back to the -simplifier by GHC.Tc.Module.tcRnSrcDecls calling GHC.Tc.Solver.tcSimplifyTop. -If we zonk `a' with a regular type variable, we will have this regular type -variable now floating around in the simplifier, which in many places assumes to -only see proper TcTyVars. - -We can avoid this problem by zonking with a skolem TcTyVar. The -skolem is rigid (which we require for a quantified variable), but is -still a TcTyVar that the simplifier knows how to deal with. - -Note [Skolemising and identity] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In some places, we make a TyVarTv for a binder. E.g. - class C a where ... -As Note [Inferring kinds for type declarations] discusses, -we make a TyVarTv for 'a'. Later we skolemise it, and we'd -like to retain its identity, location info etc. (If we don't -retain its identity we'll have to do some pointless swizzling; -see GHC.Tc.TyCl.swizzleTcTyConBndrs. If we retain its identity -but not its location we'll lose the detailed binding site info. - -Conclusion: use the Name of the TyVarTv. But we don't want -to do that when skolemising random unification variables; -there the location we want is the skolemisation site. - -Fortunately we can tell the difference: random unification -variables have System Names. That's why final_name is -set based on the isSystemName test. - - -Note [Silly Type Synonyms] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider this: - type C u a = u -- Note 'a' unused - - foo :: (forall a. C u a -> C u a) -> u - foo x = ... - - bar :: Num u => u - bar = foo (\t -> t + t) - -* From the (\t -> t+t) we get type {Num d} => d -> d - where d is fresh. - -* Now unify with type of foo's arg, and we get: - {Num (C d a)} => C d a -> C d a - where a is fresh. - -* Now abstract over the 'a', but float out the Num (C d a) constraint - because it does not 'really' mention a. (see exactTyVarsOfType) - The arg to foo becomes - \/\a -> \t -> t+t - -* So we get a dict binding for Num (C d a), which is zonked to give - a = () - Note (Sept 04): now that we are zonking quantified type variables - on construction, the 'a' will be frozen as a regular tyvar on - quantification, so the floated dict will still have type (C d a). - Which renders this whole note moot; happily!] - -* Then the \/\a abstraction has a zonked 'a' in it. - -All very silly. I think its harmless to ignore the problem. We'll end up with -a \/\a in the final result but all the occurrences of a will be zonked to () --} - -{- ********************************************************************* -* * - Promotion -* * -********************************************************************* -} - -promoteMetaTyVarTo :: HasDebugCallStack => TcLevel -> TcTyVar -> TcM Bool --- When we float a constraint out of an implication we must restore --- 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] -promoteMetaTyVarTo tclvl tv - | assertPpr (isMetaTyVar tv) (ppr tv) $ - tcTyVarLevel tv `strictlyDeeperThan` tclvl - = do { cloned_tv <- cloneMetaTyVar tv - ; let rhs_tv = setMetaTyVarTcLevel cloned_tv tclvl - ; writeMetaTyVar tv (mkTyVarTy rhs_tv) - ; traceTc "promoteTyVar" (ppr tv <+> text "-->" <+> ppr rhs_tv) - ; return True } - | otherwise - = return False - --- Returns whether or not *any* tyvar is defaulted -promoteTyVarSet :: HasDebugCallStack => TcTyVarSet -> TcM Bool -promoteTyVarSet tvs - = do { tclvl <- getTcLevel - ; bools <- mapM (promoteMetaTyVarTo tclvl) $ - filter isPromotableMetaTyVar $ - nonDetEltsUniqSet tvs - -- Non-determinism is OK because order of promotion doesn't matter - ; return (or bools) } - - -{- ********************************************************************* -* * - Zonking types -* * -********************************************************************* -} - -zonkTcTypeAndFV :: TcType -> TcM DTyCoVarSet --- Zonk a type and take its free variables --- With kind polymorphism it can be essential to zonk *first* --- so that we find the right set of free variables. Eg --- forall k1. forall (a:k2). a --- where k2:=k1 is in the substitution. We don't want --- k2 to look free in this type! -zonkTcTypeAndFV ty - = tyCoVarsOfTypeDSet <$> zonkTcType ty - -zonkTyCoVar :: TyCoVar -> TcM TcType --- Works on TyVars and TcTyVars -zonkTyCoVar tv | isTcTyVar tv = zonkTcTyVar tv - | isTyVar tv = mkTyVarTy <$> zonkTyCoVarKind tv - | otherwise = assertPpr (isCoVar tv) (ppr tv) $ - mkCoercionTy . mkCoVarCo <$> zonkTyCoVarKind tv - -- Hackily, when typechecking type and class decls - -- we have TyVars in scope added (only) in - -- GHC.Tc.Gen.HsType.bindTyClTyVars, but it seems - -- painful to make them into TcTyVars there - -zonkTyCoVarsAndFV :: TyCoVarSet -> TcM TyCoVarSet -zonkTyCoVarsAndFV tycovars - = tyCoVarsOfTypes <$> mapM zonkTyCoVar (nonDetEltsUniqSet tycovars) - -- It's OK to use nonDetEltsUniqSet here because we immediately forget about - -- the ordering by turning it into a nondeterministic set and the order - -- of zonking doesn't matter for determinism. - -zonkDTyCoVarSetAndFV :: DTyCoVarSet -> TcM DTyCoVarSet -zonkDTyCoVarSetAndFV tycovars - = mkDVarSet <$> (zonkTyCoVarsAndFVList $ dVarSetElems tycovars) - --- Takes a list of TyCoVars, zonks them and returns a --- deterministically ordered list of their free variables. -zonkTyCoVarsAndFVList :: [TyCoVar] -> TcM [TyCoVar] -zonkTyCoVarsAndFVList tycovars - = tyCoVarsOfTypesList <$> mapM zonkTyCoVar tycovars - -zonkTcTyVars :: [TcTyVar] -> TcM [TcType] -zonkTcTyVars tyvars = mapM zonkTcTyVar tyvars - ------------------ Types -zonkTyCoVarKind :: TyCoVar -> TcM TyCoVar -zonkTyCoVarKind tv = do { kind' <- zonkTcType (tyVarKind tv) - ; return (setTyVarKind tv kind') } - -{- -************************************************************************ -* * - Zonking constraints -* * -************************************************************************ --} - -zonkImplication :: Implication -> TcM Implication -zonkImplication implic@(Implic { ic_skols = skols - , ic_given = given - , ic_wanted = wanted - , ic_info = info }) - = do { skols' <- mapM zonkTyCoVarKind skols -- Need to zonk their kinds! - -- as #7230 showed - ; given' <- mapM zonkEvVar given - ; info' <- zonkSkolemInfoAnon info - ; wanted' <- zonkWCRec wanted - ; return (implic { ic_skols = skols' - , ic_given = given' - , ic_wanted = wanted' - , ic_info = info' }) } - -zonkEvVar :: EvVar -> TcM EvVar -zonkEvVar var = updateIdTypeAndMultM zonkTcType var - - -zonkWC :: WantedConstraints -> TcM WantedConstraints -zonkWC wc = zonkWCRec wc - -zonkWCRec :: WantedConstraints -> TcM WantedConstraints -zonkWCRec (WC { wc_simple = simple, wc_impl = implic, wc_errors = errs }) - = do { simple' <- zonkSimples simple - ; implic' <- mapBagM zonkImplication implic - ; errs' <- mapBagM zonkDelayedError errs - ; return (WC { wc_simple = simple', wc_impl = implic', wc_errors = errs' }) } - -zonkSimples :: Cts -> TcM Cts -zonkSimples cts = do { cts' <- mapBagM zonkCt cts - ; traceTc "zonkSimples done:" (ppr cts') - ; return cts' } - -zonkDelayedError :: DelayedError -> TcM DelayedError -zonkDelayedError (DE_Hole hole) - = DE_Hole <$> zonkHole hole -zonkDelayedError (DE_NotConcrete err) - = DE_NotConcrete <$> zonkNotConcreteError err - -zonkHole :: Hole -> TcM Hole -zonkHole hole@(Hole { hole_ty = ty }) - = do { ty' <- zonkTcType ty - ; return (hole { hole_ty = ty' }) } - -zonkNotConcreteError :: NotConcreteError -> TcM NotConcreteError -zonkNotConcreteError err@(NCE_FRR { nce_frr_origin = frr_orig }) - = do { frr_orig <- zonkFRROrigin frr_orig - ; return $ err { nce_frr_origin = frr_orig } } - -zonkFRROrigin :: FixedRuntimeRepOrigin -> TcM FixedRuntimeRepOrigin -zonkFRROrigin (FixedRuntimeRepOrigin ty orig) - = do { ty' <- zonkTcType ty - ; return $ FixedRuntimeRepOrigin ty' orig } - -{- Note [zonkCt behaviour] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -zonkCt tries to maintain the canonical form of a Ct. For example, - - a CDictCan should stay a CDictCan; - - a CIrredCan should stay a CIrredCan with its cc_reason flag intact - -Why?, for example: -- For CDictCan, the @GHC.Tc.Solver.expandSuperClasses@ step, which runs after the - simple wanted and plugin loop, looks for @CDictCan@s. If a plugin is in use, - constraints are zonked before being passed to the plugin. This means if we - don't preserve a canonical form, @expandSuperClasses@ fails to expand - superclasses. This is what happened in #11525. - -- For CIrredCan we want to see if a constraint is insoluble with insolubleWC - -On the other hand, we change CEqCan to CNonCanonical, because of all of -CEqCan's invariants, which can break during zonking. (Example: a ~R alpha, where -we have alpha := N Int, where N is a newtype.) Besides, the constraint -will be canonicalised again, so there is little benefit in keeping the -CEqCan structure. - -NB: Constraints are always rewritten etc by the canonicaliser in -@GHC.Tc.Solver.Canonical@ even if they come in as CDictCan. Only canonical constraints that -are actually in the inert set carry all the guarantees. So it is okay if zonkCt -creates e.g. a CDictCan where the cc_tyars are /not/ fully reduced. --} - -zonkCt :: Ct -> TcM Ct --- See Note [zonkCt behaviour] -zonkCt ct@(CDictCan { cc_ev = ev, cc_tyargs = args }) - = do { ev' <- zonkCtEvidence ev - ; args' <- mapM zonkTcType args - ; return $ ct { cc_ev = ev', cc_tyargs = args' } } - -zonkCt (CEqCan { cc_ev = ev }) - = mkNonCanonical <$> zonkCtEvidence ev - -zonkCt ct@(CIrredCan { cc_ev = ev }) -- Preserve the cc_reason flag - = do { ev' <- zonkCtEvidence ev - ; return (ct { cc_ev = ev' }) } - -zonkCt ct - = do { fl' <- zonkCtEvidence (ctEvidence ct) - ; return (mkNonCanonical fl') } - -zonkCtEvidence :: CtEvidence -> TcM CtEvidence -zonkCtEvidence ctev - = do { pred' <- zonkTcType (ctev_pred ctev) - ; return (setCtEvPredType ctev pred') - } - -zonkSkolemInfo :: SkolemInfo -> TcM SkolemInfo -zonkSkolemInfo (SkolemInfo u sk) = SkolemInfo u <$> zonkSkolemInfoAnon sk - -zonkSkolemInfoAnon :: SkolemInfoAnon -> TcM SkolemInfoAnon -zonkSkolemInfoAnon (SigSkol cx ty tv_prs) = do { ty' <- zonkTcType ty - ; return (SigSkol cx ty' tv_prs) } -zonkSkolemInfoAnon (InferSkol ntys) = do { ntys' <- mapM do_one ntys - ; return (InferSkol ntys') } - where - do_one (n, ty) = do { ty' <- zonkTcType ty; return (n, ty') } -zonkSkolemInfoAnon skol_info = return skol_info - -{- -************************************************************************ -* * - Zonking -- the main work-horses: zonkTcType, zonkTcTyVar -* * -************************************************************************ --} - --- 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 -zonkTcType :: TcType -> TcM TcType -zonkTcTypes :: [TcType] -> TcM [TcType] -zonkCo :: Coercion -> TcM Coercion - -(zonkTcType, zonkTcTypes, zonkCo, _) - = mapTyCo zonkTcTypeMapper - --- | A suitable TyCoMapper for zonking a type during type-checking, --- before all metavars are filled in. -zonkTcTypeMapper :: TyCoMapper () TcM -zonkTcTypeMapper = TyCoMapper - { tcm_tyvar = const zonkTcTyVar - , tcm_covar = const (\cv -> mkCoVarCo <$> zonkTyCoVarKind cv) - , tcm_hole = hole - , tcm_tycobinder = \_env tv _vis -> ((), ) <$> zonkTyCoVarKind tv - , tcm_tycon = zonkTcTyCon } - where - hole :: () -> CoercionHole -> TcM 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 -> TcM TcTyCon --- Only called on TcTyCons --- A non-poly TcTyCon may have unification --- variables that need zonking, but poly ones cannot -zonkTcTyCon tc - | isMonoTcTyCon tc = do { tck' <- zonkTcType (tyConKind tc) - ; return (setTcTyConKind tc tck') } - | otherwise = return tc - -zonkTcTyVar :: TcTyVar -> TcM TcType --- Simply look through all Flexis -zonkTcTyVar tv - | isTcTyVar tv - = case tcTyVarDetails tv of - SkolemTv {} -> zonk_kind_and_return - RuntimeUnk {} -> zonk_kind_and_return - MetaTv { mtv_ref = ref } - -> do { cts <- readMutVar ref - ; case cts of - Flexi -> zonk_kind_and_return - Indirect ty -> do { zty <- zonkTcType ty - ; writeTcRef ref (Indirect zty) - -- See Note [Sharing in zonking] - ; return zty } } - - | otherwise -- coercion variable - = zonk_kind_and_return - where - zonk_kind_and_return = do { z_tv <- zonkTyCoVarKind tv - ; return (mkTyVarTy z_tv) } - --- Variant that assumes that any result of zonking is still a TyVar. --- Should be used only on skolems and TyVarTvs -zonkTcTyVarsToTcTyVars :: HasDebugCallStack => [TcTyVar] -> TcM [TcTyVar] -zonkTcTyVarsToTcTyVars = mapM zonkTcTyVarToTcTyVar - -zonkTcTyVarToTcTyVar :: HasDebugCallStack => TcTyVar -> TcM TcTyVar -zonkTcTyVarToTcTyVar tv - = do { ty <- zonkTcTyVar tv - ; let tv' = case getTyVar_maybe ty of - Just tv' -> tv' - Nothing -> pprPanic "zonkTcTyVarToTcTyVar" - (ppr tv $$ ppr ty) - ; return tv' } - -zonkInvisTVBinder :: VarBndr TcTyVar spec -> TcM (VarBndr TcTyVar spec) -zonkInvisTVBinder (Bndr tv spec) = do { tv' <- zonkTcTyVarToTcTyVar tv - ; return (Bndr tv' spec) } - --- zonkId is used *during* typechecking just to zonk the Id's type -zonkId :: TcId -> TcM TcId -zonkId id = Id.updateIdTypeAndMultM zonkTcType id - -zonkCoVar :: CoVar -> TcM CoVar -zonkCoVar = zonkId - -{- Note [Sharing in zonking] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose we have - alpha :-> beta :-> gamma :-> ty -where the ":->" means that the unification variable has been -filled in with Indirect. Then when zonking alpha, it'd be nice -to short-circuit beta too, so we end up with - alpha :-> zty - beta :-> zty - gamma :-> zty -where zty is the zonked version of ty. That way, if we come across -beta later, we'll have less work to do. (And indeed the same for -alpha.) - -This is easily achieved: just overwrite (Indirect ty) with (Indirect -zty). Non-systematic perf comparisons suggest that this is a modest -win. - -But c.f Note [Sharing when zonking to Type] in GHC.Tc.Utils.Zonk. - -%************************************************************************ -%* * - Tidying -* * -************************************************************************ --} - -zonkTidyTcType :: TidyEnv -> TcType -> TcM (TidyEnv, TcType) -zonkTidyTcType env ty = do { ty' <- zonkTcType ty - ; return (tidyOpenType env ty') } - -zonkTidyTcTypes :: TidyEnv -> [TcType] -> TcM (TidyEnv, [TcType]) -zonkTidyTcTypes = zonkTidyTcTypes' [] - where zonkTidyTcTypes' zs env [] = return (env, reverse zs) - zonkTidyTcTypes' zs env (ty:tys) - = do { (env', ty') <- zonkTidyTcType env ty - ; zonkTidyTcTypes' (ty':zs) env' tys } - -zonkTidyOrigin :: TidyEnv -> CtOrigin -> TcM (TidyEnv, CtOrigin) -zonkTidyOrigin env (GivenOrigin skol_info) - = do { skol_info1 <- zonkSkolemInfoAnon skol_info - ; let skol_info2 = tidySkolemInfoAnon env skol_info1 - ; return (env, GivenOrigin skol_info2) } -zonkTidyOrigin env (GivenSCOrigin skol_info sc_depth blocked) - = do { skol_info1 <- zonkSkolemInfoAnon skol_info - ; let skol_info2 = tidySkolemInfoAnon env skol_info1 - ; return (env, GivenSCOrigin skol_info2 sc_depth blocked) } -zonkTidyOrigin env orig@(TypeEqOrigin { uo_actual = act - , uo_expected = exp }) - = do { (env1, act') <- zonkTidyTcType env act - ; (env2, exp') <- zonkTidyTcType env1 exp - ; return ( env2, orig { uo_actual = act' - , uo_expected = exp' }) } -zonkTidyOrigin env (KindEqOrigin ty1 ty2 orig t_or_k) - = do { (env1, ty1') <- zonkTidyTcType env ty1 - ; (env2, ty2') <- zonkTidyTcType env1 ty2 - ; (env3, orig') <- zonkTidyOrigin env2 orig - ; return (env3, KindEqOrigin ty1' ty2' orig' t_or_k) } -zonkTidyOrigin env (FunDepOrigin1 p1 o1 l1 p2 o2 l2) - = do { (env1, p1') <- zonkTidyTcType env p1 - ; (env2, o1') <- zonkTidyOrigin env1 o1 - ; (env3, p2') <- zonkTidyTcType env2 p2 - ; (env4, o2') <- zonkTidyOrigin env3 o2 - ; return (env4, FunDepOrigin1 p1' o1' l1 p2' o2' l2) } -zonkTidyOrigin env (FunDepOrigin2 p1 o1 p2 l2) - = do { (env1, p1') <- zonkTidyTcType env p1 - ; (env2, p2') <- zonkTidyTcType env1 p2 - ; (env3, o1') <- zonkTidyOrigin env2 o1 - ; return (env3, FunDepOrigin2 p1' o1' p2' l2) } -zonkTidyOrigin env (InjTFOrigin1 pred1 orig1 loc1 pred2 orig2 loc2) - = do { (env1, pred1') <- zonkTidyTcType env pred1 - ; (env2, orig1') <- zonkTidyOrigin env1 orig1 - ; (env3, pred2') <- zonkTidyTcType env2 pred2 - ; (env4, orig2') <- zonkTidyOrigin env3 orig2 - ; return (env4, InjTFOrigin1 pred1' orig1' loc1 pred2' orig2' loc2) } -zonkTidyOrigin env (CycleBreakerOrigin orig) - = do { (env1, orig') <- zonkTidyOrigin env orig - ; return (env1, CycleBreakerOrigin orig') } -zonkTidyOrigin env (InstProvidedOrigin mod cls_inst) - = do { (env1, is_tys') <- mapAccumLM zonkTidyTcType env (is_tys cls_inst) - ; return (env1, InstProvidedOrigin mod (cls_inst {is_tys = is_tys'})) } -zonkTidyOrigin env (WantedSuperclassOrigin pty orig) - = do { (env1, pty') <- zonkTidyTcType env pty - ; (env2, orig') <- zonkTidyOrigin env1 orig - ; return (env2, WantedSuperclassOrigin pty' orig') } -zonkTidyOrigin env orig = return (env, orig) - -zonkTidyOrigins :: TidyEnv -> [CtOrigin] -> TcM (TidyEnv, [CtOrigin]) -zonkTidyOrigins = mapAccumLM zonkTidyOrigin - -zonkTidyFRRInfos :: TidyEnv - -> [FixedRuntimeRepErrorInfo] - -> TcM (TidyEnv, [FixedRuntimeRepErrorInfo]) -zonkTidyFRRInfos = go [] - 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) - = do { (env, ty) <- zonkTidyTcType env ty - ; (env, mb_not_conc) <- go_mb_not_conc env mb_not_conc - ; let info = FRR_Info { frr_info_origin = FixedRuntimeRepOrigin ty orig - , frr_info_not_concrete = mb_not_conc } - ; 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 - ; (env, ty) <- zonkTidyTcType env ty - ; return (env, Just (tv, ty)) } - ----------------- -tidyCt :: TidyEnv -> Ct -> Ct --- Used only in error reporting -tidyCt env ct = ct { cc_ev = tidyCtEvidence env (ctEvidence ct) } - -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 - -tidyHole :: TidyEnv -> Hole -> Hole -tidyHole env h@(Hole { hole_ty = ty }) = h { hole_ty = tidyType env ty } - -tidyDelayedError :: TidyEnv -> DelayedError -> DelayedError -tidyDelayedError env (DE_Hole hole) - = DE_Hole $ tidyHole env hole -tidyDelayedError env (DE_NotConcrete err) - = DE_NotConcrete $ tidyConcreteError env err - -tidyConcreteError :: TidyEnv -> NotConcreteError -> NotConcreteError -tidyConcreteError env err@(NCE_FRR { nce_frr_origin = frr_orig }) - = err { nce_frr_origin = tidyFRROrigin env frr_orig } - -tidyFRROrigin :: TidyEnv -> FixedRuntimeRepOrigin -> FixedRuntimeRepOrigin -tidyFRROrigin env (FixedRuntimeRepOrigin ty orig) - = FixedRuntimeRepOrigin (tidyType env ty) orig - ----------------- -tidyEvVar :: TidyEnv -> EvVar -> EvVar -tidyEvVar env var = updateIdTypeAndMult (tidyType env) var - - -------------------------------------------------------------------------- -{- -%************************************************************************ -%* * - Representation polymorphism checks -* * -***********************************************************************-} - --- | Check that the specified type has a fixed runtime representation. --- --- If it isn't, throw a representation-polymorphism error appropriate --- for the context (as specified by the 'FixedRuntimeRepProvenance'). --- --- Unlike the other representation polymorphism checks, which can emit --- new Wanted constraints to be solved by the constraint solver, this function --- does not emit any constraints: it has enough information to immediately --- make a decision. --- --- See (1) in Note [Representation polymorphism checking] in GHC.Tc.Utils.Concrete -checkTypeHasFixedRuntimeRep :: FixedRuntimeRepProvenance -> Type -> TcM () -checkTypeHasFixedRuntimeRep prov ty = - unless (typeHasFixedRuntimeRep ty) - (addDetailedDiagnostic $ TcRnTypeDoesNotHaveFixedRuntimeRep ty prov) - -{- -%************************************************************************ -%* * - Error messages -* * -************************************************************************* - --} - --- See Note [Naughty quantification candidates] -naughtyQuantification :: TcType -- original type user wanted to quantify - -> TcTyVar -- naughty var - -> TyVarSet -- skolems that would escape - -> TcM a -naughtyQuantification orig_ty tv escapees - = do { orig_ty1 <- zonkTcType orig_ty -- in case it's not zonked - - ; escapees' <- zonkTcTyVarsToTcTyVars $ - nonDetEltsUniqSet escapees - -- we'll just be printing, so no harmful non-determinism - - ; let fvs = tyCoVarsOfTypeWellScoped orig_ty1 - env0 = tidyFreeTyCoVars emptyTidyEnv fvs - env = env0 `delTidyEnvList` escapees' - -- this avoids gratuitous renaming of the escaped - -- variables; very confusing to users! - - orig_ty' = tidyType env orig_ty1 - ppr_tidied = pprTyVars . map (tidyTyCoVarOcc env) - msg = mkTcRnUnknownMessage $ mkPlainError noHints $ - pprWithExplicitKindsWhen True $ - vcat [ sep [ text "Cannot generalise type; skolem" <> plural escapees' - , quotes $ ppr_tidied escapees' - , text "would escape" <+> itsOrTheir escapees' <+> text "scope" - ] - , sep [ text "if I tried to quantify" - , ppr_tidied [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.)" - ] - - ; failWithTcM (env, msg) } - -{- -************************************************************************ -* * - Checking for coercion holes -* * -************************************************************************ --} - --- | 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. -anyUnfilledCoercionHoles :: RewriterSet -> TcM Bool -anyUnfilledCoercionHoles (RewriterSet set) - = nonDetStrictFoldUniqSet go (return False) 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 Bool -> TcM Bool - go hole m_acc = m_acc <||> check_hole hole - - check_hole :: CoercionHole -> TcM Bool - check_hole hole = do { m_co <- unpackCoercionHole_maybe hole - ; case m_co of - Nothing -> return True -- unfilled 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 Bool } - -instance Semigroup UnfilledCoercionHoleMonoid where - UCHM l <> UCHM r = UCHM (l <||> r) - -instance Monoid UnfilledCoercionHoleMonoid where - mempty = UCHM (return False) +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE RecursiveDo #-} +{-# LANGUAGE TupleSections #-} + +{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + +-} + +-- | Monadic type operations +-- +-- This module contains monadic operations over types that contain mutable type +-- variables. +module GHC.Tc.Utils.TcMType ( + TcTyVar, TcKind, TcType, TcTauType, TcThetaType, TcTyVarSet, + + -------------------------------- + -- Creating new mutable type variables + newFlexiTyVar, + newNamedFlexiTyVar, + newFlexiTyVarTy, -- Kind -> TcM TcType + newFlexiTyVarTys, -- Int -> Kind -> TcM [TcType] + newOpenFlexiTyVar, newOpenFlexiTyVarTy, newOpenTypeKind, + newOpenFlexiFRRTyVar, newOpenFlexiFRRTyVarTy, + newOpenBoxedTypeKind, + newMetaKindVar, newMetaKindVars, + newMetaTyVarTyAtLevel, newConcreteTyVarTyAtLevel, substConcreteTvOrigin, + newAnonMetaTyVar, newConcreteTyVar, + cloneMetaTyVar, cloneMetaTyVarWithInfo, + newCycleBreakerTyVar, + + newMultiplicityVar, + readMetaTyVar, writeMetaTyVar, writeMetaTyVarRef, + newTauTvDetailsAtLevel, newMetaDetails, newMetaTyVarName, + isFilledMetaTyVar_maybe, isFilledMetaTyVar, isUnfilledMetaTyVar, + + -------------------------------- + -- Creating new evidence variables + newEvVar, newEvVars, newDict, + newWantedWithLoc, newWanted, newWanteds, cloneWanted, cloneWC, cloneWantedCtEv, + emitWanted, emitWantedEq, emitWantedEvVar, + emitWantedEqs, + newTcEvBinds, newNoTcEvBinds, addTcEvBind, + emitNewExprHole, + + newCoercionHole, + fillCoercionHole, isFilledCoercionHole, + checkCoercionHole, + + newImplication, + + -------------------------------- + -- Instantiation + newMetaTyVars, newMetaTyVarX, newMetaTyVarsX, newMetaTyVarBndrsX, + newMetaTyVarTyVarX, + newTyVarTyVar, cloneTyVarTyVar, + newConcreteTyVarX, + newPatTyVar, newSkolemTyVar, newWildCardX, + + -------------------------------- + -- Expected types + ExpType(..), ExpSigmaType, ExpRhoType, + mkCheckExpType, newInferExpType, newInferExpTypeFRR, + runInfer, runInferRho, runInferSigma, runInferKind, runInferRhoFRR, runInferSigmaFRR, + readExpType, readExpType_maybe, readScaledExpType, + expTypeToType, scaledExpTypeToType, + checkingExpType_maybe, checkingExpType, + inferResultToType, ensureMonoType, promoteTcType, + + -------------------------------- + -- Multiplicity usage environment + tcCheckUsage, + + --------------------------------- + -- Promotion, defaulting, skolemisation + defaultTyVar, promoteMetaTyVarTo, promoteTyVarSet, + quantifyTyVars, doNotQuantifyTyVars, + zonkAndSkolemise, skolemiseQuantifiedTyVar, + + candidateQTyVarsOfType, candidateQTyVarsOfKind, + candidateQTyVarsOfTypes, candidateQTyVarsOfKinds, + candidateQTyVarsWithBinders, weedOutCandidates, + CandidatesQTvs(..), delCandidates, + candidateKindVars, partitionCandidates, + + ------------------------------ + -- Representation polymorphism + checkTypeHasFixedRuntimeRep, + + -- * Other HsSyn functions + mkHsDictLet, mkHsApp, + mkHsAppTy, mkHsCaseAlt, + tcShortCutLit, shortCutLit, hsOverLitName, + conLikeResTy + ) where + +import GHC.Prelude + +import GHC.Hs +import GHC.Platform + +import GHC.Driver.DynFlags +import qualified GHC.LanguageExtensions as LangExt + +import {-# SOURCE #-} GHC.Tc.Utils.Unify( unifyInvisibleType, tcSubMult ) +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.TcType + +import GHC.Builtin.Names + +import GHC.Core.ConLike +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 +import GHC.Core.Class +import GHC.Core.Predicate +import GHC.Core.UsageEnv + +import GHC.Types.Var +import GHC.Types.Id as Id +import GHC.Types.Name +import GHC.Types.SourceText +import GHC.Types.Var.Set + +import GHC.Builtin.Types +import GHC.Types.Var.Env +import GHC.Types.Unique.Set +import GHC.Types.Basic ( TypeOrKind(..) + , NonStandardDefaultingStrategy(..) + , DefaultingStrategy(..), defaultNonStandardTyVars ) + +import GHC.Data.FastString +import GHC.Data.Bag + +import GHC.Utils.Misc +import GHC.Utils.Outputable +import GHC.Utils.Panic +import GHC.Utils.Constants (debugIsOn) + +import Control.Monad +import Data.IORef +import GHC.Data.Maybe +import qualified Data.Semigroup as Semi +import GHC.Types.Name.Reader + +{- +************************************************************************ +* * + Kind variables +* * +************************************************************************ +-} + +newMetaKindVar :: TcM TcKind +newMetaKindVar + = do { details <- newMetaDetails TauTv + ; name <- newMetaTyVarName (fsLit "k") + -- All MetaKindVars are called "k" + -- They may be jiggled by tidying + ; let kv = mkTcTyVar name liftedTypeKind details + ; traceTc "newMetaKindVar" (ppr kv) + ; return (mkTyVarTy kv) } + +newMetaKindVars :: Int -> TcM [TcKind] +newMetaKindVars n = replicateM n newMetaKindVar + +{- +************************************************************************ +* * + Evidence variables; range over constraints we can abstract over +* * +************************************************************************ +-} + +newEvVars :: TcThetaType -> TcM [EvVar] +newEvVars theta = mapM newEvVar theta + +-------------- + +newEvVar :: TcPredType -> TcRnIf gbl lcl EvVar +-- Creates new *rigid* variables for predicates +newEvVar ty = do { name <- newSysName (predTypeOccName ty) + ; return (mkLocalIdOrCoVar name ManyTy ty) } + +-- | Create a new Wanted constraint with the given 'CtLoc'. +newWantedWithLoc :: CtLoc -> PredType -> TcM CtEvidence +newWantedWithLoc loc pty + = do dst <- case classifyPredType pty of + EqPred {} -> HoleDest <$> newCoercionHole pty + _ -> EvVarDest <$> newEvVar pty + 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. +newWanted :: CtOrigin -> Maybe TypeOrKind -> PredType -> TcM CtEvidence +-- Deals with both equality and non-equality predicates +newWanted orig t_or_k pty + = do loc <- getCtLocM orig t_or_k + newWantedWithLoc loc pty + +-- | Create new Wanted constraints with the given 'CtOrigin', +-- and location information taken from the 'TcM' environment. +newWanteds :: CtOrigin -> ThetaType -> TcM [CtEvidence] +newWanteds orig = mapM (newWanted orig Nothing) + +---------------------------------------------- +-- Cloning constraints +---------------------------------------------- + +cloneWantedCtEv :: CtEvidence -> TcM CtEvidence +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 + +cloneWanted :: Ct -> TcM Ct +cloneWanted ct = mkNonCanonical <$> cloneWantedCtEv (ctEvidence ct) + +cloneWC :: WantedConstraints -> TcM WantedConstraints +-- Clone all the evidence bindings in +-- a) the ic_bind field of any implications +-- b) the CoercionHoles of any wanted constraints +-- so that solving the WantedConstraints will not have any visible side +-- effect, /except/ from causing unifications +cloneWC wc@(WC { wc_simple = simples, wc_impl = implics }) + = do { simples' <- mapBagM cloneWanted simples + ; implics' <- mapBagM cloneImplication implics + ; return (wc { wc_simple = simples', wc_impl = implics' }) } + +cloneImplication :: Implication -> TcM Implication +cloneImplication implic@(Implic { ic_binds = binds, ic_wanted = inner_wanted }) + = do { binds' <- cloneEvBindsVar binds + ; inner_wanted' <- cloneWC inner_wanted + ; return (implic { ic_binds = binds', ic_wanted = inner_wanted' }) } + +---------------------------------------------- +-- Emitting constraints +---------------------------------------------- + +-- | Emits a new Wanted. Deals with both equalities and non-equalities. +emitWanted :: CtOrigin -> TcPredType -> TcM EvTerm +emitWanted origin pty + = do { ev <- newWanted origin Nothing pty + ; emitSimple $ mkNonCanonical ev + ; return $ ctEvTerm ev } + +emitWantedEqs :: CtOrigin -> [(TcType,TcType)] -> TcM () +-- Emit some new wanted nominal equalities +emitWantedEqs origin pairs + | null pairs + = return () + | otherwise + = mapM_ (uncurry (emitWantedEq origin TypeLevel Nominal)) pairs + +-- | Emits a new equality constraint +emitWantedEq :: CtOrigin -> TypeOrKind -> Role -> TcType -> TcType -> TcM Coercion +emitWantedEq origin t_or_k role ty1 ty2 + = do { hole <- newCoercionHole pty + ; loc <- getCtLocM origin (Just t_or_k) + ; emitSimple $ mkNonCanonical $ CtWanted $ + WantedCt { ctev_pred = pty + , ctev_dest = HoleDest hole + , ctev_loc = loc + , ctev_rewriters = emptyRewriterSet } + ; return (HoleCo hole) } + where + pty = mkEqPredRole role ty1 ty2 + +-- | Creates a new EvVar and immediately emits it as a Wanted. +-- No equality predicates here. +emitWantedEvVar :: CtOrigin -> TcPredType -> TcM EvVar +emitWantedEvVar origin ty + = do { new_cv <- newEvVar ty + ; loc <- getCtLocM origin Nothing + ; let ctev = WantedCt { ctev_pred = ty + , ctev_dest = EvVarDest new_cv + , ctev_loc = loc + , ctev_rewriters = emptyRewriterSet } + ; emitSimple $ mkNonCanonical $ CtWanted ctev + ; return new_cv } + +-- | Emit a new wanted expression hole +emitNewExprHole :: RdrName -- of the hole + -> Type -> TcM HoleExprRef +emitNewExprHole occ ty + = do { u <- newUnique + ; ref <- newTcRef (pprPanic "unfilled unbound-variable evidence" (ppr u)) + ; let her = HER ref ty u + + ; loc <- getCtLocM (ExprHoleOrigin (Just occ)) (Just TypeLevel) + + ; let hole = Hole { hole_sort = ExprHole her + , hole_occ = occ + , hole_ty = ty + , hole_loc = loc } + ; emitHole hole + ; return her } + +newDict :: Class -> [TcType] -> TcM DictId +newDict cls tys + = do { name <- newSysName (mkDictOcc (getOccName cls)) + ; return (mkLocalId name ManyTy (mkClassPred cls tys)) } + +predTypeOccName :: PredType -> OccName +predTypeOccName ty = case classifyPredType ty of + ClassPred cls _ -> mkDictOcc (getOccName cls) + EqPred {} -> mkVarOccFS (fsLit "co") + IrredPred {} -> mkVarOccFS (fsLit "irred") + ForAllPred {} -> mkVarOccFS (fsLit "df") + +-- | Create a new 'Implication' with as many sensible defaults for its fields +-- as possible. Note that the 'ic_tclvl', 'ic_binds', and 'ic_info' fields do +-- /not/ have sensible defaults, so they are initialized with lazy thunks that +-- will 'panic' if forced, so one should take care to initialize these fields +-- after creation. +-- +-- This is monadic to look up the 'TcLclEnv', which is used to initialize +-- 'ic_env', and to set the -Winaccessible-code flag. See +-- Note [Avoid -Winaccessible-code when deriving] in "GHC.Tc.TyCl.Instance". +newImplication :: TcM Implication +newImplication + = do env <- getLclEnv + warn_inaccessible <- woptM Opt_WarnInaccessibleCode + let in_gen_code = lclEnvInGeneratedCode env + return $ + (implicationPrototype (mkCtLocEnv env)) + { ic_warn_inaccessible = warn_inaccessible && not in_gen_code } + +{- +************************************************************************ +* * + Coercion holes +* * +************************************************************************ +-} + +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 } } + +-- | Put a value in a coercion hole +fillCoercionHole :: CoercionHole -> Coercion -> TcM () +fillCoercionHole (CoercionHole { ch_ref = ref, ch_co_var = cv }) co = do + when debugIsOn $ do + cts <- readTcRef ref + whenIsJust cts $ \old_co -> + pprPanic "Filling a filled coercion hole" (ppr cv $$ ppr co $$ ppr old_co) + traceTc "Filling coercion hole" (ppr cv <+> text ":=" <+> ppr co) + writeTcRef ref (Just co) + + +{- ********************************************************************** +* + ExpType functions +* +********************************************************************** -} + +{- Note [ExpType] +~~~~~~~~~~~~~~~~~ +An ExpType is used as the "expected type" when type-checking an expression. +An ExpType can hold a "hole" that can be filled in by the type-checker. +This allows us to have one tcExpr that works in both checking mode and +synthesis mode (that is, bidirectional type-checking). Previously, this +was achieved by using ordinary unification variables, but we don't need +or want that generality. (For example, #11397 was caused by doing the +wrong thing with unification variables.) Instead, we observe that these +holes should + +1. never be nested +2. never appear as the type of a variable +3. be used linearly (never be duplicated) + +By defining ExpType, separately from Type, we can achieve goals 1 and 2 +statically. + +See also [wiki:typechecking] + +Note [TcLevel of ExpType] +~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + + data G a where + MkG :: G Bool + + foo MkG = True + +This is a classic untouchable-variable / ambiguous GADT return type +scenario. But, with ExpTypes, we'll be inferring the type of the RHS. +We thus must track a TcLevel in an Inferring ExpType. If we try to +fill the ExpType and find that the TcLevels don't work out, we fill +the ExpType with a tau-tv at the low TcLevel, hopefully to be worked +out later by some means -- see fillInferResult, and Note [fillInferResult] + +This behaviour triggered in test gadt/gadt-escape1. + +Note [FixedRuntimeRep context in ExpType] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Sometimes, we want to be sure that we fill an ExpType with a type +that has a syntactically fixed RuntimeRep (in the sense of +Note [Fixed RuntimeRep] in GHC.Tc.Utils.Concrete). + +Example: + + pattern S a = (a :: (T :: TYPE R)) + +We have to infer a type for `a` which has a syntactically fixed RuntimeRep. +When it comes time to filling in the inferred type, we do the appropriate +representation-polymorphism check, much like we do a level check +as explained in Note [TcLevel of ExpType]. + +See test case T21325. +-} + +-- actual data definition is in GHC.Tc.Utils.TcType + +newInferExpType :: InferInstFlag -> TcM ExpType +newInferExpType iif = new_inferExpType iif IFRR_Any + +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. + + ; new_inferExpType iif mb_frr } + +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_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. +readExpType_maybe :: MonadIO m => ExpType -> m (Maybe TcType) +readExpType_maybe (Check ty) = return (Just ty) +readExpType_maybe (Infer (IR { ir_ref = ref})) = liftIO $ readIORef ref +{-# INLINEABLE readExpType_maybe #-} + +-- | Same as readExpType, but for Scaled ExpTypes +readScaledExpType :: MonadIO m => Scaled ExpType -> m (Scaled Type) +readScaledExpType (Scaled m exp_ty) + = do { ty <- readExpType exp_ty + ; return (Scaled m ty) } +{-# INLINEABLE readScaledExpType #-} + +-- | Extract a type out of an ExpType. Otherwise, panics. +readExpType :: MonadIO m => ExpType -> m TcType +readExpType exp_ty + = do { mb_ty <- readExpType_maybe exp_ty + ; case mb_ty of + Just ty -> return ty + Nothing -> pprPanic "Unknown expected type" (ppr exp_ty) } +{-# INLINEABLE readExpType #-} + +scaledExpTypeToType :: Scaled ExpType -> TcM (Scaled TcType) +scaledExpTypeToType (Scaled m exp_ty) + = do { ty <- expTypeToType exp_ty + ; return (Scaled m ty) } + +-- | Extracts the expected type if there is one, or generates a new +-- TauTv if there isn't. +expTypeToType :: ExpType -> TcM TcType +expTypeToType (Check ty) = return ty +expTypeToType (Infer inf_res) = inferResultToType inf_res + +inferResultToType :: InferResult -> TcM Type +inferResultToType (IR { ir_uniq = u, ir_lvl = tc_lvl + , ir_ref = ref + , ir_frr = mb_frr }) + = do { mb_inferred_ty <- readTcRef ref + ; tau <- case mb_inferred_ty of + Just ty -> do { ensureMonoType ty + -- See Note [inferResultToType] + ; return ty } + Nothing -> do { tau <- new_meta + ; writeMutVar ref (Just tau) + ; return tau } + ; traceTc "Forcing ExpType to be monomorphic:" + (ppr u <+> text ":=" <+> ppr tau) + ; return tau } + where + -- See Note [TcLevel of ExpType] + new_meta = case mb_frr of + IFRR_Any -> do { rr <- newMetaTyVarTyAtLevel tc_lvl runtimeRepTy + ; newMetaTyVarTyAtLevel tc_lvl (mkTYPEapp rr) } + 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] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +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] above, and +Note [fillInferResult] in GHC.Tc.Utils.Unify. +-} + +-- | Infer a type using a fresh ExpType +-- See also Note [ExpType] in "GHC.Tc.Utils.TcMType" +-- +-- Use 'runInferFRR' if you require the type to have a fixed +-- runtime representation. +runInferSigma :: (ExpSigmaType -> TcM a) -> TcM (a, TcSigmaType) +runInferSigma = runInfer IIF_Sigma IFRR_Any + +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. +runInferRhoFRR :: FixedRuntimeRepContext -> (ExpRhoTypeFRR -> TcM a) -> TcM (a, TcRhoTypeFRR) +runInferRhoFRR frr_orig = runInfer IIF_DeepRho (IFRR_Check frr_orig) + +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) } + +{- ********************************************************************* +* * + Promoting types +* * +********************************************************************* -} + +ensureMonoType :: TcType -> TcM () +-- Assuming that the argument type is of kind (TYPE r), +-- ensure that it is a /monotype/ +-- If it is not a monotype we can see right away (since unification +-- variables and type-function applications stand for monotypes), but +-- we emit a Wanted equality just to delay the error message until later +ensureMonoType res_ty + | isTauTy res_ty -- isTauTy doesn't need zonking or anything + = return () + | otherwise + = do { mono_ty <- newOpenFlexiTyVarTy + ; _co <- unifyInvisibleType res_ty mono_ty + ; return () } + +promoteTcType :: TcLevel -> TcType -> TcM (TcCoercionN, TcType) +-- See Note [Promoting a type] +-- See also Note [fillInferResult] +-- promoteTcType level ty = (co, ty') +-- * Returns ty' whose max level is just 'level' +-- and whose kind is ~# to the kind of 'ty' +-- and whose kind has form TYPE rr +-- * and co :: ty ~ ty' +-- * and emits constraints to justify the coercion +-- +-- NB: we expect that 'ty' has already kind (TYPE rr) for +-- some rr::RuntimeRep. It is, after all, the type of a term. +promoteTcType dest_lvl ty + = do { cur_lvl <- getTcLevel + ; if (cur_lvl `sameDepthAs` dest_lvl) + then return (mkNomReflCo ty, ty) + else promote_it } + where + promote_it :: TcM (TcCoercion, TcType) + promote_it -- Emit a constraint (alpha :: TYPE rr) ~ ty + -- where alpha and rr are fresh and from level dest_lvl + = do { rr <- newMetaTyVarTyAtLevel dest_lvl runtimeRepTy + ; prom_ty <- newMetaTyVarTyAtLevel dest_lvl (mkTYPEapp rr) + ; co <- unifyInvisibleType ty prom_ty + ; return (co, prom_ty) } + +{- Note [Promoting a type] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider (#12427) + + data T where + MkT :: (Int -> Int) -> a -> T + + h y = case y of MkT v w -> v + +We'll infer the RHS type with an expected type ExpType of + (IR { ir_lvl = l, ir_ref = ref, ... ) +where 'l' is the TcLevel of the RHS of 'h'. Then the MkT pattern +match will increase the level, so we'll end up in tcSubType, trying to +unify the type of v, + v :: Int -> Int +with the expected type. But this attempt takes place at level (l+1), +rightly so, since v's type could have mentioned existential variables, +(like w's does) and we want to catch that. + +So we + - create a new meta-var alpha[l+1] + - fill in the InferRes ref cell 'ref' with alpha + - emit an equality constraint, thus + [W] alpha[l+1] ~ (Int -> Int) + +That constraint will float outwards, as it should, unless v's +type mentions a skolem-captured variable. + +This approach fails if v has a higher rank type; see +Note [Promotion and higher rank types] + + +Note [Promotion and higher rank types] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If v had a higher-rank type, say v :: (forall a. a->a) -> Int, +then we'd emit an equality + [W] alpha[l+1] ~ ((forall a. a->a) -> Int) +which will sadly fail because we can't unify a unification variable +with a polytype. But there is nothing really wrong with the program +here. + +We could just about solve this by "promote the type" of v, to expose +its polymorphic "shape" while still leaving constraints that will +prevent existential escape. But we must be careful! Exposing +the "shape" of the type is precisely what we must NOT do under +a GADT pattern match! So in this case we might promote the type +to + (forall a. a->a) -> alpha[l+1] +and emit the constraint + [W] alpha[l+1] ~ Int +Now the promoted type can fill the ref cell, while the emitted +equality can float or not, according to the usual rules. + +But that's not quite right! We are exposing the arrow! We could +deal with that too: + (forall a. mu[l+1] a a) -> alpha[l+1] +with constraints + [W] alpha[l+1] ~ Int + [W] mu[l+1] ~ (->) +Here we abstract over the '->' inside the forall, in case that +is subject to an equality constraint from a GADT match. + +Note that we kept the outer (->) because that's part of +the polymorphic "shape". And because of impredicativity, +GADT matches can't give equalities that affect polymorphic +shape. + +This reasoning just seems too complicated, so I decided not +to do it. These higher-rank notes are just here to record +the thinking. +-} + + +{- ********************************************************************* +* * + MetaTvs (meta type variables; mutable) +* * +********************************************************************* -} + +{- Note [TyVarTv] +~~~~~~~~~~~~~~~~~ +A TyVarTv can unify with type *variables* only, including other TyVarTvs and +skolems. They are used in two places: + +1. In kind signatures, see GHC.Tc.TyCl + Note [Inferring kinds for type declarations] + and Note [Using TyVarTvs for kind-checking GADTs] + +2. In partial type signatures. See GHC.Tc.Types + Note [Quantified variables in partial type signatures] + +Sometimes, they can unify with type variables that the user would +rather keep distinct; see #11203 for an example. So, any client of +this function needs to either allow the TyVarTvs to unify with each +other or check that they don't. In the case of (1) the check is done +in GHC.Tc.TyCl.swizzleTcTyConBndrs. In case of (2) it's done by +findDupTyVarTvs in GHC.Tc.Gen.Bind.chooseInferredQuantifiers. + +Historical note: Before #15050 this (under the name SigTv) was also +used for ScopedTypeVariables in patterns, to make sure these type +variables only refer to other type variables, but this restriction was +dropped, and ScopedTypeVariables can now refer to full types (GHC +Proposal 29). +-} + +newMetaTyVarName :: FastString -> TcM Name +-- Makes a /System/ Name, which is eagerly eliminated by +-- the unifier; see GHC.Tc.Utils.Unify.nicer_to_update_tv1, and +-- GHC.Tc.Solver.Equality.canEqTyVarTyVar (nicer_to_update_tv2) +newMetaTyVarName str + = newSysName (mkTyVarOccFS str) + +cloneMetaTyVarName :: Name -> TcM Name +cloneMetaTyVarName name + = newSysName (nameOccName name) + -- See Note [Name of an instantiated type variable] + +{- Note [Name of an instantiated type variable] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +At the moment we give a unification variable a System Name, which +influences the way it is tidied; see TypeRep.tidyTyVarBndr. +-} + +metaInfoToTyVarName :: MetaInfo -> FastString +metaInfoToTyVarName meta_info = + case meta_info of + TauTv -> fsLit "t" + TyVarTv -> fsLit "a" + RuntimeUnkTv -> fsLit "r" + CycleBreakerTv -> fsLit "b" + ConcreteTv {} -> fsLit "c" + +newAnonMetaTyVar :: MetaInfo -> Kind -> TcM TcTyVar +newAnonMetaTyVar mi = newNamedAnonMetaTyVar (metaInfoToTyVarName mi) mi + +newNamedAnonMetaTyVar :: FastString -> MetaInfo -> Kind -> TcM TcTyVar +-- Make a new meta tyvar out of thin air +newNamedAnonMetaTyVar tyvar_name meta_info kind + + = do { name <- newMetaTyVarName tyvar_name + ; details <- newMetaDetails meta_info + ; let tyvar = mkTcTyVar name kind details + ; traceTc "newAnonMetaTyVar" (ppr tyvar <+> dcolon <+> ppr kind) + ; return tyvar } + +-- makes a new skolem tv +newSkolemTyVar :: SkolemInfo -> Name -> Kind -> TcM TcTyVar +newSkolemTyVar skol_info name kind + = do { lvl <- getTcLevel + ; return (mkTcTyVar name kind (SkolemTv skol_info lvl False)) } + +newTyVarTyVar :: Name -> Kind -> TcM TcTyVar +-- See Note [TyVarTv] +-- Does not clone a fresh unique +newTyVarTyVar name kind + = do { details <- newMetaDetails TyVarTv + ; let tyvar = mkTcTyVar name kind details + ; traceTc "newTyVarTyVar" (ppr tyvar) + ; return tyvar } + +cloneTyVarTyVar :: Name -> Kind -> TcM TcTyVar +-- See Note [TyVarTv] +-- Clones a fresh unique +cloneTyVarTyVar name kind + = do { details <- newMetaDetails TyVarTv + ; uniq <- newUnique + ; let name' = name `setNameUnique` uniq + tyvar = mkTcTyVar name' kind details + -- Don't use cloneMetaTyVar, which makes a SystemName + -- We want to keep the original more user-friendly Name + -- In practical terms that means that in error messages, + -- when the Name is tidied we get 'a' rather than 'a0' + ; traceTc "cloneTyVarTyVar" (ppr tyvar) + ; return tyvar } + +-- | Create a new metavariable, of the given kind, which can only be unified +-- with a concrete type. +-- +-- Invariant: the kind must be concrete, as per Note [ConcreteTv]. +-- This is checked with an assertion. +newConcreteTyVar :: HasDebugCallStack => ConcreteTvOrigin + -> FastString -> TcKind -> TcM TcTyVar +newConcreteTyVar reason fs kind + = assertPpr (isConcreteType kind) assert_msg $ + 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 + +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 "newPatTyVar" (ppr tyvar) + ; return tyvar } + +cloneAnonMetaTyVar :: MetaInfo -> TyVar -> TcKind -> TcM TcTyVar +-- Make a fresh MetaTyVar, basing the name +-- on that of the supplied TyVar +cloneAnonMetaTyVar info tv kind + = do { details <- newMetaDetails info + ; name <- cloneMetaTyVarName (tyVarName tv) + ; let tyvar = mkTcTyVar name kind details + ; traceTc "cloneAnonMetaTyVar" (ppr tyvar <+> dcolon <+> ppr (tyVarKind tyvar)) + ; return tyvar } + +-- | 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 + ; name <- newMetaTyVarName (fsLit "cbv") + ; return (mkTcTyVar name kind details) } + +newMetaDetails :: MetaInfo -> TcM TcTyVarDetails +newMetaDetails info + = do { ref <- newMutVar Flexi + ; tclvl <- getTcLevel + ; return (MetaTv { mtv_info = info + , mtv_ref = ref + , mtv_tclvl = tclvl }) } + +newTauTvDetailsAtLevel :: TcLevel -> TcM TcTyVarDetails +newTauTvDetailsAtLevel tclvl + = do { ref <- newMutVar Flexi + ; return (MetaTv { mtv_info = TauTv + , mtv_ref = ref + , mtv_tclvl = tclvl }) } + +newConcreteTvDetailsAtLevel :: ConcreteTvOrigin -> TcLevel -> TcM TcTyVarDetails +newConcreteTvDetailsAtLevel conc_orig tclvl + = do { ref <- newMutVar Flexi + ; return (MetaTv { mtv_info = ConcreteTv conc_orig + , mtv_ref = ref + , mtv_tclvl = tclvl }) } + +cloneMetaTyVar :: TcTyVar -> TcM TcTyVar +cloneMetaTyVar tv + = assert (isTcTyVar tv) $ + do { ref <- newMutVar Flexi + ; name' <- cloneMetaTyVarName (tyVarName tv) + ; let details' = case tcTyVarDetails tv of + details@(MetaTv {}) -> details { mtv_ref = ref } + _ -> pprPanic "cloneMetaTyVar" (ppr tv) + tyvar = mkTcTyVar name' (tyVarKind tv) details' + ; traceTc "cloneMetaTyVar" (ppr tyvar) + ; return tyvar } + +cloneMetaTyVarWithInfo :: MetaInfo -> TcLevel -> TcTyVar -> TcM TcTyVar +cloneMetaTyVarWithInfo info tc_lvl tv + = assert (isTcTyVar tv) $ + do { ref <- newMutVar Flexi + ; name' <- cloneMetaTyVarName (tyVarName tv) + ; let details = MetaTv { mtv_info = info + , mtv_ref = ref + , mtv_tclvl = tc_lvl } + tyvar = mkTcTyVar name' (tyVarKind tv) details + ; traceTc "cloneMetaTyVarWithInfo" (ppr tyvar) + ; return tyvar } + +-- Works for both type and kind variables +readMetaTyVar :: MonadIO m => TyVar -> m MetaDetails +readMetaTyVar tyvar = assertPpr (isMetaTyVar tyvar) (ppr tyvar) $ + liftIO $ readIORef (metaTyVarRef tyvar) +{-# SPECIALISE readMetaTyVar :: TyVar -> TcM MetaDetails #-} +{-# SPECIALISE readMetaTyVar :: TyVar -> ZonkM MetaDetails #-} + +isFilledMetaTyVar_maybe :: TcTyVar -> TcM (Maybe Type) +isFilledMetaTyVar_maybe tv +-- TODO: This should be an assertion that tv is definitely a TcTyVar but it fails +-- at the moment (Jan 22) + | isTcTyVar tv + , MetaTv { mtv_ref = ref } <- tcTyVarDetails tv + = do { cts <- readTcRef ref + ; case cts of + Indirect ty -> return (Just ty) + Flexi -> return Nothing } + | otherwise + = return Nothing + +isFilledMetaTyVar :: TyVar -> TcM Bool +-- True of a filled-in (Indirect) meta type variable +isFilledMetaTyVar tv = isJust <$> isFilledMetaTyVar_maybe tv + +isUnfilledMetaTyVar :: TyVar -> TcM Bool +-- True of a un-filled-in (Flexi) meta type variable +-- NB: Not the opposite of isFilledMetaTyVar +isUnfilledMetaTyVar tv + | MetaTv { mtv_ref = ref } <- tcTyVarDetails tv + = do { details <- readMutVar ref + ; return (isFlexi details) } + | otherwise = return False + +{- +************************************************************************ +* * + MetaTvs: TauTvs +* * +************************************************************************ + +Note [Never need to instantiate coercion variables] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +With coercion variables sloshing around in types, it might seem that we +sometimes need to instantiate coercion variables. This would be problematic, +because coercion variables inhabit unboxed equality (~#), and the constraint +solver thinks in terms only of boxed equality (~). The solution is that +we never need to instantiate coercion variables in the first place. + +The tyvars that we need to instantiate come from the types of functions, +data constructors, and patterns. These will never be quantified over +coercion variables, except for the special case of the promoted Eq#. But, +that can't ever appear in user code, so we're safe! +-} + + +newMultiplicityVar :: TcM TcType +newMultiplicityVar = newFlexiTyVarTy multiplicityTy + +newFlexiTyVar :: Kind -> TcM TcTyVar +newFlexiTyVar kind = newAnonMetaTyVar TauTv kind + +-- | Create a new flexi ty var with a specific name +newNamedFlexiTyVar :: FastString -> Kind -> TcM TcTyVar +newNamedFlexiTyVar fs kind = newNamedAnonMetaTyVar fs TauTv kind + +newFlexiTyVarTy :: Kind -> TcM TcType +newFlexiTyVarTy kind = do + tc_tyvar <- newFlexiTyVar kind + return (mkTyVarTy tc_tyvar) + +newFlexiTyVarTys :: Int -> Kind -> TcM [TcType] +newFlexiTyVarTys n kind = replicateM n (newFlexiTyVarTy kind) + +newOpenTypeKind :: TcM TcKind +newOpenTypeKind + = do { rr <- newFlexiTyVarTy runtimeRepTy + ; 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. +-- +-- 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 + ; return (mkTyVarTy tv) } + +newOpenFlexiTyVar :: TcM TcTyVar +newOpenFlexiTyVar + = 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) + ; let rr = mkTyConApp boxedRepDataConTyCon [lev] + ; return (mkTYPEapp rr) } + +newMetaTyVars :: [TyVar] -> TcM (Subst, [TcTyVar]) +-- Instantiate with META type variables +-- Note that this works for a sequence of kind, type, and coercion variables +-- variables. Eg [ (k:*), (a:k->k) ] +-- Gives [ (k7:*), (a8:k7->k7) ] +newMetaTyVars = newMetaTyVarsX emptySubst + -- emptySubst has an empty in-scope set, but that's fine here + -- Since the tyvars are freshly made, they cannot possibly be + -- captured by any existing for-alls. + +newMetaTyVarsX :: Subst -> [TyVar] -> TcM (Subst, [TcTyVar]) +-- 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 subst tv = new_meta_tv_x TyVarTv subst tv + +newWildCardX :: Subst -> TyVar -> TcM (Subst, TcTyVar) +newWildCardX subst tv + = do { new_tv <- newAnonMetaTyVar TauTv (substTy subst (tyVarKind tv)) + ; return (extendTvSubstWithClone subst tv new_tv, new_tv) } + +new_meta_tv_x :: MetaInfo -> Subst -> TyVar -> TcM (Subst, TcTyVar) +new_meta_tv_x info subst tv + = do { new_tv <- cloneAnonMetaTyVar info tv substd_kind + ; let subst1 = extendTvSubstWithClone subst tv new_tv + ; return (subst1, new_tv) } + where + substd_kind = substTy subst (tyVarKind tv) + +newMetaTyVarTyAtLevel :: TcLevel -> TcKind -> TcM TcType +newMetaTyVarTyAtLevel tc_lvl kind + = do { details <- newTauTvDetailsAtLevel tc_lvl + ; name <- newMetaTyVarName (fsLit "p") + ; return (mkTyVarTy (mkTcTyVar name kind details)) } + +newConcreteTyVarTyAtLevel :: ConcreteTvOrigin -> TcLevel -> TcKind -> TcM TcType +newConcreteTyVarTyAtLevel conc_orig tc_lvl kind + = do { details <- newConcreteTvDetailsAtLevel conc_orig tc_lvl + ; 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 +* * +********************************************************************* -} + +{- Note [Dependent type variables] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In Haskell type inference we quantify over type variables; but we only +quantify over /kind/ variables when -XPolyKinds is on. Without -XPolyKinds +we default the kind variables to *. + +So, to support this defaulting, and only for that reason, when +collecting the free vars of a type (in candidateQTyVarsOfType and friends), +prior to quantifying, we must keep the type and kind variables separate. + +But what does that mean in a system where kind variables /are/ type +variables? It's a fairly arbitrary distinction based on how the +variables appear: + + - "Kind variables" appear in the kind of some other free variable + or in the kind of a locally quantified type variable + (forall (a :: kappa). ...) or in the kind of a coercion + (a |> (co :: kappa1 ~ kappa2)). + + These are the ones we default to * if -XPolyKinds is off + + - "Type variables" are all free vars that are not kind variables + +E.g. In the type T k (a::k) + 'k' is a kind variable, because it occurs in the kind of 'a', + even though it also appears at "top level" of the type + 'a' is a type variable, because it doesn't + +We gather these variables using a CandidatesQTvs record: + DV { dv_kvs: Variables free in the kind of a free type variable + or of a forall-bound type variable + , dv_tvs: Variables syntactically free in the type } + +So: dv_kvs are the kind variables of the type + (dv_tvs - dv_kvs) are the type variable of the type + +Note that + +* A variable can occur in both. + T k (x::k) The first occurrence of k makes it + show up in dv_tvs, the second in dv_kvs + +* We include any coercion variables in the "dependent", + "kind-variable" set because we never quantify over them. + +* The "kind variables" might depend on each other; e.g + (k1 :: k2), (k2 :: *) + The "type variables" do not depend on each other; if + one did, it'd be classified as a kind variable! + +Note [CandidatesQTvs determinism and order] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +* Determinism: when we quantify over type variables we decide the + order in which they appear in the final type. Because the order of + type variables in the type can end up in the interface file and + affects some optimizations like worker-wrapper, we want this order to + be deterministic. + + To achieve that we use deterministic sets of variables that can be + converted to lists in a deterministic order. For more information + about deterministic sets see Note [Deterministic UniqFM] in GHC.Types.Unique.DFM. + +* Order: as well as being deterministic, we use an + accumulating-parameter style for candidateQTyVarsOfType so that we + add variables one at a time, left to right. That means we tend to + produce the variables in left-to-right order. This is just to make + it bit more predictable for the programmer. + +Note [Naughty quantification candidates] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider (#14880, dependent/should_compile/T14880-2), suppose +we are trying to generalise this type: + + forall arg. ... (alpha[tau]:arg) ... + +We have a metavariable alpha whose kind mentions a skolem variable +bound inside the very type we are generalising. +This can arise while type-checking a user-written type signature +(see the test case for the full code). + +We cannot generalise over alpha! That would produce a type like + forall {a :: arg}. forall arg. ...blah... +The fact that alpha's kind mentions arg renders it completely +ineligible for generalisation. + +However, we are not going to learn any new constraints on alpha, +because its kind isn't even in scope in the outer context (but see Wrinkle). +So alpha is entirely unconstrained. + +What then should we do with alpha? During generalization, every +metavariable is either (A) promoted, (B) generalized, or (C) zapped +(according to Note [Recipe for checking a signature] in GHC.Tc.Gen.HsType). + + * We can't generalise it. + * We can't promote it, because its kind prevents that + * We can't simply leave it be, because this type is about to + go into the typing environment (as the type of some let-bound + variable, say), and then chaos erupts when we try to instantiate. + +Previously, we zapped it to Any. This worked, but it had the unfortunate +effect of causing Any sometimes to appear in error messages. If this +kind of signature happens, the user probably has made a mistake -- no +one really wants Any in their types. So we now error. This must be +a hard error (failure in the monad) to avoid other messages from mentioning +Any. + +We do this eager erroring in candidateQTyVars, which always precedes +generalisation, because at that moment we have a clear picture of what +skolems are in scope within the type itself (e.g. that 'forall arg'). + +This change is inspired by and described in Section 7.2 of "Kind Inference +for Datatypes", POPL'20. + +NB: this is all rather similar to, but sadly not the same as + Note [Error on unconstrained meta-variables] + +Wrinkle: + +We must make absolutely sure that alpha indeed is not from an outer +context. (Otherwise, we might indeed learn more information about it.) +This can be done easily: we just check alpha's TcLevel. That level +must be strictly greater than the ambient TcLevel in order to treat it +as naughty. We say "strictly greater than" because the call to +candidateQTyVars is made outside the bumped TcLevel, as stated in the +comment to candidateQTyVarsOfType. The level check is done in go_tv in +collect_cand_qtvs. Skipping this check caused #16517. + +-} + +data CandidatesQTvs + -- See Note [Dependent type variables] + -- See Note [CandidatesQTvs determinism and order] + -- + -- Invariants: + -- * All variables are fully zonked, including their kinds + -- * All variables are at a level greater than the ambient level + -- See Note [Use level numbers for quantification] + -- + -- This *can* contain skolems. For example, in `data X k :: k -> Type` + -- we need to know that the k is a dependent variable. This is done + -- by collecting the candidates in the kind after skolemising. It also + -- comes up when generalizing a associated type instance, where instance + -- variables are skolems. (Recall that associated type instances are generalized + -- independently from their enclosing class instance, and the associated + -- type instance may be generalized by more, fewer, or different variables + -- than the class instance.) + -- + = DV { dv_kvs :: DTyVarSet -- "kind" metavariables (dependent) + , dv_tvs :: DTyVarSet -- "type" metavariables (non-dependent) + -- A variable may appear in both sets + -- E.g. T k (x::k) The first occurrence of k makes it + -- show up in dv_tvs, the second in dv_kvs + -- See Note [Dependent type variables] + + , dv_cvs :: CoVarSet + -- These are covars. Included only so that we don't repeatedly + -- look at covars' kinds in accumulator. Not used by quantifyTyVars. + } + +instance Semi.Semigroup CandidatesQTvs where + (DV { dv_kvs = kv1, dv_tvs = tv1, dv_cvs = cv1 }) + <> (DV { dv_kvs = kv2, dv_tvs = tv2, dv_cvs = cv2 }) + = DV { dv_kvs = kv1 `unionDVarSet` kv2 + , dv_tvs = tv1 `unionDVarSet` tv2 + , dv_cvs = cv1 `unionVarSet` cv2 } + +instance Monoid CandidatesQTvs where + mempty = DV { dv_kvs = emptyDVarSet, dv_tvs = emptyDVarSet, dv_cvs = emptyVarSet } + mappend = (Semi.<>) + +instance Outputable CandidatesQTvs where + ppr (DV {dv_kvs = kvs, dv_tvs = tvs, dv_cvs = cvs }) + = text "DV" <+> braces (pprWithCommas id [ text "dv_kvs =" <+> ppr kvs + , 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 + +-- | Extract out the kind vars (in order) and type vars (in order) from +-- a 'CandidatesQTvs'. The lists are guaranteed to be distinct. Keeping +-- the lists separate is important only in the -XNoPolyKinds case. +candidateVars :: CandidatesQTvs -> ([TcTyVar], [TcTyVar]) +candidateVars (DV { dv_kvs = dep_kv_set, dv_tvs = nondep_tkv_set }) + = (dep_kvs, nondep_tvs) + where + dep_kvs = scopedSort $ dVarSetElems dep_kv_set + -- scopedSort: put the kind variables into + -- well-scoped order. + -- E.g. [k, (a::k)] not the other way round + + nondep_tvs = dVarSetElems (nondep_tkv_set `minusDVarSet` dep_kv_set) + -- See Note [Dependent type variables] + -- The `minus` dep_tkvs removes any kind-level vars + -- e.g. T k (a::k) Since k appear in a kind it'll + -- be in dv_kvs, and is dependent. So remove it from + -- dv_tvs which will also contain k + -- NB kinds of tvs are already zonked + +candidateKindVars :: CandidatesQTvs -> TyVarSet +candidateKindVars dvs = dVarSetToVarSet (dv_kvs dvs) + +delCandidates :: CandidatesQTvs -> [Var] -> CandidatesQTvs +delCandidates (DV { dv_kvs = kvs, dv_tvs = tvs, dv_cvs = cvs }) vars + = DV { dv_kvs = kvs `delDVarSetList` vars + , dv_tvs = tvs `delDVarSetList` vars + , dv_cvs = cvs `delVarSetList` vars } + +partitionCandidates :: CandidatesQTvs -> (TyVar -> Bool) -> (TyVarSet, CandidatesQTvs) +-- The selected TyVars are returned as a non-deterministic TyVarSet +partitionCandidates dvs@(DV { dv_kvs = kvs, dv_tvs = tvs }) pred + = (extracted, dvs { dv_kvs = rest_kvs, dv_tvs = rest_tvs }) + where + (extracted_kvs, rest_kvs) = partitionDVarSet pred kvs + (extracted_tvs, rest_tvs) = partitionDVarSet pred tvs + extracted = dVarSetToVarSet extracted_kvs `unionVarSet` dVarSetToVarSet extracted_tvs + +candidateQTyVarsWithBinders :: [TyVar] -> Type -> TcM CandidatesQTvs +-- (candidateQTyVarsWithBinders tvs ty) returns the candidateQTyVars +-- of (forall tvs. ty), but do not treat 'tvs' as bound for the purpose +-- of Note [Naughty quantification candidates]. Why? +-- Because we are going to scoped-sort the quantified variables +-- in among the tvs +candidateQTyVarsWithBinders bound_tvs ty + = do { kvs <- candidateQTyVarsOfKinds (map tyVarKind bound_tvs) + ; cur_lvl <- getTcLevel + ; all_tvs <- collect_cand_qtvs ty False cur_lvl emptyVarSet kvs ty + ; return (all_tvs `delCandidates` bound_tvs) } + +-- | Gathers free variables to use as quantification candidates (in +-- 'quantifyTyVars'). This might output the same var +-- in both sets, if it's used in both a type and a kind. +-- The variables to quantify must have a TcLevel strictly greater than +-- the ambient level. (See Wrinkle in Note [Naughty quantification candidates]) +-- See Note [CandidatesQTvs determinism and order] +-- See Note [Dependent type variables] +candidateQTyVarsOfType :: TcType -- not necessarily zonked + -> TcM CandidatesQTvs +candidateQTyVarsOfType ty + = do { cur_lvl <- getTcLevel + ; collect_cand_qtvs ty False cur_lvl emptyVarSet mempty ty } + +-- | Like 'candidateQTyVarsOfType', but over a list of types +-- The variables to quantify must have a TcLevel strictly greater than +-- the ambient level. (See Wrinkle in Note [Naughty quantification candidates]) +candidateQTyVarsOfTypes :: [Type] -> TcM CandidatesQTvs +candidateQTyVarsOfTypes tys + = do { cur_lvl <- getTcLevel + ; foldlM (\acc ty -> collect_cand_qtvs ty False cur_lvl emptyVarSet acc ty) + mempty tys } + +-- | Like 'candidateQTyVarsOfType', but consider every free variable +-- to be dependent. This is appropriate when generalizing a *kind*, +-- instead of a type. (That way, -XNoPolyKinds will default the variables +-- to Type.) +candidateQTyVarsOfKind :: TcKind -- Not necessarily zonked + -> TcM CandidatesQTvs +candidateQTyVarsOfKind ty + = do { cur_lvl <- getTcLevel + ; collect_cand_qtvs ty True cur_lvl emptyVarSet mempty ty } + +candidateQTyVarsOfKinds :: [TcKind] -- Not necessarily zonked + -> TcM CandidatesQTvs +candidateQTyVarsOfKinds tys + = do { cur_lvl <- getTcLevel + ; foldM (\acc ty -> collect_cand_qtvs ty True cur_lvl emptyVarSet acc ty) + mempty tys } + +collect_cand_qtvs + :: TcType -- Original type that we started recurring into; for errors + -> Bool -- True <=> consider every fv in Type to be dependent + -> TcLevel -- Current TcLevel; collect only tyvars whose level is greater + -> VarSet -- Bound variables (locals only) + -> CandidatesQTvs -- Accumulating parameter + -> Type -- Not necessarily zonked + -> TcM CandidatesQTvs + +-- Key points: +-- * Looks through meta-tyvars as it goes; +-- no need to zonk in advance +-- +-- * Needs to be monadic anyway, because it handles naughty +-- quantification; see Note [Naughty quantification candidates] +-- +-- * Returns fully-zonked CandidateQTvs, including their kinds +-- so that subsequent dependency analysis (to build a well +-- scoped telescope) works correctly + +collect_cand_qtvs orig_ty is_dep cur_lvl bound dvs ty + = go dvs ty + where + is_bound tv = tv `elemVarSet` bound + + ----------------- + go :: CandidatesQTvs -> TcType -> TcM CandidatesQTvs + -- Uses accumulating-parameter style + go dv (AppTy t1 t2) = foldlM go dv [t1, t2] + go dv (TyConApp tc tys) = go_tc_args dv (tyConBinders tc) tys + go dv (FunTy _ w arg res) = foldlM go dv [w, arg, res] + go dv (LitTy {}) = return dv + go dv (CastTy ty co) = do { dv1 <- go dv ty + ; collect_cand_qtvs_co orig_ty cur_lvl bound dv1 co } + go dv (CoercionTy co) = collect_cand_qtvs_co orig_ty cur_lvl bound dv co + + go dv (TyVarTy tv) + | is_bound tv = return dv + | otherwise = do { m_contents <- isFilledMetaTyVar_maybe tv + ; case m_contents of + Just ind_ty -> go dv ind_ty + Nothing -> go_tv dv tv } + + go dv (ForAllTy (Bndr tv _) ty) + = do { dv1 <- collect_cand_qtvs orig_ty True cur_lvl bound dv (tyVarKind tv) + ; collect_cand_qtvs orig_ty is_dep cur_lvl (bound `extendVarSet` tv) dv1 ty } + + -- This makes sure that we default e.g. the alpha in Proxy alpha (Any alpha). + -- Tested in polykinds/NestedProxies. + -- We just might get this wrong in AppTy, but I don't think that's possible + -- with -XNoPolyKinds. And fixing it would be non-performant, as we'd need + -- to look at kinds. + go_tc_args dv (tc_bndr:tc_bndrs) (ty:tys) + = do { dv1 <- collect_cand_qtvs orig_ty (is_dep || isNamedTyConBinder tc_bndr) + cur_lvl bound dv ty + ; go_tc_args dv1 tc_bndrs tys } + go_tc_args dv _bndrs tys -- _bndrs might be non-empty: undersaturation + -- tys might be non-empty: oversaturation + -- either way, the foldlM is correct + = foldlM go dv tys + + ----------------- + go_tv dv@(DV { dv_kvs = kvs, dv_tvs = tvs }) tv + | 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 `strictlyDeeperThan` pushTcLevel cur_lvl + _ -> False + = return dv -- Skip inner skolems + -- This only happens for erroneous program with bad telescopes + -- e.g. BadTelescope2: forall a k (b :: k). SameKind a b + -- We have (a::k), and at the outer we don't want to quantify + -- over the already-quantified skolem k. + -- (Apparently we /do/ want to quantify over skolems whose level sk_lvl is + -- sk_lvl > cur_lvl; you get lots of failures otherwise. A battle for another day.) + + | tv `elemDVarSet` kvs + = return dv -- We have met this tyvar already + + | not is_dep + , tv `elemDVarSet` tvs + = return dv -- We have met this tyvar already + + | otherwise + = do { tv_kind <- liftZonkM $ zonkTcType (tyVarKind tv) + -- This zonk is annoying, but it is necessary, both to + -- ensure that the collected candidates have zonked kinds + -- (#15795) and to make the naughty check + -- (which comes next) works correctly + + ; let tv_kind_vars = tyCoVarsOfType tv_kind + ; if | intersectsVarSet bound tv_kind_vars + -- the tyvar must not be from an outer context, but we have + -- already checked for this. + -- See Note [Naughty quantification candidates] + -> do { traceTc "Naughty quantifier" $ + vcat [ ppr tv <+> dcolon <+> ppr tv_kind + , text "bound:" <+> pprTyVars (nonDetEltsUniqSet bound) + , text "fvs:" <+> pprTyVars (nonDetEltsUniqSet tv_kind_vars) ] + + ; let escapees = intersectVarSet bound tv_kind_vars + ; naughtyQuantification orig_ty tv escapees } + + | otherwise + -> do { let tv' = tv `setTyVarKind` tv_kind + dv' | is_dep = dv { dv_kvs = kvs `extendDVarSet` tv' } + | otherwise = dv { dv_tvs = tvs `extendDVarSet` tv' } + -- See Note [Order of accumulation] + + -- See Note [Recurring into kinds for candidateQTyVars] + ; collect_cand_qtvs orig_ty True cur_lvl bound dv' tv_kind } } + +collect_cand_qtvs_co :: TcType -- original type at top of recursion; for errors + -> TcLevel + -> VarSet -- bound variables + -> CandidatesQTvs -> Coercion + -> TcM CandidatesQTvs +collect_cand_qtvs_co orig_ty cur_lvl bound = go_co + where + go_co dv (Refl ty) = collect_cand_qtvs orig_ty True cur_lvl bound dv ty + go_co dv (GRefl _ ty mco) = do { dv1 <- collect_cand_qtvs orig_ty True cur_lvl bound dv ty + ; go_mco dv1 mco } + 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 (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 + go_co dv (LRCo _ co) = go_co dv co + go_co dv (InstCo co1 co2) = foldlM go_co dv [co1, co2] + go_co dv (KindCo co) = go_co dv co + go_co dv (SubCo co) = go_co dv co + + go_co dv (HoleCo 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 { 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_cv :: CandidatesQTvs -> CoVar -> TcM CandidatesQTvs + go_cv dv@(DV { dv_cvs = cvs }) cv + | is_bound cv = return dv + | cv `elemVarSet` cvs = return dv + + -- See Note [Recurring into kinds for candidateQTyVars] + | otherwise = collect_cand_qtvs orig_ty True cur_lvl bound + (dv { dv_cvs = cvs `extendVarSet` cv }) + (idType cv) + + is_bound tv = tv `elemVarSet` bound + +{- Note [Order of accumulation] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +You might be tempted (like I was) to use unitDVarSet and mappend +rather than extendDVarSet. However, the union algorithm for +deterministic sets depends on (roughly) the size of the sets. The +elements from the smaller set end up to the right of the elements from +the larger one. When sets are equal, the left-hand argument to +`mappend` goes to the right of the right-hand argument. + +In our case, if we use unitDVarSet and mappend, we learn that the free +variables of (a -> b -> c -> d) are [b, a, c, d], and we then quantify +over them in that order. (The a comes after the b because we union the +singleton sets as ({a} `mappend` {b}), producing {b, a}. Thereafter, +the size criterion works to our advantage.) This is just annoying to +users, so I use `extendDVarSet`, which unambiguously puts the new +element to the right. + +Note that the unitDVarSet/mappend implementation would not be wrong +against any specification -- just suboptimal and confounding to users. + +Note [Recurring into kinds for candidateQTyVars] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +First, read Note [Closing over free variable kinds] in GHC.Core.TyCo.FVs, paying +attention to the end of the Note about using an empty bound set when +traversing a variable's kind. + +That Note concludes with the recommendation that we empty out the bound +set when recurring into the kind of a type variable. Yet, we do not do +this here. I have two tasks in order to convince you that this code is +right. First, I must show why it is safe to ignore the reasoning in that +Note. Then, I must show why is is necessary to contradict the reasoning in +that Note. + +Why it is safe: There can be no +shadowing in the candidateQ... functions: they work on the output of +type inference, which is seeded by the renamer and its insistence to +use different Uniques for different variables. (In contrast, the Core +functions work on the output of optimizations, which may introduce +shadowing.) Without shadowing, the problem studied by +Note [Closing over free variable kinds] in GHC.Core.TyCo.FVs cannot happen. + +Why it is necessary: +Wiping the bound set would be just plain wrong here. Consider + + forall k1 k2 (a :: k1). Proxy k2 (a |> (hole :: k1 ~# k2)) + +We really don't want to think k1 and k2 are free here. (It's true that we'll +never be able to fill in `hole`, but we don't want to go off the rails just +because we have an insoluble coercion hole.) So: why is it wrong to wipe +the bound variables here but right in Core? Because the final statement +in Note [Closing over free variable kinds] in GHC.Core.TyCo.FVs is wrong: not +every variable is either free or bound. A variable can be a hole, too! +The reasoning in that Note then breaks down. + +And the reasoning applies just as well to free non-hole variables, so we +retain the bound set always. + +-} + +{- ********************************************************************* +* * + Quantification +* * +************************************************************************ + +Note [quantifyTyVars] +~~~~~~~~~~~~~~~~~~~~~ +quantifyTyVars is given the free vars of a type that we +are about to wrap in a forall. + +It takes these free type/kind variables (partitioned into dependent and +non-dependent variables) skolemises metavariables with a TcLevel greater +than the ambient level (see Note [Use level numbers for quantification]). + +* This function distinguishes between dependent and non-dependent + variables only to keep correct defaulting behavior with -XNoPolyKinds. + With -XPolyKinds, it treats both classes of variables identically. + +* quantifyTyVars never quantifies over + - a coercion variable (or any tv mentioned in the kind of a covar) + - a runtime-rep variable + +Note [Use level numbers for quantification] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The level numbers assigned to metavariables are very useful. Not only +do they track touchability (Note [TcLevel invariants] in GHC.Tc.Utils.TcType), +but they also allow us to determine which variables to +generalise. The rule is this: + + When generalising, quantify only metavariables with a TcLevel greater + than the ambient level. + +This works because we bump the level every time we go inside a new +source-level construct. In a traditional generalisation algorithm, we +would gather all free variables that aren't free in an environment. +However, if a variable is in that environment, it will always have a lower +TcLevel: it came from an outer scope. So we can replace the "free in +environment" check with a level-number check. + +Here is an example: + + f x = x + (z True) + where + z y = x * x + +We start by saying (x :: alpha[1]). When inferring the type of z, we'll +quickly discover that z :: alpha[1]. But it would be disastrous to +generalise over alpha in the type of z. So we need to know that alpha +comes from an outer environment. By contrast, the type of y is beta[2], +and we are free to generalise over it. What's the difference between +alpha[1] and beta[2]? Their levels. beta[2] has the right TcLevel for +generalisation, and so we generalise it. alpha[1] does not, and so +we leave it alone. + +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.decidePromotedTyVars +and in GHC.Tc.Gen.HsType.kindGeneralizeSome, both of which exclude +certain otherwise-eligible variables from being generalised. + +Using level numbers for quantification is implemented in the candidateQTyVars... +functions, by adding only those variables with a level strictly higher than +the ambient level to the set of candidates. + +Note [quantifyTyVars determinism] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The results of quantifyTyVars are wrapped in a forall and can end up in the +interface file. One such example is inferred type signatures. They also affect +the results of optimizations, for example worker-wrapper. This means that to +get deterministic builds quantifyTyVars needs to be deterministic. + +To achieve this CandidatesQTvs is backed by deterministic sets which allows them +to be later converted to a list in a deterministic order. + +For more information about deterministic sets see +Note [Deterministic UniqFM] in GHC.Types.Unique.DFM. +-} + +quantifyTyVars :: SkolemInfo + -> NonStandardDefaultingStrategy + -> CandidatesQTvs -- See Note [Dependent type variables] + -- Already zonked + -> TcM [TcTyVar] +-- See Note [quantifyTyVars] +-- Can be given a mixture of TcTyVars and TyVars, in the case of +-- associated type declarations. Also accepts covars, but *never* returns any. +-- According to Note [Use level numbers for quantification] and the +-- invariants on CandidateQTvs, we do not have to filter out variables +-- free in the environment here. Just quantify unconditionally, subject +-- to the restrictions in Note [quantifyTyVars]. +quantifyTyVars skol_info ns_strat dvs + -- short-circuit common case + | isEmptyCandidates dvs + = do { traceTc "quantifyTyVars has nothing to quantify" empty + ; return [] } + + | otherwise + = do { traceTc "quantifyTyVars {" + ( vcat [ text "ns_strat =" <+> ppr ns_strat + , text "dvs =" <+> ppr dvs ]) + + ; undefaulted <- defaultTyVars ns_strat dvs + ; final_qtvs <- liftZonkM $ mapMaybeM zonk_quant undefaulted + + ; traceTc "quantifyTyVars }" + (vcat [ text "undefaulted:" <+> pprTyVars undefaulted + , text "final_qtvs:" <+> pprTyVars final_qtvs ]) + + -- We should never quantify over coercion variables; check this + ; let co_vars = filter isCoVar final_qtvs + ; massertPpr (null co_vars) (ppr co_vars) + + ; return final_qtvs } + where + -- zonk_quant returns a tyvar if it should be quantified over; + -- otherwise, it returns Nothing. The latter case happens for + -- non-meta-tyvars + zonk_quant tkv + | not (isTyVar tkv) + = return Nothing -- this can happen for a covar that's associated with + -- a coercion hole. Test case: typecheck/should_compile/T2494 + + | otherwise + = Just <$> skolemiseQuantifiedTyVar skol_info tkv + +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. +-- (Because non-CUSK type declarations use TyVarTvs.) +-- Regardless, it may have a kind that has not yet been zonked, +-- and may include kind unification variables. +zonkAndSkolemise skol_info tyvar + | isTyVarTyVar tyvar + -- We want to preserve the binding location of the original TyVarTv. + -- This is important for error messages. If we don't do this, then + -- we get bad locations in, e.g., typecheck/should_fail/T2688 + = do { zonked_tyvar <- zonkTcTyVarToTcTyVar tyvar + ; skolemiseQuantifiedTyVar skol_info zonked_tyvar } + + | otherwise + = assertPpr (isImmutableTyVar tyvar || isCoVar tyvar) (pprTyVar tyvar) $ + zonkTyCoVarKind tyvar + +skolemiseQuantifiedTyVar :: SkolemInfo -> TcTyVar -> ZonkM TcTyVar +-- The quantified type variables often include meta type variables +-- we want to freeze them into ordinary type variables +-- The meta tyvar is updated to point to the new skolem TyVar. Now any +-- bound occurrences of the original type variable will get zonked to +-- the immutable version. +-- +-- We leave skolem TyVars alone; they are immutable. +-- +-- This function is called on both kind and type variables, +-- but kind variables *only* if PolyKinds is on. + +skolemiseQuantifiedTyVar skol_info tv + = case tcTyVarDetails tv of + MetaTv {} -> skolemiseUnboundMetaTyVar skol_info tv + + SkolemTv _ lvl _ -- It might be a skolem type variable, + -- for example from a user type signature + -- But it might also be a shared meta-variable across several + -- type declarations, each with its own skol_info. The first + -- will skolemise it, but the other uses must update its + -- skolem info (#22379) + -> do { kind <- zonkTcType (tyVarKind tv) + ; let details = SkolemTv skol_info lvl False + name = tyVarName tv + ; return (mkTcTyVar name kind details) } + + _other -> pprPanic "skolemiseQuantifiedTyVar" (ppr tv) -- RuntimeUnk + +-- | Default a type variable using the given defaulting strategy. +-- +-- See Note [Type variable defaulting options] in GHC.Types.Basic. +defaultTyVar :: DefaultingStrategy + -> TcTyVar -- If it's a MetaTyVar then it is unbound + -> TcM Bool -- True <=> defaulted away altogether +defaultTyVar def_strat tv + | not (isMetaTyVar tv) + || isTyVarTyVar tv + -- Do not default TyVarTvs. Doing so would violate the invariants + -- on TyVarTvs; see Note [TyVarTv] in GHC.Tc.Utils.TcMType. + -- #13343 is an example; #14555 is another + -- See Note [Inferring kinds for type declarations] in GHC.Tc.TyCl + = return False + + | isRuntimeRepVar tv + , default_ns_vars + = do { traceTc "Defaulting a RuntimeRep var to LiftedRep" (ppr tv) + ; liftZonkM $ writeMetaTyVar tv liftedRepTy + ; return True } + + | isLevityVar tv + , default_ns_vars + = do { traceTc "Defaulting a Levity var to Lifted" (ppr tv) + ; liftZonkM $ writeMetaTyVar tv liftedDataConTy + ; return True } + + | isMultiplicityVar tv + , default_ns_vars + = do { traceTc "Defaulting a Multiplicity var to Many" (ppr tv) + ; liftZonkM $ writeMetaTyVar tv manyDataConTy + ; return True } + + | isConcreteTyVar tv + -- We don't want to quantify; but neither can we default to + -- anything sensible. (If it has kind RuntimeRep or Levity, as is + -- often the case, it'll have been caught earlier by earlier + -- cases. So in this exotic situation we just promote. Not very + -- satisfing, but it's very much a corner case: #23051 + -- We should really implement the plan in #20686. + = do { lvl <- getTcLevel + ; _ <- promoteMetaTyVarTo lvl tv + ; return True } + + | DefaultKindVars <- def_strat -- -XNoPolyKinds and this is a kind var: we must default it + = default_kind_var tv + + | otherwise + = return False + + where + default_ns_vars :: Bool + default_ns_vars = defaultNonStandardTyVars def_strat + default_kind_var :: TyVar -> TcM Bool + -- defaultKindVar is used exclusively with -XNoPolyKinds + -- See Note [Defaulting with -XNoPolyKinds] + -- It takes an (unconstrained) meta tyvar and defaults it. + -- Works only on vars of type *; for other kinds, it issues an error. + default_kind_var kv + | isLiftedTypeKind (tyVarKind kv) + = do { traceTc "Defaulting a kind var to *" (ppr kv) + ; liftZonkM $ writeMetaTyVar kv liftedTypeKind + ; return True } + | otherwise + = 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 + -- Note [Recipe for checking a signature] + -- Otherwise we get level-number assertion failures. It doesn't matter much + -- because we are in an error situation anyway. + ; return False + } + +-- | Default some unconstrained type variables, as specified +-- by the defaulting options: +-- +-- - 'RuntimeRep' tyvars default to 'LiftedRep' +-- - 'Levity' tyvars default to 'Lifted' +-- - 'Multiplicity' tyvars default to 'Many' +-- - 'Type' tyvars from dv_kvs default to 'Type', when -XNoPolyKinds +-- (under -XNoPolyKinds, non-defaulting vars in dv_kvs is an error) +defaultTyVars :: NonStandardDefaultingStrategy + -> CandidatesQTvs -- ^ all candidates for quantification + -> TcM [TcTyVar] -- ^ those variables not defaulted +defaultTyVars ns_strat dvs + = do { poly_kinds <- xoptM LangExt.PolyKinds + ; let + def_tvs, def_kvs :: DefaultingStrategy + def_tvs = NonStandardDefaulting ns_strat + def_kvs | poly_kinds = def_tvs + | otherwise = DefaultKindVars + -- As -XNoPolyKinds precludes polymorphic kind variables, we default them. + -- For example: + -- + -- type F :: Type -> Type + -- type family F a where + -- F (a -> b) = b + -- + -- Here we get `a :: TYPE r`, so to accept this program when -XNoPolyKinds is enabled + -- we must default the kind variable `r :: RuntimeRep`. + -- Test case: T20584. + ; defaulted_kvs <- mapM (defaultTyVar def_kvs) dep_kvs + ; defaulted_tvs <- mapM (defaultTyVar def_tvs) nondep_tvs + ; let undefaulted_kvs = [ kv | (kv, False) <- dep_kvs `zip` defaulted_kvs ] + undefaulted_tvs = [ tv | (tv, False) <- nondep_tvs `zip` defaulted_tvs ] + ; return (undefaulted_kvs ++ undefaulted_tvs) } + -- NB: kvs before tvs because tvs may depend on kvs + where + (dep_kvs, nondep_tvs) = candidateVars dvs + +skolemiseUnboundMetaTyVar :: SkolemInfo -> TcTyVar -> ZonkM TyVar +-- We have a Meta tyvar with a ref-cell inside it +-- Skolemise it, so that we are totally out of Meta-tyvar-land +-- We create a skolem TcTyVar, not a regular TyVar +-- See Note [Zonking to Skolem] +-- +-- Its level should be one greater than the ambient level, which will typically +-- be the same as the level on the meta-tyvar. But not invariably; for example +-- f :: (forall a b. SameKind a b) -> Int +-- The skolems 'a' and 'b' are bound by tcTKTelescope, at level 2; and they each +-- have a level-2 kind unification variable, since it might get unified with another +-- of the level-2 skolems e.g. 'k' in this version +-- f :: (forall k (a :: k) b. SameKind a b) -> Int +-- So when we quantify the kind vars at the top level of the signature, the ambient +-- level is 1, but we will quantify over kappa[2]. + +skolemiseUnboundMetaTyVar skol_info tv + = assertPpr (isMetaTyVar tv) (ppr tv) $ + do { check_empty tv + -- Get the location and level from "here", + -- i.e. where we are generalising + ; ZonkGblEnv { zge_src_span = here, zge_tc_level = tc_lvl } + <- getZonkGblEnv + ; kind <- zonkTcType (tyVarKind tv) + ; let tv_name = tyVarName tv + -- See Note [Skolemising and identity] + final_name | isSystemName tv_name + = mkInternalName (nameUnique tv_name) + (nameOccName tv_name) here + | otherwise + = tv_name + details = SkolemTv skol_info (pushTcLevel tc_lvl) False + final_tv = mkTcTyVar final_name kind details + + ; traceZonk "Skolemising" (ppr tv <+> text ":=" <+> ppr final_tv) + ; writeMetaTyVar tv (mkTyVarTy final_tv) + ; return final_tv } + where + check_empty tv -- [Sept 04] Check for non-empty. + = when debugIsOn $ -- See Note [Silly Type Synonyms] + do { cts <- readMetaTyVar tv + ; case cts of + Flexi -> return () + Indirect ty -> warnPprTrace True "skolemiseUnboundMetaTyVar" (ppr tv $$ ppr ty) $ + return () } + +{- Note [Error on unconstrained meta-variables] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + +* type C :: Type -> Type -> Constraint + class (forall a. a b ~ a c) => C b c + +* type T = forall a. Proxy a + +* data (forall a. a b ~ a c) => T b c + +* type instance F Int = Proxy Any + where Any :: forall k. k + +In the first three cases we will infer a :: Type -> kappa, but then +we get no further information on kappa. In the last, we will get + Proxy kappa Any +but again will get no further info on kappa. + +What do do? + A. We could choose kappa := Type. But this only works when the kind of kappa + is Type (true in this example, but not always). + B. We could default to Any. + C. We could quantify. + D. We could error. + +We choose (D), as described in #17567, and implement this choice in +doNotQuantifyTyVars. Discussion of alternatives A-C is below. + +NB: this is all rather similar to, but sadly not the same as + Note [Naughty quantification candidates] + +To do this, we must take an extra step before doing the final zonk to create +e.g. a TyCon. (There is no problem in the final term-level zonk. See the +section on alternative (B) below.) This extra step is needed only for +constructs that do not quantify their free meta-variables, such as a class +constraint or right-hand side of a type synonym. + +Specifically: before the final zonk, every construct must either call +quantifyTyVars or doNotQuantifyTyVars. The latter issues an error +if it is passed any free variables. (Exception: we still default +RuntimeRep and Multiplicity variables.) + +Because no meta-variables remain after quantifying or erroring, we perform +the zonk with NoFlexi, which panics upon seeing a meta-variable. + +Alternatives A-C, not implemented: + +A. As stated above, this works only sometimes. We might have a free + meta-variable of kind Nat, for example. + +B. This is what we used to do, but it caused Any to appear in error + messages sometimes. See #17567 for several examples. Defaulting to + Any during the final, whole-program zonk is OK, though, because + we are completely done type-checking at that point. No chance to + leak into an error message. + +C. Examine the class declaration at the top of this Note again. + Where should we quantify? We might imagine quantifying and + putting the kind variable in the forall of the quantified constraint. + But what if there are nested foralls? Which one should get the + variable? Other constructs have other problems. (For example, + the right-hand side of a type family instance equation may not + be a poly-type.) + + More broadly, the GHC AST defines a set of places where it performs + implicit lexical generalization. For example, in a type + signature + + f :: Proxy a -> Bool + + the otherwise-unbound a is lexically quantified, giving us + + f :: forall a. Proxy a -> Bool + + The places that allow lexical quantification are marked in the AST with + HsImplicitBndrs. HsImplicitBndrs offers a binding site for otherwise-unbound + variables. + + Later, during type-checking, we discover that a's kind is unconstrained. + We thus quantify *again*, to + + f :: forall {k} (a :: k). Proxy @k a -> Bool + + It is this second quantification that this Note is really about -- + let's call it *inferred quantification*. + So there are two sorts of implicit quantification in types: + 1. Lexical quantification: signalled by HsImplicitBndrs, occurs over + variables mentioned by the user but with no explicit binding site, + suppressed by a user-written forall (by the forall-or-nothing rule, + in Note [forall-or-nothing rule] in GHC.Hs.Type). + 2. Inferred quantification: no signal in HsSyn, occurs over unconstrained + variables invented by the type-checker, possible only with -XPolyKinds, + unaffected by forall-or-nothing rule + These two quantifications are performed in different compiler phases, and are + essentially unrelated. However, it is convenient + for programmers to remember only one set of implicit quantification + sites. So, we choose to use the same places (those with HsImplicitBndrs) + for lexical quantification as for inferred quantification of unconstrained + meta-variables. Accordingly, there is no quantification in a class + constraint, or the other constructs that call doNotQuantifyTyVars. +-} + +doNotQuantifyTyVars :: CandidatesQTvs + -> (TidyEnv -> ZonkM (TidyEnv, UninferrableTyVarCtx)) + -- ^ like "the class context (D a b, E foogle)" + -> TcM () +-- See Note [Error on unconstrained meta-variables] +doNotQuantifyTyVars dvs where_found + | isEmptyCandidates dvs + = traceTc "doNotQuantifyTyVars has nothing to error on" empty + + | otherwise + = do { traceTc "doNotQuantifyTyVars" (ppr dvs) + ; undefaulted <- defaultTyVars DefaultNonStandardTyVars dvs + -- could have regular TyVars here, in an associated type RHS, or + -- bound by a type declaration head. So filter looking only for + -- metavars. e.g. b and c in `class (forall a. a b ~ a c) => C b c` + -- are OK + ; let leftover_metas = filter isMetaTyVar undefaulted + ; unless (null 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) } + ; traceTc "doNotQuantifyTyVars success" empty } + +{- Note [Defaulting with -XNoPolyKinds] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + + data Compose f g a = Mk (f (g a)) + +We infer + + Compose :: forall k1 k2. (k2 -> *) -> (k1 -> k2) -> k1 -> * + Mk :: forall k1 k2 (f :: k2 -> *) (g :: k1 -> k2) (a :: k1). + f (g a) -> Compose k1 k2 f g a + +Now, in another module, we have -XNoPolyKinds -XDataKinds in effect. +What does 'Mk mean? Pre GHC-8.0 with -XNoPolyKinds, +we just defaulted all kind variables to *. But that's no good here, +because the kind variables in 'Mk aren't of kind *, so defaulting to * +is ill-kinded. + +After some debate on #11334, we decided to issue an error in this case. +The code is in defaultKindVar. + +Note [What is a meta variable?] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +A "meta type-variable", also know as a "unification variable" is a placeholder +introduced by the typechecker for an as-yet-unknown monotype. + +For example, when we see a call `reverse (f xs)`, we know that we calling + reverse :: forall a. [a] -> [a] +So we know that the argument `f xs` must be a "list of something". But what is +the "something"? We don't know until we explore the `f xs` a bit more. So we set +out what we do know at the call of `reverse` by instantiating its type with a fresh +meta tyvar, `alpha` say. So now the type of the argument `f xs`, and of the +result, is `[alpha]`. The unification variable `alpha` stands for the +as-yet-unknown type of the elements of the list. + +As type inference progresses we may learn more about `alpha`. For example, suppose +`f` has the type + f :: forall b. b -> [Maybe b] +Then we instantiate `f`'s type with another fresh unification variable, say +`beta`; and equate `f`'s result type with reverse's argument type, thus +`[alpha] ~ [Maybe beta]`. + +Now we can solve this equality to learn that `alpha ~ Maybe beta`, so we've +refined our knowledge about `alpha`. And so on. + +If you found this Note useful, you may also want to have a look at +Section 5 of "Practical type inference for higher rank types" (Peyton Jones, +Vytiniotis, Weirich and Shields. J. Functional Programming. 2011). + +Note [Zonking to Skolem] +~~~~~~~~~~~~~~~~~~~~~~~~ +We used to zonk quantified type variables to regular TyVars. However, this +leads to problems. Consider this program from the regression test suite: + + eval :: Int -> String -> String -> String + eval 0 root actual = evalRHS 0 root actual + + evalRHS :: Int -> a + evalRHS 0 root actual = eval 0 root actual + +It leads to the deferral of an equality (wrapped in an implication constraint) + + forall a. () => ((String -> String -> String) ~ a) + +which is propagated up to the toplevel (see GHC.Tc.Solver.tcSimplifyInferCheck). +In the meantime `a' is zonked and quantified to form `evalRHS's signature. +This has the *side effect* of also zonking the `a' in the deferred equality +(which at this point is being handed around wrapped in an implication +constraint). + +Finally, the equality (with the zonked `a') will be handed back to the +simplifier by GHC.Tc.Module.tcRnSrcDecls calling GHC.Tc.Solver.tcSimplifyTop. +If we zonk `a' with a regular type variable, we will have this regular type +variable now floating around in the simplifier, which in many places assumes to +only see proper TcTyVars. + +We can avoid this problem by zonking with a skolem TcTyVar. The +skolem is rigid (which we require for a quantified variable), but is +still a TcTyVar that the simplifier knows how to deal with. + +Note [Skolemising and identity] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In some places, we make a TyVarTv for a binder. E.g. + class C a where ... +As Note [Inferring kinds for type declarations] discusses, +we make a TyVarTv for 'a'. Later we skolemise it, and we'd +like to retain its identity, location info etc. (If we don't +retain its identity we'll have to do some pointless swizzling; +see GHC.Tc.TyCl.swizzleTcTyConBndrs. If we retain its identity +but not its location we'll lose the detailed binding site info. + +Conclusion: use the Name of the TyVarTv. But we don't want +to do that when skolemising random unification variables; +there the location we want is the skolemisation site. + +Fortunately we can tell the difference: random unification +variables have System Names. That's why final_name is +set based on the isSystemName test. + + +Note [Silly Type Synonyms] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this: + type C u a = u -- Note 'a' unused + + foo :: (forall a. C u a -> C u a) -> u + foo x = ... + + bar :: Num u => u + bar = foo (\t -> t + t) + +* From the (\t -> t+t) we get type {Num d} => d -> d + where d is fresh. + +* Now unify with type of foo's arg, and we get: + {Num (C d a)} => C d a -> C d a + where a is fresh. + +* Now abstract over the 'a', but float out the Num (C d a) constraint + because it does not 'really' mention a. (see exactTyVarsOfType) + The arg to foo becomes + \/\a -> \t -> t+t + +* So we get a dict binding for Num (C d a), which is zonked to give + a = () + Note (Sept 04): now that we are zonking quantified type variables + on construction, the 'a' will be frozen as a regular tyvar on + quantification, so the floated dict will still have type (C d a). + Which renders this whole note moot; happily!] + +* Then the \/\a abstraction has a zonked 'a' in it. + +All very silly. I think its harmless to ignore the problem. We'll end up with +a \/\a in the final result but all the occurrences of a will be zonked to () +-} + +-------------------------------------------------------------------------------- + +-- | @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. +tcCheckUsage :: Name -> Mult -> TcM a -> TcM a +tcCheckUsage name id_mult thing_inside + = do { (local_usage, result) <- tcCollectingUsage thing_inside + ; check_usage (lookupUE local_usage name) + ; tcEmitBindingUsage (deleteUE local_usage name) + ; return result } + where + check_usage :: Usage -> TcM () + -- Checks that the usage of the newly introduced binder is compatible with + -- 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 } } + + -- This is gross. The problem is in test case typecheck/should_compile/T18998: + -- f :: a %1-> Id n a -> Id n a + -- f x (MkId _) = MkId x + -- where MkId is a GADT constructor. Multiplicity polymorphism of constructors + -- invents a new multiplicity variable p[2] for the application MkId x. This + -- variable is at level 2, bumped because of the GADT pattern-match (MkId _). + -- We eventually unify the variable with One, due to the call to tcSubMult in + -- tcCheckUsage. But by then, we're at TcLevel 1, and so the level-check + -- fails. + -- + -- What to do? If we did inference "for real", the sub-multiplicity constraint + -- would end up in the implication of the GADT pattern-match, and all would + -- be well. But we don't have a real sub-multiplicity constraint to put in + -- the implication. (Multiplicity inference works outside the usual generate- + -- constraints-and-solve scheme.) Here, where the multiplicity arrives, we + -- must promote all multiplicity variables to reflect this outer TcLevel. + -- It's reminiscent of floating a constraint, really, so promotion is + -- appropriate. The promoteTcType function works only on types of kind TYPE rr, + -- so we can't use it here. Thus, this dirtiness. + -- + -- It works nicely in practice. + -- + -- We use a set to avoid calling promoteMetaTyVarTo twice on the same + -- metavariable. This happened in #19400. + promote_mult m = do { fvs <- liftZonkM $ zonkTyCoVarsAndFV (tyCoVarsOfType m) + ; any_promoted <- promoteTyVarSet fvs + ; if any_promoted then liftZonkM $ zonkTcType m else return m + } + +{- ********************************************************************* +* * + Short-cuts for overloaded numeric literals +* * +********************************************************************* -} + +-- Overloaded literals. Here mainly because it uses isIntTy etc + +{- Note [Short cut for overloaded literals] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +A literal like "3" means (fromInteger @ty (dNum :: Num ty) (3::Integer)). +But if we have a list like + [4,2,3,2,4,4,2]::[Int] +we use a lot of compile time and space generating and solving all those Num +constraints, and generating calls to fromInteger etc. Better just to cut to +the chase, and cough up an Int literal. Large collections of literals like this +sometimes appear in source files, so it's quite a worthwhile fix. + +So we try to take advantage of whatever nearby type information we have, +to short-cut the process for built-in types. We can do this in two places; + +* In the typechecker, when we are about to typecheck the literal. +* If that fails, in the desugarer, once we know the final type. +-} + +tcShortCutLit :: HsOverLit GhcRn -> ExpRhoType -> TcM (Maybe (HsOverLit GhcTc)) +tcShortCutLit lit@(OverLit { ol_val = val, ol_ext = OverLitRn rebindable _}) exp_res_ty + | not rebindable + , Just res_ty <- checkingExpType_maybe exp_res_ty + = do { dflags <- getDynFlags + ; let platform = targetPlatform dflags + ; case shortCutLit platform val res_ty of + Just expr -> return $ Just $ + lit { ol_ext = OverLitTc False expr res_ty } + Nothing -> return Nothing } + | otherwise + = return Nothing + +shortCutLit :: Platform -> OverLitVal -> TcType -> Maybe (HsExpr GhcTc) +shortCutLit platform val res_ty + = case val of + HsIntegral int_lit -> go_integral int_lit + HsFractional frac_lit -> go_fractional frac_lit + HsIsString s src -> go_string s src + where + go_integral int@(IL src neg i) + | isIntTy res_ty && platformInIntRange platform i + = Just (HsLit noExtField (HsInt noExtField int)) + | isWordTy res_ty && platformInWordRange platform i + = Just (mkLit wordDataCon (HsWordPrim src i)) + | isIntegerTy res_ty + = Just (HsLit noExtField (XLit $ HsInteger src i res_ty)) + | otherwise + = go_fractional (integralFractionalLit neg i) + -- The 'otherwise' case is important + -- Consider (3 :: Float). Syntactically it looks like an IntLit, + -- so we'll call shortCutIntLit, but of course it's a float + -- This can make a big difference for programs with a lot of + -- literals, compiled without -O + + go_fractional f + | isFloatTy res_ty && valueInRange = Just (mkLit floatDataCon (HsFloatPrim noExtField f)) + | isDoubleTy res_ty && valueInRange = Just (mkLit doubleDataCon (HsDoublePrim noExtField f)) + | otherwise = Nothing + where + valueInRange = + case f of + FL { fl_exp = e } -> (-100) <= e && e <= 100 + -- We limit short-cutting Fractional Literals to when their power of 10 + -- is less than 100, which ensures desugaring isn't slow. + + go_string src s + | isStringTy res_ty = Just (HsLit noExtField (HsString src s)) + | otherwise = Nothing + +mkLit :: DataCon -> HsLit GhcTc -> HsExpr GhcTc +mkLit con lit = HsApp noExtField (nlHsDataCon con) (nlHsLit lit) + +------------------------------ +hsOverLitName :: OverLitVal -> Name +-- Get the canonical 'fromX' name for a particular OverLitVal +hsOverLitName (HsIntegral {}) = fromIntegerName +hsOverLitName (HsFractional {}) = fromRationalName +hsOverLitName (HsIsString {}) = fromStringName + + +{- ********************************************************************* +* * + Promotion +* * +********************************************************************* -} + +promoteMetaTyVarTo :: HasDebugCallStack => TcLevel -> TcTyVar -> TcM Bool +-- When we float a constraint out of an implication we must restore +-- 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 [Promote monomorphic tyvars] in GHC.Tc.Solver +promoteMetaTyVarTo tclvl tv + | assertPpr (isMetaTyVar tv) (ppr tv) $ + tcTyVarLevel tv `strictlyDeeperThan` tclvl + = do { cloned_tv <- cloneMetaTyVar tv + ; let rhs_tv = setMetaTyVarTcLevel cloned_tv tclvl + ; liftZonkM $ writeMetaTyVar tv (mkTyVarTy rhs_tv) + ; traceTc "promoteTyVar" (ppr tv <+> text "-->" <+> ppr rhs_tv) + ; return True } + | otherwise + = return False + +-- Returns whether or not *any* tyvar is defaulted +promoteTyVarSet :: HasDebugCallStack => TcTyVarSet -> TcM Bool +promoteTyVarSet tvs + = do { tclvl <- getTcLevel + ; bools <- mapM (promoteMetaTyVarTo tclvl) $ + filter isPromotableMetaTyVar $ + nonDetEltsUniqSet tvs + -- Non-determinism is OK because order of promotion doesn't matter + ; return (or bools) } + +{- +%************************************************************************ +%* * + Representation polymorphism checks +* * +***********************************************************************-} + +-- | Check that the specified type has a fixed runtime representation. +-- +-- If it isn't, throw a representation-polymorphism error appropriate +-- for the context (as specified by the 'FixedRuntimeRepProvenance'). +-- +-- Unlike the other representation polymorphism checks, which can emit +-- new Wanted constraints to be solved by the constraint solver, this function +-- does not emit any constraints: it has enough information to immediately +-- make a decision. +-- +-- See (1) in Note [Representation polymorphism checking] in GHC.Tc.Utils.Concrete +checkTypeHasFixedRuntimeRep :: FixedRuntimeRepProvenance -> Type -> TcM () +checkTypeHasFixedRuntimeRep prov ty = + unless (typeHasFixedRuntimeRep ty) + (addDetailedDiagnostic $ TcRnTypeDoesNotHaveFixedRuntimeRep ty prov) + +{- ********************************************************************** +* * + Error messages +* * +********************************************************************** -} + +-- See Note [Naughty quantification candidates] +naughtyQuantification :: TcType -- original type user wanted to quantify + -> TcTyVar -- naughty var + -> TyVarSet -- skolems that would escape + -> TcM a +naughtyQuantification orig_ty tv escapees + = do { (orig_ty1, escapees') <- liftZonkM $ + do { orig_ty1 <- zonkTcType orig_ty -- in case it's not zonked + ; escapees' <- zonkTcTyVarsToTcTyVars $ + nonDetEltsUniqSet escapees + -- we'll just be printing, so no harmful non-determinism + ; return (orig_ty1, escapees') } + + ; let fvs = tyCoVarsOfTypeList orig_ty1 + env0 = tidyFreeTyCoVars emptyTidyEnv fvs + env = env0 `delTidyEnvList` escapees' + -- this avoids gratuitous renaming of the escaped + -- variables; very confusing to users! + + orig_ty' = tidyType env orig_ty1 + tidied = map (tidyTyCoVarOcc env) escapees' + msg = TcRnSkolemEscape tidied (tidyTyCoVarOcc env tv) orig_ty' + + ; failWithTcM (env, msg) } 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,23 +24,27 @@ -------------------------------- -- 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, -------------------------------- -- TcLevel TcLevel(..), topTcLevel, pushTcLevel, isTopTcLevel, strictlyDeeperThan, deeperThanOrSame, sameDepthAs, - tcTypeLevel, tcTyVarLevel, maxTcLevel, + tcTypeLevel, tcTyVarLevel, maxTcLevel, minTcLevel, -------------------------------- -- MetaDetails @@ -47,9 +53,11 @@ isImmutableTyVar, isSkolemTyVar, isMetaTyVar, isMetaTyVarTy, isTyVarTy, tcIsTcTyVar, isTyVarTyVar, isOverlappableTyVar, isTyConableTyVar, ConcreteTvOrigin(..), isConcreteTyVar_maybe, isConcreteTyVar, - isConcreteTyVarTy, isConcreteTyVarTy_maybe, + isConcreteTyVarTy, isConcreteTyVarTy_maybe, concreteInfo_maybe, + ConcreteTyVars, noConcreteTyVars, isAmbiguousTyVar, isCycleBreakerTyVar, metaTyVarRef, metaTyVarInfo, isFlexi, isIndirect, isRuntimeUnkSkol, + isQLInstTyVar, isRuntimeUnkTyVar, metaTyVarTcLevel, setMetaTyVarTcLevel, metaTyVarTcLevel_maybe, isTouchableMetaTyVar, isPromotableMetaTyVar, findDupTyVarTvs, mkTyVarNamePairs, @@ -62,7 +70,7 @@ -------------------------------- -- Splitters getTyVar, getTyVar_maybe, getCastedTyVar_maybe, - tcSplitForAllTyVarBinder_maybe, + tcSplitForAllTyVarBinder_maybe, tcSplitForAllTyVarsReqTVBindersN, tcSplitForAllTyVars, tcSplitForAllInvisTyVars, tcSplitSomeForAllTyVars, tcSplitForAllReqTVBinders, tcSplitForAllInvisTVBinders, tcSplitPiTys, tcSplitPiTy_maybe, tcSplitForAllTyVarBinders, @@ -72,7 +80,7 @@ tcSplitTyConApp, tcSplitTyConApp_maybe, tcTyConAppTyCon, tcTyConAppTyCon_maybe, tcTyConAppArgs, tcSplitAppTy_maybe, tcSplitAppTy, tcSplitAppTys, tcSplitAppTyNoView_maybe, - tcSplitSigmaTy, tcSplitNestedSigmaTys, + tcSplitSigmaTy, tcSplitSigmaTyBndrs, tcSplitNestedSigmaTys, tcSplitIOType_maybe, --------------------------------- -- Predicates. @@ -80,25 +88,23 @@ 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, + 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, --------------------------------- -- Misc type manipulators deNoteType, - orphNamesOfType, orphNamesOfCo, - orphNamesOfTypes, orphNamesOfCoCon, getDFunTyKey, evVarPred, ambigTkvsOfTy, @@ -114,31 +120,17 @@ -- * Finding "exact" (non-dead) type variables exactTyCoVarsOfType, exactTyCoVarsOfTypes, - anyRewritableTyVar, anyRewritableTyFamApp, - - --------------------------------- - -- Foreign import and export - IllegalForeignTypeReason(..), - TypeCannotBeMarshaledReason(..), - isFFIArgumentTy, -- :: DynFlags -> Safety -> Type -> Bool - isFFIImportResultTy, -- :: DynFlags -> Type -> Bool - isFFIExportResultTy, -- :: Type -> Bool - isFFIExternalTy, -- :: Type -> Bool - isFFIDynTy, -- :: Type -> Type -> Bool - isFFIPrimArgumentTy, -- :: DynFlags -> Type -> Bool - isFFIPrimResultTy, -- :: DynFlags -> Type -> Bool - isFFILabelTy, -- :: Type -> Bool - isFunPtrTy, -- :: Type -> Bool - tcSplitIOType_maybe, -- :: Type -> Maybe Type + anyRewritableTyVar, anyRewritableTyFamApp, UnderFam, --------------------------------- -- Patersons sizes - PatersonSize(..), PatersonSizeFailure(..), + PatersonSize(..), PatersonCondFailure(..), + PatersonCondFailureContext(..), ltPatersonSize, pSizeZero, pSizeOne, pSizeType, pSizeTypeX, pSizeTypes, pSizeClassPred, pSizeClassPredX, - pSizeTyConApp, + pSizeTyConApp, pSizeHead, noMoreTyVars, allDistinctTyVars, TypeSize, sizeType, sizeTypes, scopedSort, isTerminatingClass, isStuckTypeFamily, @@ -163,8 +155,8 @@ mkTyConTy, mkTyVarTy, mkTyVarTys, mkTyCoVarTy, mkTyCoVarTys, - isClassPred, isEqPrimPred, isIPLikePred, isEqPred, isEqPredClass, - mkClassPred, + isClassPred, isEqPred, couldBeIPLike, isEqClassPred, + isEqualityClass, mkClassPred, tcSplitQuantPredTy, tcSplitDFunTy, tcSplitDFunHead, tcSplitMethodTy, isRuntimeRepVar, isFixedRuntimeRepKind, isVisiblePiTyBinder, isInvisiblePiTyBinder, @@ -174,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, @@ -207,7 +199,7 @@ --------------------------------- -- argument visibility - tcTyConVisibilities, isNextTyConArgVisible, isNextArgVisible + tyConVisibilities, isNextTyConArgVisible, isNextArgVisible ) where @@ -221,12 +213,10 @@ import GHC.Core.TyCo.Ppr import GHC.Core.Class import GHC.Types.Var -import GHC.Types.ForeignCall import GHC.Types.Var.Set import GHC.Core.Coercion import GHC.Core.Type as Type import GHC.Core.Predicate -import GHC.Types.RepType import GHC.Core.TyCon import {-# SOURCE #-} GHC.Tc.Types.Origin @@ -234,14 +224,13 @@ , FixedRuntimeRepOrigin, FixedRuntimeRepContext ) -- others: -import GHC.Driver.Session -import GHC.Core.FVs 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, unitTyCon, unitTyConKey +import GHC.Builtin.Types ( coercibleClass, eqClass, heqClass, unitTyConKey , listTyCon, constraintKind ) import GHC.Types.Basic import GHC.Utils.Misc @@ -249,17 +238,11 @@ import GHC.Data.List.SetOps ( getNth, findDupsEq ) import GHC.Utils.Outputable import GHC.Utils.Panic -import GHC.Utils.Panic.Plain -import GHC.Utils.Error( Validity'(..) ) -import GHC.Utils.Unique (anyOfUnique) -import qualified GHC.LanguageExtensions as LangExt -import Data.IORef +import Data.IORef ( IORef ) import Data.List.NonEmpty( NonEmpty(..) ) import Data.List ( partition, nub, (\\) ) -import GHC.Generics ( Generic ) - {- ************************************************************************ * * @@ -372,7 +355,7 @@ type TcInvisTVBinder = InvisTVBinder type TcReqTVBinder = ReqTVBinder --- See Note [TcTyCon, MonoTcTyCon, and PolyTcTyCon] +-- See Note [TcTyCon, MonoTcTyCon, and PolyTcTyCon] in GHC.Tc.TyCl type TcTyCon = TyCon type MonoTcTyCon = TcTyCon type PolyTcTyCon = TcTyCon @@ -397,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 @@ -406,51 +390,7 @@ type TcDTyVarSet = DTyVarSet type TcDTyCoVarSet = DTyCoVarSet -{- Note [TcTyCon, MonoTcTyCon, and PolyTcTyCon] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -See Note [How TcTyCons work] in GHC.Tc.TyCl -Invariants: - -* TcTyCon: a TyCon built with the TcTyCon constructor - -* TcTyConBinder: a TyConBinder with a TcTyVar inside (not a TyVar) - -* TcTyCons contain TcTyVars - -* MonoTcTyCon: - - Flag tcTyConIsPoly = False - - - tyConScopedTyVars is important; maps a Name to a TyVarTv unification variable - The order is important: Specified then Required variables. E.g. in - data T a (b :: k) = ... - the order will be [k, a, b]. - - NB: There are no Inferred binders in tyConScopedTyVars; 'a' may - also be poly-kinded, but that kind variable will be added by - generaliseTcTyCon, in the passage to a PolyTcTyCon. - - - tyConBinders are irrelevant; we just use tcTyConScopedTyVars - Well not /quite/ irrelevant: its length gives the number of Required binders, - and so allows up to distinguish between the Specified and Required elements of - tyConScopedTyVars. - -* PolyTcTyCon: - - Flag tcTyConIsPoly = True; this is used only to short-cut zonking - - - tyConBinders are still TcTyConBinders, but they are /skolem/ TcTyVars, - with fixed kinds, and accurate skolem info: no unification variables here - - tyConBinders includes the Inferred binders if any - - tyConBinders uses the Names from the original, renamed program. - - - tcTyConScopedTyVars is irrelevant: just use (binderVars tyConBinders) - All the types have been swizzled back to use the original Names - See Note [tyConBinders and lexical scoping] in GHC.Core.TyCon - --} - {- ********************************************************************* * * ExpType: an "expected type" in the type checker @@ -469,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@. @@ -480,40 +424,106 @@ -- @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 mkCheckExpType = Check +-- | Returns the expected type when in checking mode. +checkingExpType_maybe :: ExpType -> Maybe TcType +checkingExpType_maybe (Check ty) = Just ty +checkingExpType_maybe (Infer {}) = Nothing +-- | 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 @@ -605,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: @@ -628,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 @@ -637,7 +648,7 @@ , mtv_ref :: IORef MetaDetails , mtv_tclvl :: TcLevel } -- See Note [TcLevel invariants] -vanillaSkolemTvUnk :: HasCallStack => TcTyVarDetails +vanillaSkolemTvUnk :: HasDebugCallStack => TcTyVarDetails vanillaSkolemTvUnk = SkolemTv unkSkol topTcLevel False instance Outputable TcTyVarDetails where @@ -657,7 +668,7 @@ | Indirect TcType -- | What restrictions are on this metavariable around unification? --- These are checked in GHC.Tc.Utils.Unify.startSolvingByUnification. +-- These are checked in GHC.Tc.Utils.Unify.checkTopShape data MetaInfo = TauTv -- ^ This MetaTv is an ordinary unification variable -- A TauTv is always filled in with a tau-type, which @@ -670,9 +681,9 @@ | 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.Canonical + -- GHC.Tc.Solver.Equality | ConcreteTv ConcreteTvOrigin -- ^ A unification variable that can only be unified @@ -701,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] @@ -719,6 +741,9 @@ and each Implication has a level number (of type TcLevel) +* INVARIANT (KindInv) Given a type variable (tv::ki) at at level L, + the free vars of `ki` all have level <= L + * INVARIANTS. In a tree of Implications, (ImplicInv) The level number (ic_tclvl) of an Implication is @@ -741,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 @@ -799,37 +845,58 @@ -} 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 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] topTcLevel = TcLevel 0 -- 0 = outermost level 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 @@ -852,7 +919,8 @@ | otherwise = lvl instance Outputable TcLevel where - ppr (TcLevel us) = ppr us + ppr (TcLevel n) = ppr n + ppr QLInstVar = text "qlinst" {- ********************************************************************* * * @@ -903,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 @@ -959,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 @@ -975,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] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1183,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 @@ -1204,6 +1299,10 @@ | otherwise = Nothing +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'? isConcreteTyVar :: TcTyVar -> Bool @@ -1373,7 +1472,7 @@ -- Always succeeds, even if it returns an empty list. tcSplitPiTys :: Type -> ([PiTyVarBinder], Type) tcSplitPiTys ty - = assert (all isTyBinder (fst sty) ) -- No CoVar binders here + = assert (all isTyBinder (fst sty)) -- No CoVar binders here sty where sty = splitPiTys ty @@ -1396,7 +1495,7 @@ -- returning just the tyvars. tcSplitForAllTyVars :: Type -> ([TyVar], Type) tcSplitForAllTyVars ty - = assert (all isTyVar (fst sty) ) sty + = assert (all isTyVar (fst sty)) sty where sty = splitForAllTyCoVars ty -- | Like 'tcSplitForAllTyVars', but only splits 'ForAllTy's with 'Invisible' @@ -1417,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) @@ -1461,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) @@ -1568,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) @@ -1699,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. --------------------------- @@ -1733,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 @@ -1790,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] @@ -1850,7 +1968,7 @@ Notice that in the recursive-superclass case we include C again at the end of the chain. One could exclude C in this case, but the code is more awkward and there seems no good reason to do so. -(However C.f. GHC.Tc.Solver.Canonical.mk_strict_superclasses, which /does/ +(However C.f. GHC.Tc.Solver.Dict.mk_strict_superclasses, which /does/ appear to do so.) The algorithm is expand( so_far, pred ): @@ -1888,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 @@ -1909,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 @@ -1919,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 @@ -1930,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@, @@ -1970,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 {- @@ -2037,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 @@ -2048,251 +2170,8 @@ _ -> Nothing --- | Reason why a type in an FFI signature is invalid -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 !(Maybe TyCon) - | UnliftedFFITypesNeeded - | NotABoxedMarshalableTyCon - | ForeignLabelNotAPtr - | NotSimpleUnliftedType - | NotBoxedKindAny - deriving Generic - -isFFIArgumentTy :: DynFlags -> Safety -> Type -> Validity' IllegalForeignTypeReason --- Checks for valid argument type for a 'foreign import' -isFFIArgumentTy dflags safety ty - = checkRepTyCon (legalOutgoingTyCon dflags safety) ty - -isFFIExternalTy :: Type -> Validity' IllegalForeignTypeReason --- Types that are allowed as arguments of a 'foreign export' -isFFIExternalTy ty = checkRepTyCon legalFEArgTyCon ty - -isFFIImportResultTy :: DynFlags -> Type -> Validity' IllegalForeignTypeReason -isFFIImportResultTy dflags ty - = checkRepTyCon (legalFIResultTyCon dflags) ty - -isFFIExportResultTy :: Type -> Validity' IllegalForeignTypeReason -isFFIExportResultTy ty = checkRepTyCon legalFEResultTyCon ty - -isFFIDynTy :: Type -> Type -> Validity' IllegalForeignTypeReason --- The type in a foreign import dynamic must be Ptr, FunPtr, or a newtype of --- either, and the wrapped function type must be equal to the given type. --- We assume that all types have been run through normaliseFfiType, so we don't --- need to worry about expanding newtypes here. -isFFIDynTy expected ty - -- Note [Foreign import dynamic] - -- In the example below, expected would be 'CInt -> IO ()', while ty would - -- be 'FunPtr (CDouble -> IO ())'. - | Just (tc, [ty']) <- splitTyConApp_maybe ty - , anyOfUnique tc [ptrTyConKey, funPtrTyConKey] - , eqType ty' expected - = IsValid - | otherwise - = NotValid (ForeignDynNotPtr expected ty) - -isFFILabelTy :: Type -> Validity' IllegalForeignTypeReason --- The type of a foreign label must be Ptr, FunPtr, or a newtype of either. -isFFILabelTy ty = checkRepTyCon ok ty - where - ok tc | tc `hasKey` funPtrTyConKey || tc `hasKey` ptrTyConKey - = IsValid - | otherwise - = NotValid ForeignLabelNotAPtr - --- | Check validity for a type of the form @Any :: k@. --- --- This function returns: --- --- - @Just IsValid@ for @Any :: Type@ and @Any :: UnliftedType@, --- - @Just (NotValid ..)@ for @Any :: k@ if @k@ is not a kind of boxed types, --- - @Nothing@ if the type is not @Any@. -checkAnyTy :: Type -> Maybe (Validity' IllegalForeignTypeReason) -checkAnyTy ty - | Just ki <- anyTy_maybe ty - = Just $ - if isJust $ kindBoxedRepLevity_maybe ki - then IsValid - -- NB: don't allow things like @Any :: TYPE IntRep@, as per #21305. - else NotValid (TypeCannotBeMarshaled ty NotBoxedKindAny) - | otherwise - = Nothing - -isFFIPrimArgumentTy :: DynFlags -> Type -> Validity' IllegalForeignTypeReason --- Checks for valid argument type for a 'foreign import prim' --- Currently they must all be simple unlifted types, or Any (at kind Type or UnliftedType), --- which can be used to pass the address to a Haskell object on the heap to --- the foreign function. -isFFIPrimArgumentTy dflags ty - | Just validity <- checkAnyTy ty - = validity - | otherwise - = checkRepTyCon (legalFIPrimArgTyCon dflags) ty - -isFFIPrimResultTy :: DynFlags -> Type -> Validity' IllegalForeignTypeReason --- Checks for valid result type for a 'foreign import prim' Currently --- it must be an unlifted type, including unboxed tuples, unboxed --- sums, or the well-known type Any (at kind Type or UnliftedType). -isFFIPrimResultTy dflags ty - | Just validity <- checkAnyTy ty - = validity - | otherwise - = checkRepTyCon (legalFIPrimResultTyCon dflags) ty - -isFunPtrTy :: Type -> Bool -isFunPtrTy ty - | Just (tc, [_]) <- splitTyConApp_maybe ty - = tc `hasKey` funPtrTyConKey - | otherwise - = False - --- normaliseFfiType gets run before checkRepTyCon, so we don't --- need to worry about looking through newtypes or type functions --- here; that's already been taken care of. -checkRepTyCon - :: (TyCon -> Validity' TypeCannotBeMarshaledReason) - -> Type - -> Validity' IllegalForeignTypeReason -checkRepTyCon check_tc ty - = fmap (TypeCannotBeMarshaled ty) $ case splitTyConApp_maybe ty of - Just (tc, tys) - | isNewTyCon tc -> NotValid (mk_nt_reason tc tys) - | otherwise -> check_tc tc - Nothing -> NotValid NotADataType - where - mk_nt_reason tc tys - | null tys = NewtypeDataConNotInScope Nothing - | otherwise = NewtypeDataConNotInScope (Just tc) - {- -Note [Foreign import dynamic] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -A dynamic stub must be of the form 'FunPtr ft -> ft' where ft is any foreign -type. Similarly, a wrapper stub must be of the form 'ft -> IO (FunPtr ft)'. - -We use isFFIDynTy to check whether a signature is well-formed. For example, -given a (illegal) declaration like: - -foreign import ccall "dynamic" - foo :: FunPtr (CDouble -> IO ()) -> CInt -> IO () - -isFFIDynTy will compare the 'FunPtr' type 'CDouble -> IO ()' with the curried -result type 'CInt -> IO ()', and return False, as they are not equal. - - ----------------------------------------------- -These chaps do the work; they are not exported ----------------------------------------------- --} - -legalFEArgTyCon :: TyCon -> Validity' TypeCannotBeMarshaledReason -legalFEArgTyCon tc - -- It's illegal to make foreign exports that take unboxed - -- arguments. The RTS API currently can't invoke such things. --SDM 7/2000 - = boxedMarshalableTyCon tc - -legalFIResultTyCon :: DynFlags -> TyCon -> Validity' TypeCannotBeMarshaledReason -legalFIResultTyCon dflags tc - | tc == unitTyCon = IsValid - | otherwise = marshalableTyCon dflags tc - -legalFEResultTyCon :: TyCon -> Validity' TypeCannotBeMarshaledReason -legalFEResultTyCon tc - | tc == unitTyCon = IsValid - | otherwise = boxedMarshalableTyCon tc - -legalOutgoingTyCon :: DynFlags -> Safety -> TyCon -> Validity' TypeCannotBeMarshaledReason --- Checks validity of types going from Haskell -> external world -legalOutgoingTyCon dflags _ tc - = marshalableTyCon dflags tc - --- Check for marshalability of a primitive type. --- We exclude lifted types such as RealWorld and TYPE. --- They can technically appear in types, e.g. --- f :: RealWorld -> TYPE LiftedRep -> RealWorld --- f x _ = x --- but there are no values of type RealWorld or TYPE LiftedRep, --- so it doesn't make sense to use them in FFI. -marshalablePrimTyCon :: TyCon -> Bool -marshalablePrimTyCon tc = isPrimTyCon tc && not (isLiftedTypeKind (tyConResKind tc)) - -marshalableTyCon :: DynFlags -> TyCon -> Validity' TypeCannotBeMarshaledReason -marshalableTyCon dflags tc - | marshalablePrimTyCon tc - , not (null (tyConPrimRep tc)) -- Note [Marshalling void] - = validIfUnliftedFFITypes dflags - | otherwise - = boxedMarshalableTyCon tc - -boxedMarshalableTyCon :: TyCon -> Validity' TypeCannotBeMarshaledReason -boxedMarshalableTyCon tc - | anyOfUnique tc [ intTyConKey, int8TyConKey, int16TyConKey - , int32TyConKey, int64TyConKey - , wordTyConKey, word8TyConKey, word16TyConKey - , word32TyConKey, word64TyConKey - , floatTyConKey, doubleTyConKey - , ptrTyConKey, funPtrTyConKey - , charTyConKey - , stablePtrTyConKey - , boolTyConKey - ] - = IsValid - - | otherwise = NotValid NotABoxedMarshalableTyCon - -legalFIPrimArgTyCon :: DynFlags -> TyCon -> Validity' TypeCannotBeMarshaledReason --- Check args of 'foreign import prim', only allow simple unlifted types. -legalFIPrimArgTyCon dflags tc - | marshalablePrimTyCon tc - = validIfUnliftedFFITypes dflags - | otherwise - = NotValid NotSimpleUnliftedType - -legalFIPrimResultTyCon :: DynFlags -> TyCon -> Validity' TypeCannotBeMarshaledReason --- Check result type of 'foreign import prim'. Allow simple unlifted --- 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 - = validIfUnliftedFFITypes dflags - - | otherwise - = NotValid $ NotSimpleUnliftedType - -validIfUnliftedFFITypes :: DynFlags -> Validity' TypeCannotBeMarshaledReason -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 --} - -{- ************************************************************************ * * Visiblities @@ -2303,8 +2182,8 @@ -- | For every arg a tycon can take, the returned list says True if the argument -- is taken visibly, and False otherwise. Ends with an infinite tail of Trues to -- allow for oversaturation. -tcTyConVisibilities :: TyCon -> [Bool] -tcTyConVisibilities tc = tc_binder_viss ++ tc_return_kind_viss ++ repeat True +tyConVisibilities :: TyCon -> [Bool] +tyConVisibilities tc = tc_binder_viss ++ tc_return_kind_viss ++ repeat True where tc_binder_viss = map isVisibleTyConBinder (tyConBinders tc) tc_return_kind_viss = map isVisiblePiTyBinder (fst $ tcSplitPiTys (tyConResKind tc)) @@ -2312,13 +2191,14 @@ -- | If the tycon is applied to the types, is the next argument visible? isNextTyConArgVisible :: TyCon -> [Type] -> Bool isNextTyConArgVisible tc tys - = tcTyConVisibilities tc `getNth` length tys + = tyConVisibilities tc `getNth` length tys -- | Should this type be applied to a visible argument? +-- E.g. (s t): is `t` a visible argument of `s`? isNextArgVisible :: TcType -> Bool isNextArgVisible ty - | Just (bndr, _) <- tcSplitPiTy_maybe ty = isVisiblePiTyBinder bndr - | otherwise = True + | Just (bndr, _) <- tcSplitPiTy_maybe (typeKind ty) = isVisiblePiTyBinder bndr + | otherwise = True -- this second case might happen if, say, we have an unzonked TauTv. -- But TauTvs can't range over types that take invisible arguments @@ -2387,18 +2267,29 @@ has a separate call to isStuckTypeFamily, so the `F` above will still be accepted. -} - --- | Why was the LHS 'PatersonSize' not strictly smaller than the RHS 'PatersonSize'? +-- | Why did the Paterson conditions fail; that is, why +-- was the context P not Paterson-smaller than the head H? -- -- See Note [Paterson conditions] in GHC.Tc.Validity. -data PatersonSizeFailure - -- | Either side contains a type family. - = PSF_TyFam TyCon - -- | The size of the LHS is not strictly less than the size of the RHS. - | PSF_Size - -- | These type variables appear more often in the LHS than in the RHS. - | PSF_TyVar [TyVar] -- ^ no duplicates in this list +data PatersonCondFailure + -- | Some type variables occur more often in P than in H. + -- See (PC1) in Note [Paterson conditions] in GHC.Tc.Validity. + = PCF_TyVar + [TyVar] -- ^ the type variables which appear more often in the context + -- | P is not smaller in size than H. + -- See (PC2) in Note [Paterson conditions] in GHC.Tc.Validity. + | PCF_Size + -- | P contains a type family. + -- See (PC3) in Note [Paterson conditions] in GHC.Tc.Validity. + | PCF_TyFam + TyCon -- ^ the type constructor of the type family +-- | Indicates whether a Paterson condition failure occurred in an instance declaration or a type family equation. +-- Useful for differentiating context in error messages. +data PatersonCondFailureContext + = InInstanceDecl + | InTyFamEquation + -------------------------------------- -- | The Paterson size of a given type, in the sense of @@ -2409,7 +2300,6 @@ data PatersonSize -- | The type mentions a type family, so the size could be anything. = PS_TyFam TyCon - -- | The type does not mention a type family. | PS_Vanilla { ps_tvs :: [TyVar] -- ^ free tyvars, including repetitions; , ps_size :: Int -- ^ number of type constructors and variables @@ -2432,14 +2322,14 @@ -- - @Just ps_fail@ otherwise; @ps_fail@ says what went wrong. ltPatersonSize :: PatersonSize -> PatersonSize - -> Maybe PatersonSizeFailure + -> Maybe PatersonCondFailure ltPatersonSize (PS_Vanilla { ps_tvs = tvs1, ps_size = s1 }) (PS_Vanilla { ps_tvs = tvs2, ps_size = s2 }) - | s1 >= s2 = Just PSF_Size - | bad_tvs@(_:_) <- noMoreTyVars tvs1 tvs2 = Just (PSF_TyVar bad_tvs) + | s1 >= s2 = Just PCF_Size + | bad_tvs@(_:_) <- noMoreTyVars tvs1 tvs2 = Just (PCF_TyVar bad_tvs) | otherwise = Nothing -- OK! -ltPatersonSize (PS_TyFam tc) _ = Just (PSF_TyFam tc) -ltPatersonSize _ (PS_TyFam tc) = Just (PSF_TyFam tc) +ltPatersonSize (PS_TyFam tc) _ = Just (PCF_TyFam tc) +ltPatersonSize _ (PS_TyFam tc) = Just (PCF_TyFam tc) -- NB: this last equation is never taken when checking instances, because -- type families are disallowed in instance heads. -- @@ -2507,6 +2397,13 @@ | 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 @@ -2533,11 +2430,11 @@ = isIPClass cls -- Implicit parameter constraints always terminate because -- there are no instances for them --- they are only solved -- by "local instances" in expressions - || isEqPredClass cls + || isEqualityClass cls || cls `hasKey` typeableClassKey -- Typeable constraints are bigger than they appear due -- to kind polymorphism, but we can never get instance divergence this way - || cls `hasKey` coercibleTyConKey + || cls `hasKey` unsatisfiableClassNameKey allDistinctTyVars :: TyVarSet -> [KindOrType] -> Bool -- (allDistinctTyVars tvs tys) returns True if tys are 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,15 +1,22 @@ 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.Stack +import {-# SOURCE #-} GHC.Tc.Types.Origin ( FixedRuntimeRepOrigin ) +import GHC.Types.Name.Env ( NameEnv ) data MetaDetails data TcTyVarDetails pprTcTyVarDetails :: TcTyVarDetails -> SDoc -vanillaSkolemTvUnk :: HasCallStack => TcTyVarDetails +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,2722 +1,4764 @@ -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE RecursiveDo #-} - -{- -(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, unifyExpectedType, - uType, promoteTcType, - swapOverTyVars, startSolvingByUnification, - - -------------------------------- - -- Holes - tcInfer, - matchExpectedListTy, - matchExpectedTyConApp, - matchExpectedAppTy, - matchExpectedFunTys, - matchExpectedFunKind, - matchActualFunTySigma, matchActualFunTysRho, - - checkTyVarEq, checkTyFamEq, checkTypeEq - - ) where - -import GHC.Prelude - -import GHC.Hs - -import GHC.Tc.Utils.Concrete ( hasFixedRuntimeRep, makeTypeConcrete, 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.Core.Type -import GHC.Core.TyCo.Rep -import GHC.Core.TyCo.Ppr( debugPprType ) -import GHC.Core.TyCon -import GHC.Core.Coercion -import GHC.Core.Multiplicity - -import qualified GHC.LanguageExtensions as LangExt - -import GHC.Tc.Types.Evidence -import GHC.Tc.Types.Constraint -import GHC.Tc.Types.Origin -import GHC.Types.Name( Name, isSystemName ) - -import GHC.Builtin.Types -import GHC.Types.Var as Var -import GHC.Types.Var.Set -import GHC.Types.Var.Env -import GHC.Utils.Error -import GHC.Driver.Session -import GHC.Types.Basic -import GHC.Data.Bag -import GHC.Data.FastString( fsLit ) -import GHC.Utils.Misc -import GHC.Utils.Outputable as Outputable -import GHC.Utils.Panic -import GHC.Utils.Panic.Plain - -import GHC.Exts ( inline ) -import Control.Monad -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 -> TcM (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 -> TcM (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 - -> TcM (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) - , checkTyVarEq tv tau `cterHasProblem` cteInsolubleOccurs - -- The tyvar actually occurs (DP2), - -- and occurs in an injective position (DP3). - -- Fortunately checkTyVarEq, used for the occur check, - -- is just what we need. - = 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 <- uType 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 - = uType TypeLevel origin ty1 ty2 - where - origin = TypeEqOrigin { uo_actual = ty1 - , uo_expected = ty2 - , uo_thing = thing - , uo_visible = True } - -unifyTypeET :: TcTauType -> TcTauType -> TcM CoercionN --- Like unifyType, but swap expected and actual in error messages --- This is used when typechecking patterns -unifyTypeET ty1 ty2 - = uType 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 - = uType KindLevel origin ty1 ty2 - where - origin = TypeEqOrigin { uo_actual = ty1 - , uo_expected = ty2 - , uo_thing = mb_thing - , uo_visible = True } - - -{- -%************************************************************************ -%* * - uType and friends -%* * -%************************************************************************ - -uType is the heart of the unifier. --} - -uType, uType_defer - :: TypeOrKind - -> CtOrigin - -> 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] --- ty1 is "actual" --- ty2 is "expected" -uType_defer t_or_k origin ty1 ty2 - = do { co <- emitWantedEq origin t_or_k Nominal ty1 ty2 - - -- 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 [ debugPprType ty1 - , debugPprType ty2 - , pprCtOrigin origin - , doc]) - ; traceTc "utype_defer2" (ppr co) - } - ; return co } - --------------- -uType t_or_k origin orig_ty1 orig_ty2 - = do { tclvl <- getTcLevel - ; traceTc "u_tys" $ vcat - [ text "tclvl" <+> ppr tclvl - , sep [ ppr orig_ty1, text "~", ppr orig_ty2] - , pprCtOrigin origin] - ; 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 t_or_k origin t1 t2 - ; return (mkCoherenceLeftCo Nominal t1 co1 co_tys) } - - go t1 (CastTy t2 co2) - = do { co_tys <- uType t_or_k origin t1 t2 - ; return (mkCoherenceRightCo Nominal 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) - ; go ty1 ty2 } - Nothing -> uUnfilledVar origin t_or_k 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) - ; go ty1 ty2 } - Nothing -> uUnfilledVar origin t_or_k IsSwapped tv2 ty1 } - - -- See Note [Expanding synonyms during unification] - go ty1@(TyConApp tc1 []) (TyConApp tc2 []) - | tc1 == tc2 - = return $ mkNomReflCo 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 - -- Do not attempt (c => t); just defer - 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, af1 == af2 - = do { co_l <- uType t_or_k origin arg1 arg2 - ; co_r <- uType t_or_k origin res1 res2 - ; co_w <- uType t_or_k origin w1 w2 - ; return $ mkNakedFunCo1 Nominal 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 - = assertPpr (isGenerativeTyCon tc1 Nominal) (ppr tc1) $ - do { cos <- zipWith3M (uType t_or_k) origins' tys1 tys2 - ; return $ mkTyConAppCo Nominal tc1 cos } - where - origins' = map (\is_vis -> if is_vis then origin else toInvisibleOrigin origin) - (tcTyConVisibilities tc1) - - go (LitTy m) ty@(LitTy n) - | m == n - = return $ mkNomReflCo 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 (AppTy s1 t1) (AppTy s2 t2) - = go_app (isNextArgVisible s1) s1 t1 s2 t2 - - go (AppTy s1 t1) (TyConApp tc2 ts2) - | Just (ts2', t2') <- snocView ts2 - = assert (not (tyConMustBeSaturated tc2)) $ - go_app (isNextTyConArgVisible tc2 ts2') s1 t1 (TyConApp tc2 ts2') t2' - - go (TyConApp tc1 ts1) (AppTy s2 t2) - | Just (ts1', t1') <- snocView ts1 - = assert (not (tyConMustBeSaturated tc1)) $ - go_app (isNextTyConArgVisible tc1 ts1') (TyConApp tc1 ts1') t1' s2 t2 - - go (CoercionTy co1) (CoercionTy co2) - = do { let ty1 = coercionType co1 - ty2 = coercionType co2 - ; kco <- uType KindLevel - (KindEqOrigin orig_ty1 orig_ty2 origin - (Just t_or_k)) - ty1 ty2 - ; return $ mkProofIrrelCo Nominal 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 (mkNomReflCo ty1) - | otherwise = uType_defer t_or_k origin ty1 ty2 - - ------------------ - go_app vis s1 t1 s2 t2 - = do { co_s <- uType t_or_k origin s1 s2 - ; let arg_origin - | vis = origin - | otherwise = toInvisibleOrigin origin - ; co_t <- uType t_or_k arg_origin t1 t2 - ; return $ mkAppCo co_s co_t } - -{- 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 :: CtOrigin - -> TypeOrKind - -> SwapFlag - -> TcTyVar -- Tyvar 1: not necessarily a meta-tyvar - -- definitely not a /filled/ meta-tyvar - -> TcTauType -- Type 2 - -> TcM Coercion --- "Unfilled" means that the variable is definitely not a filled-in meta tyvar --- It might be a skolem, or untouchable, or meta - -uUnfilledVar origin t_or_k swapped tv1 ty2 - = do { ty2 <- 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 origin t_or_k swapped tv1 ty2 } - ----------- -uUnfilledVar1 :: CtOrigin - -> TypeOrKind - -> SwapFlag - -> TcTyVar -- Tyvar 1: not necessarily a meta-tyvar - -- definitely not a /filled/ meta-tyvar - -> TcTauType -- Type 2, zonked - -> TcM Coercion -uUnfilledVar1 origin t_or_k swapped tv1 ty2 - | Just tv2 <- getTyVar_maybe ty2 - = go tv2 - - | otherwise - = uUnfilledVar2 origin t_or_k 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 <- 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 origin t_or_k (flipSwap swapped) - tv2 (mkTyVarTy tv1) } - - | otherwise - = uUnfilledVar2 origin t_or_k swapped tv1 ty2 - ----------- -uUnfilledVar2 :: CtOrigin - -> TypeOrKind - -> SwapFlag - -> TcTyVar -- Tyvar 1: not necessarily a meta-tyvar - -- definitely not a /filled/ meta-tyvar - -> TcTauType -- Type 2, zonked - -> TcM Coercion -uUnfilledVar2 origin t_or_k swapped tv1 ty2 - = do { cur_lvl <- getTcLevel - ; go cur_lvl } - where - go cur_lvl - | isTouchableMetaTyVar cur_lvl tv1 - -- See Note [Unification preconditions], (UNTOUCHABLE) wrinkles - , cterHasNoProblem (checkTyVarEq tv1 ty2) - -- See Note [Prevent unification with type families] - = do { mb_continue_solving <- startSolvingByUnification (metaTyVarInfo tv1) ty2 - ; case mb_continue_solving of - { Nothing -> not_ok_so_defer - ; Just ty2 -> - do { co_k <- uType KindLevel kind_origin (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 { writeMetaTyVar tv1 ty2 - ; return (mkNomReflCo ty2) } - - else defer }}} -- This cannot be solved now. See GHC.Tc.Solver.Canonical - -- Note [Equalities with incompatible kinds] for how - -- this will be dealt with in the solver - - | otherwise - = not_ok_so_defer - - ty1 = mkTyVarTy tv1 - kind_origin = KindEqOrigin ty1 ty2 origin (Just t_or_k) - - defer = unSwap swapped (uType_defer t_or_k origin) 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 } - --- | Checks (TYVAR-TV), (COERCION-HOLE) and (CONCRETE) of --- Note [Unification preconditions]; returns True if these conditions --- are satisfied. But see the Note for other preconditions, too. -startSolvingByUnification :: MetaInfo -> TcType -- zonked - -> TcM (Maybe TcType) -startSolvingByUnification _ xi - | hasCoercionHoleTy xi -- (COERCION-HOLE) check - = return Nothing -startSolvingByUnification info xi - = case info of - CycleBreakerTv -> return Nothing - ConcreteTv conc_orig -> - do { (xi, not_conc_reasons) <- makeTypeConcrete conc_orig xi - -- NB: makeTypeConcrete has the side-effect of turning - -- some TauTvs into ConcreteTvs, e.g. - -- alpha[conc] ~# TYPE (TupleRep '[ beta[tau], IntRep ]) - -- will write `beta[tau] := beta[conc]`. - -- - -- We return the new type, so that callers of this function - -- aren't required to zonk. - ; case not_conc_reasons of - [] -> return $ Just xi - _ -> return Nothing } - TyVarTv -> - case getTyVar_maybe xi of - Nothing -> return Nothing - Just tv -> - case tcTyVarDetails tv of -- (TYVAR-TV) wrinkle - SkolemTv {} -> return $ Just xi - RuntimeUnk -> return $ Just xi - MetaTv { mtv_info = info } -> - case info of - TyVarTv -> return $ Just xi - _ -> return Nothing - _ -> return $ Just xi - -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. Unifying here - is sensible, but it can lead to very confusing error messages. - It's very much like a Wanted rewriting a Wanted. Even worse, - unifying a variable essentially turns an equality into a Given, - and so we could not use the tracking mechanism in - Note [Wanteds rewrite Wanteds] in GHC.Tc.Types.Constraint. - We thus simply do not unify in this case. - - This is expanded as Wrinkle (2) in Note [Equalities with incompatible kinds] - in GHC.Tc.Solver.Canonical. - - -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.Solver.Canonical.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 CEqCan as (a~b) or (b~a)? -This is a surprisingly tricky question! This is invariant (TyEq:TV). - -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.Canonical.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: - a) Because the MetaTv may be touchable and can be unified - b) Even if it's not touchable, GHC.Tc.Solver.floatConstraints - looks for meta tyvars on the left - - 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 [Type synonyms and the occur check] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Generally speaking we try to update a variable with type synonyms not -expanded, which improves later error messages, unless looking -inside a type synonym may help resolve a spurious occurs check -error. Consider: - type A a = () - - f :: (A a -> a -> ()) -> () - f = \ _ -> () - - x :: () - x = f (\ x p -> p x) - -We will eventually get a constraint of the form t ~ A t. The ok function above will -properly expand the type (A t) to just (), which is ok to be unified with t. If we had -unified with the original type A t, we would lead the type checker into an infinite loop. - -Hence, if the occurs check fails for a type synonym application, then (and *only* then), -the ok function expands the synonym to detect opportunities for occurs check success using -the underlying definition of the type synonym. - -The same applies later on in the constraint interaction code; see GHC.Tc.Solver.Interact, -function @occ_check_ok@. - -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 (mkNakedFunCo1 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 - } - ; uType KindLevel origin k new_fun } - -{- ********************************************************************* -* * - Equality invariant checking -* * -********************************************************************* -} - - -{- Note [Checking for foralls] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Unless we have -XImpredicativeTypes (which is a totally unsupported -feature), we do not 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->*) - --} - ----------------- -{-# NOINLINE checkTyVarEq #-} -- checkTyVarEq becomes big after the `inline` fires -checkTyVarEq :: TcTyVar -> TcType -> CheckTyEqResult -checkTyVarEq tv ty - = inline checkTypeEq (TyVarLHS tv) ty - -- inline checkTypeEq so that the `case`s over the CanEqLHS get blasted away - -{-# NOINLINE checkTyFamEq #-} -- checkTyFamEq becomes big after the `inline` fires -checkTyFamEq :: TyCon -- type function - -> [TcType] -- args, exactly saturated - -> TcType -- RHS - -> CheckTyEqResult -- always drops cteTypeFamily -checkTyFamEq fun_tc fun_args ty - = inline checkTypeEq (TyFamLHS fun_tc fun_args) ty - `cterRemoveProblem` cteTypeFamily - -- inline checkTypeEq so that the `case`s over the CanEqLHS get blasted away - -checkTypeEq :: CanEqLHS -> TcType -> CheckTyEqResult --- If cteHasNoProblem (checkTypeEq dflags lhs rhs), then lhs ~ rhs --- is a canonical CEqCan. --- --- In particular, this looks for: --- (a) a forall type (forall a. blah) --- (b) a predicate type (c => ty) --- (c) a type family; see Note [Prevent unification with type families] --- (d) an occurrence of the LHS (occurs check) --- --- Note that an occurs-check does not mean "definite error". For example --- type family F a --- type instance F Int = Int --- consider --- b0 ~ F b0 --- This is perfectly reasonable, if we later get b0 ~ Int. But we --- certainly can't unify b0 := F b0 --- --- For (a), (b), and (c) we check only the top level of the type, NOT --- inside the kinds of variables it mentions, and for (d) see --- Note [CEqCan occurs check] in GHC.Tc.Types.Constraint. --- --- checkTypeEq is called from --- * checkTyFamEq, checkTyVarEq (which inline it to specialise away the --- case-analysis on 'lhs') --- * checkEqCanLHSFinish, which does not know the form of 'lhs' -checkTypeEq lhs ty - = go ty - where - impredicative = cteProblem cteImpredicative - type_family = cteProblem cteTypeFamily - insoluble_occurs = cteProblem cteInsolubleOccurs - soluble_occurs = cteProblem cteSolubleOccurs - - -- The GHCi runtime debugger does its type-matching with - -- unification variables that can unify with a polytype - -- or a TyCon that would usually be disallowed by bad_tc - -- See Note [RuntimeUnkTv] in GHC.Runtime.Heap.Inspect - ghci_tv - | TyVarLHS tv <- lhs - , MetaTv { mtv_info = RuntimeUnkTv } <- tcTyVarDetails tv - = True - - | otherwise - = False - - go :: TcType -> CheckTyEqResult - go (TyVarTy tv') = go_tv tv' - go (TyConApp tc tys) = go_tc tc tys - go (LitTy {}) = cteOK - go (FunTy {ft_af = af, ft_mult = w, ft_arg = a, ft_res = r}) - = go w S.<> go a S.<> go r S.<> - if not ghci_tv && isInvisibleFunArg af - then impredicative - else cteOK - go (AppTy fun arg) = go fun S.<> go arg - go (CastTy ty co) = go ty S.<> go_co co - go (CoercionTy co) = go_co co - go (ForAllTy (Bndr tv' _) ty) = (case lhs of - TyVarLHS tv | tv == tv' -> go_occ (tyVarKind tv') S.<> cterClearOccursCheck (go ty) - | otherwise -> go_occ (tyVarKind tv') S.<> go ty - _ -> go ty) - S.<> - if ghci_tv then cteOK else impredicative - - go_tv :: TcTyVar -> CheckTyEqResult - -- this slightly peculiar way of defining this means - -- we don't have to evaluate this `case` at every variable - -- occurrence - go_tv = case lhs of - TyVarLHS tv -> \ tv' -> go_occ (tyVarKind tv') S.<> - if tv == tv' then insoluble_occurs else cteOK - TyFamLHS {} -> \ _tv' -> cteOK - -- See Note [Occurrence checking: look inside kinds] in GHC.Core.Type - - -- For kinds, we only do an occurs check; we do not worry - -- about type families or foralls - -- See Note [Checking for foralls] - go_occ k = cterFromKind $ go k - - go_tc :: TyCon -> [TcType] -> CheckTyEqResult - -- this slightly peculiar way of defining this means - -- we don't have to evaluate this `case` at every tyconapp - go_tc = case lhs of - TyVarLHS {} -> \ tc tys -> check_tc tc S.<> go_tc_args tc tys - TyFamLHS fam_tc fam_args -> \ tc tys -> - if tcEqTyConApps fam_tc fam_args tc tys - then insoluble_occurs - else check_tc tc S.<> go_tc_args tc tys - - -- just look at arguments, not the tycon itself - go_tc_args :: TyCon -> [TcType] -> CheckTyEqResult - go_tc_args tc tys | isGenerativeTyCon tc Nominal = foldMap go tys - | otherwise - = let (tf_args, non_tf_args) = splitAt (tyConArity tc) tys in - cterSetOccursCheckSoluble (foldMap go tf_args) S.<> foldMap go non_tf_args - - -- no bother about impredicativity in coercions, as they're - -- inferred - go_co co | TyVarLHS tv <- lhs - , tv `elemVarSet` tyCoVarsOfCo co - = soluble_occurs - - -- Don't check coercions for type families; see commentary at top of function - | otherwise - = cteOK - - check_tc :: TyCon -> CheckTyEqResult - check_tc - | ghci_tv = \ _tc -> cteOK - | otherwise = \ tc -> (if isTauTyCon tc then cteOK else impredicative) S.<> - (if isFamFreeTyCon tc then cteOK else type_family) +{-# 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.Unify and GHC.Tc.Utils.Instantiate/GHC.Tc.Utils.TcMType -unifyType :: Maybe TypedThing -> TcTauType -> TcTauType -> TcM TcCoercion -unifyKind :: Maybe TypedThing -> TcTauType -> TcTauType -> TcM TcCoercion +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/Utils/Zonk.hs b/GHC/Tc/Utils/Zonk.hs deleted file mode 100644 --- a/GHC/Tc/Utils/Zonk.hs +++ /dev/null @@ -1,1934 +0,0 @@ - -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TypeFamilies #-} - -{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} - -{- -(c) The University of Glasgow 2006 -(c) The AQUA Project, Glasgow University, 1996-1998 - --} - --- | Specialisations of the @HsSyn@ syntax for the typechecker --- --- This module is an extension of @HsSyn@ syntax, for use in the type checker. -module GHC.Tc.Utils.Zonk ( - -- * Other HsSyn functions - mkHsDictLet, mkHsApp, - mkHsAppTy, mkHsCaseAlt, - tcShortCutLit, shortCutLit, hsOverLitName, - conLikeResTy, - - -- * re-exported from TcMonad - TcId, TcIdSet, - - -- * Zonking - -- | For a description of "zonking", see Note [What is zonking?] - -- in "GHC.Tc.Utils.TcMType" - zonkTopDecls, zonkTopExpr, zonkTopLExpr, - zonkTopBndrs, - ZonkEnv, ZonkFlexi(..), emptyZonkEnv, mkEmptyZonkEnv, initZonkEnv, - zonkTyVarBindersX, zonkTyVarBinderX, - zonkTyBndrs, zonkTyBndrsX, - zonkTcTypeToType, zonkTcTypeToTypeX, - zonkTcTypesToTypesX, zonkScaledTcTypesToTypesX, - zonkTyVarOcc, - zonkCoToCo, - zonkEvBinds, zonkTcEvBinds, - zonkTcMethInfoToMethInfoX, - lookupTyVarX - ) where - -import GHC.Prelude - -import GHC.Platform - -import GHC.Builtin.Types -import GHC.Builtin.Names - -import GHC.Hs - -import {-# SOURCE #-} GHC.Tc.Gen.Splice (runTopSplice) -import GHC.Tc.Utils.Monad -import GHC.Tc.TyCl.Build ( TcMethInfo, MethInfo ) -import GHC.Tc.Utils.TcType -import GHC.Tc.Utils.TcMType -import GHC.Tc.Utils.Env ( tcLookupGlobalOnly ) -import GHC.Tc.Types.Evidence -import GHC.Tc.Errors.Types - -import GHC.Core.TyCo.Ppr ( pprTyVar ) -import GHC.Core.TyCon -import GHC.Core.Type -import GHC.Core.Coercion -import GHC.Core.ConLike -import GHC.Core.DataCon - -import GHC.Utils.Outputable -import GHC.Utils.Misc -import GHC.Utils.Panic -import GHC.Utils.Panic.Plain - -import GHC.Core.Multiplicity -import GHC.Core -import GHC.Core.Predicate - -import GHC.Types.Name -import GHC.Types.Name.Env -import GHC.Types.Var -import GHC.Types.Var.Env -import GHC.Types.Id -import GHC.Types.TypeEnv -import GHC.Types.SourceText -import GHC.Types.Basic -import GHC.Types.SrcLoc -import GHC.Types.Unique.FM -import GHC.Types.TyThing -import GHC.Driver.Session( getDynFlags, targetPlatform ) - -import GHC.Data.Maybe -import GHC.Data.Bag - -import Control.Monad -import Data.List ( partition ) -import Control.Arrow ( second ) - -{- ********************************************************************* -* * - Short-cuts for overloaded numeric literals -* * -********************************************************************* -} - --- Overloaded literals. Here mainly because it uses isIntTy etc - -{- Note [Short cut for overloaded literals] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -A literal like "3" means (fromInteger @ty (dNum :: Num ty) (3::Integer)). -But if we have a list like - [4,2,3,2,4,4,2]::[Int] -we use a lot of compile time and space generating and solving all those Num -constraints, and generating calls to fromInteger etc. Better just to cut to -the chase, and cough up an Int literal. Large collections of literals like this -sometimes appear in source files, so it's quite a worthwhile fix. - -So we try to take advantage of whatever nearby type information we have, -to short-cut the process for built-in types. We can do this in two places; - -* In the typechecker, when we are about to typecheck the literal. -* If that fails, in the desugarer, once we know the final type. --} - -tcShortCutLit :: HsOverLit GhcRn -> ExpRhoType -> TcM (Maybe (HsOverLit GhcTc)) -tcShortCutLit lit@(OverLit { ol_val = val, ol_ext = OverLitRn rebindable _}) exp_res_ty - | not rebindable - , Just res_ty <- checkingExpType_maybe exp_res_ty - = do { dflags <- getDynFlags - ; let platform = targetPlatform dflags - ; case shortCutLit platform val res_ty of - Just expr -> return $ Just $ - lit { ol_ext = OverLitTc False expr res_ty } - Nothing -> return Nothing } - | otherwise - = return Nothing - -shortCutLit :: Platform -> OverLitVal -> TcType -> Maybe (HsExpr GhcTc) -shortCutLit platform val res_ty - = case val of - HsIntegral int_lit -> go_integral int_lit - HsFractional frac_lit -> go_fractional frac_lit - HsIsString s src -> go_string s src - where - go_integral int@(IL src neg i) - | isIntTy res_ty && platformInIntRange platform i - = Just (HsLit noAnn (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)) - | otherwise - = go_fractional (integralFractionalLit neg i) - -- The 'otherwise' case is important - -- Consider (3 :: Float). Syntactically it looks like an IntLit, - -- so we'll call shortCutIntLit, but of course it's a float - -- This can make a big difference for programs with a lot of - -- literals, compiled without -O - - go_fractional f - | isFloatTy res_ty && valueInRange = Just (mkLit floatDataCon (HsFloatPrim noExtField f)) - | isDoubleTy res_ty && valueInRange = Just (mkLit doubleDataCon (HsDoublePrim noExtField f)) - | otherwise = Nothing - where - valueInRange = - case f of - FL { fl_exp = e } -> (-100) <= e && e <= 100 - -- We limit short-cutting Fractional Literals to when their power of 10 - -- is less than 100, which ensures desugaring isn't slow. - - go_string src s - | isStringTy res_ty = Just (HsLit noAnn (HsString src s)) - | otherwise = Nothing - -mkLit :: DataCon -> HsLit GhcTc -> HsExpr GhcTc -mkLit con lit = HsApp noComments (nlHsDataCon con) (nlHsLit lit) - ------------------------------- -hsOverLitName :: OverLitVal -> Name --- Get the canonical 'fromX' name for a particular OverLitVal -hsOverLitName (HsIntegral {}) = fromIntegerName -hsOverLitName (HsFractional {}) = fromRationalName -hsOverLitName (HsIsString {}) = fromStringName - -{- -************************************************************************ -* * -\subsection[BackSubst-HsBinds]{Running a substitution over @HsBinds@} -* * -************************************************************************ - -The rest of the zonking is done *after* typechecking. -The main zonking pass runs over the bindings - - a) to convert TcTyVars to TyVars etc, dereferencing any bindings etc - b) convert unbound TcTyVar to Void - c) convert each TcId to an Id by zonking its type - -The type variables are converted by binding mutable tyvars to immutable ones -and then zonking as normal. - -The Ids are converted by binding them in the normal Tc envt; that -way we maintain sharing; eg an Id is zonked at its binding site and they -all occurrences of that Id point to the common zonked copy - -It's all pretty boring stuff, because HsSyn is such a large type, and -the environment manipulation is tiresome. --} - --- Confused by zonking? See Note [What is zonking?] in GHC.Tc.Utils.TcMType. - --- | See Note [The ZonkEnv] --- Confused by zonking? See Note [What is zonking?] in "GHC.Tc.Utils.TcMType". -data ZonkEnv -- See Note [The ZonkEnv] - = ZonkEnv { ze_flexi :: ZonkFlexi - , ze_tv_env :: TyCoVarEnv TyCoVar - , ze_id_env :: IdEnv Id - , ze_meta_tv_env :: TcRef (TyVarEnv Type) } - -{- Note [The ZonkEnv] -~~~~~~~~~~~~~~~~~~~~~ -* ze_flexi :: ZonkFlexi says what to do with a - unification variable that is still un-unified. - See Note [Un-unified unification variables] - -* ze_tv_env :: TyCoVarEnv TyCoVar promotes sharing. At a binding site - of a tyvar or covar, we zonk the kind right away and add a mapping - to the env. This prevents re-zonking the kind at every - occurrence. But this is *just* an optimisation. - -* ze_id_env : IdEnv Id promotes sharing among Ids, by making all - occurrences of the Id point to a single zonked copy, built at the - binding site. - - Unlike ze_tv_env, it is knot-tied: see extendIdZonkEnvRec. - In a mutually recursive group - rec { f = ...g...; g = ...f... } - we want the occurrence of g to point to the one zonked Id for g, - and the same for f. - - Because it is knot-tied, we must be careful to consult it lazily. - Specifically, zonkIdOcc is not monadic. - -* ze_meta_tv_env: see Note [Sharing when zonking to Type] - - -Notes: - * We must be careful never to put coercion variables (which are Ids, - after all) in the knot-tied ze_id_env, because coercions can - appear in types, and we sometimes inspect a zonked type in this - module. [Question: where, precisely?] - - * In zonkTyVarOcc we consult ze_tv_env in a monadic context, - a second reason that ze_tv_env can't be monadic. - - * An obvious suggestion would be to have one VarEnv Var to - replace both ze_id_env and ze_tv_env, but that doesn't work - because of the knot-tying stuff mentioned above. - -Note [Un-unified unification variables] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -What should we do if we find a Flexi unification variable? -There are three possibilities: - -* DefaultFlexi: this is the common case, in situations like - length @alpha ([] @alpha) - It really doesn't matter what type we choose for alpha. But - we must choose a type! We can't leave mutable unification - variables floating around: after typecheck is complete, every - type variable occurrence must have a binding site. - - So we default it to 'Any' of the right kind. - - All this works for both type and kind variables (indeed - the two are the same thing). - -* SkolemiseFlexi: is a special case for the LHS of RULES. - See Note [Zonking the LHS of a RULE] - -* RuntimeUnkFlexi: is a special case for the GHCi debugger. - It's a way to have a variable that is not a mutable - unification variable, but doesn't have a binding site - either. - -* NoFlexi: See Note [Error on unconstrained meta-variables] - in GHC.Tc.Utils.TcMType. This mode will panic on unfilled - meta-variables. --} - -data ZonkFlexi -- See Note [Un-unified unification variables] - = DefaultFlexi -- Default unbound unification variables to Any - | SkolemiseFlexi -- Skolemise unbound unification variables - -- See Note [Zonking the LHS of a RULE] - | RuntimeUnkFlexi -- Used in the GHCi debugger - | NoFlexi -- Panic on unfilled meta-variables - -- See Note [Error on unconstrained meta-variables] - -- in GHC.Tc.Utils.TcMType - -instance Outputable ZonkEnv where - ppr (ZonkEnv { ze_tv_env = tv_env - , ze_id_env = id_env }) - = text "ZE" <+> braces (vcat - [ text "ze_tv_env =" <+> ppr tv_env - , text "ze_id_env =" <+> ppr id_env ]) - --- The EvBinds have to already be zonked, but that's usually the case. -emptyZonkEnv :: TcM ZonkEnv -emptyZonkEnv = mkEmptyZonkEnv DefaultFlexi - -mkEmptyZonkEnv :: ZonkFlexi -> TcM ZonkEnv -mkEmptyZonkEnv flexi - = do { mtv_env_ref <- newTcRef emptyVarEnv - ; return (ZonkEnv { ze_flexi = flexi - , ze_tv_env = emptyVarEnv - , ze_id_env = emptyVarEnv - , ze_meta_tv_env = mtv_env_ref }) } - -initZonkEnv :: (ZonkEnv -> TcM b) -> TcM b -initZonkEnv thing_inside = do { ze <- mkEmptyZonkEnv DefaultFlexi - ; thing_inside ze } - --- | Extend the knot-tied environment. -extendIdZonkEnvRec :: ZonkEnv -> [Var] -> ZonkEnv -extendIdZonkEnvRec ze@(ZonkEnv { ze_id_env = id_env }) ids - -- NB: Don't look at the var to decide which env't to put it in. That - -- would end up knot-tying all the env'ts. - = ze { ze_id_env = extendVarEnvList id_env [(id,id) | id <- ids] } - -- Given coercion variables will actually end up here. That's OK though: - -- coercion variables are never looked up in the knot-tied env't, so zonking - -- them simply doesn't get optimised. No one gets hurt. An improvement (?) - -- would be to do SCC analysis in zonkEvBinds and then only knot-tie the - -- recursive groups. But perhaps the time it takes to do the analysis is - -- more than the savings. - -extendZonkEnv :: ZonkEnv -> [Var] -> ZonkEnv -extendZonkEnv ze@(ZonkEnv { ze_tv_env = tyco_env, ze_id_env = id_env }) vars - = ze { ze_tv_env = extendVarEnvList tyco_env [(tv,tv) | tv <- tycovars] - , ze_id_env = extendVarEnvList id_env [(id,id) | id <- ids] } - where - (tycovars, ids) = partition isTyCoVar vars - -extendIdZonkEnv :: ZonkEnv -> Var -> ZonkEnv -extendIdZonkEnv ze@(ZonkEnv { ze_id_env = id_env }) id - = ze { ze_id_env = extendVarEnv id_env id id } - -extendTyZonkEnv :: ZonkEnv -> TyVar -> ZonkEnv -extendTyZonkEnv ze@(ZonkEnv { ze_tv_env = ty_env }) tv - = ze { ze_tv_env = extendVarEnv ty_env tv tv } - -setZonkType :: ZonkEnv -> ZonkFlexi -> ZonkEnv -setZonkType ze flexi = ze { ze_flexi = flexi } - -zonkEnvIds :: ZonkEnv -> TypeEnv -zonkEnvIds (ZonkEnv { ze_id_env = id_env}) - = mkNameEnv [(getName id, AnId id) | id <- nonDetEltsUFM id_env] - -- It's OK to use nonDetEltsUFM here because we forget the ordering - -- immediately by creating a TypeEnv - -zonkLIdOcc :: ZonkEnv -> LocatedN TcId -> LocatedN Id -zonkLIdOcc env = fmap (zonkIdOcc env) - -zonkIdOcc :: ZonkEnv -> TcId -> Id --- Ids defined in this module should be in the envt; --- ignore others. (Actually, data constructors are also --- not LocalVars, even when locally defined, but that is fine.) --- (Also foreign-imported things aren't currently in the ZonkEnv; --- that's ok because they don't need zonking.) --- --- Actually, Template Haskell works in 'chunks' of declarations, and --- an earlier chunk won't be in the 'env' that the zonking phase --- carries around. Instead it'll be in the tcg_gbl_env, already fully --- zonked. There's no point in looking it up there (except for error --- checking), and it's not conveniently to hand; hence the simple --- 'orElse' case in the LocalVar branch. --- --- Even without template splices, in module Main, the checking of --- 'main' is done as a separate chunk. -zonkIdOcc (ZonkEnv { ze_id_env = id_env}) id - | isLocalVar id = lookupVarEnv id_env id `orElse` - id - | otherwise = id - -zonkIdOccs :: ZonkEnv -> [TcId] -> [Id] -zonkIdOccs env ids = map (zonkIdOcc env) ids - --- zonkIdBndr is used *after* typechecking to get the Id's type --- to its final form. The TyVarEnv give -zonkIdBndr :: ZonkEnv -> TcId -> TcM Id -zonkIdBndr env v - = do Scaled w' ty' <- zonkScaledTcTypeToTypeX env (idScaledType v) - return (setIdMult (setIdType v ty') w') - -zonkIdBndrs :: ZonkEnv -> [TcId] -> TcM [Id] -zonkIdBndrs env ids = mapM (zonkIdBndr env) ids - -zonkTopBndrs :: [TcId] -> TcM [Id] -zonkTopBndrs ids = initZonkEnv $ \ ze -> zonkIdBndrs ze ids - -zonkFieldOcc :: ZonkEnv -> FieldOcc GhcTc -> TcM (FieldOcc GhcTc) -zonkFieldOcc env (FieldOcc sel lbl) - = fmap ((flip FieldOcc) lbl) $ zonkIdBndr env sel - -zonkEvBndrsX :: ZonkEnv -> [EvVar] -> TcM (ZonkEnv, [Var]) -zonkEvBndrsX = mapAccumLM zonkEvBndrX - -zonkEvBndrX :: ZonkEnv -> EvVar -> TcM (ZonkEnv, EvVar) --- Works for dictionaries and coercions -zonkEvBndrX env var - = do { var' <- zonkEvBndr env var - ; return (extendZonkEnv env [var'], var') } - -zonkEvBndr :: ZonkEnv -> EvVar -> TcM EvVar --- Works for dictionaries and coercions --- Does not extend the ZonkEnv -zonkEvBndr env var - = updateIdTypeAndMultM ({-# SCC "zonkEvBndr_zonkTcTypeToType" #-} zonkTcTypeToTypeX env) var - -{- -zonkEvVarOcc :: ZonkEnv -> EvVar -> TcM EvTerm -zonkEvVarOcc env v - | isCoVar v - = EvCoercion <$> zonkCoVarOcc env v - | otherwise - = return (EvId $ zonkIdOcc env v) --} - -zonkCoreBndrX :: ZonkEnv -> Var -> TcM (ZonkEnv, Var) -zonkCoreBndrX env v - | isId v = do { v' <- zonkIdBndr env v - ; return (extendIdZonkEnv env v', v') } - | otherwise = zonkTyBndrX env v - -zonkCoreBndrsX :: ZonkEnv -> [Var] -> TcM (ZonkEnv, [Var]) -zonkCoreBndrsX = mapAccumLM zonkCoreBndrX - -zonkTyBndrs :: [TcTyVar] -> TcM (ZonkEnv, [TyVar]) -zonkTyBndrs tvs = initZonkEnv $ \ze -> zonkTyBndrsX ze tvs - -zonkTyBndrsX :: ZonkEnv -> [TcTyVar] -> TcM (ZonkEnv, [TyVar]) -zonkTyBndrsX = mapAccumLM zonkTyBndrX - -zonkTyBndrX :: ZonkEnv -> TcTyVar -> TcM (ZonkEnv, TyVar) --- This guarantees to return a TyVar (not a TcTyVar) --- then we add it to the envt, so all occurrences are replaced --- --- It does not clone: the new TyVar has the sane Name --- as the old one. This important when zonking the --- TyVarBndrs of a TyCon, whose Names may scope. -zonkTyBndrX env tv - = assertPpr (isImmutableTyVar tv) (ppr tv <+> dcolon <+> ppr (tyVarKind tv)) $ - do { ki <- zonkTcTypeToTypeX env (tyVarKind tv) - -- Internal names tidy up better, for iface files. - ; let tv' = mkTyVar (tyVarName tv) ki - ; return (extendTyZonkEnv env tv', tv') } - -zonkTyVarBindersX :: ZonkEnv -> [VarBndr TcTyVar vis] - -> TcM (ZonkEnv, [VarBndr TyVar vis]) -zonkTyVarBindersX = mapAccumLM zonkTyVarBinderX - -zonkTyVarBinderX :: ZonkEnv -> VarBndr TcTyVar vis - -> TcM (ZonkEnv, VarBndr TyVar vis) --- Takes a TcTyVar and guarantees to return a TyVar -zonkTyVarBinderX env (Bndr tv vis) - = do { (env', tv') <- zonkTyBndrX env tv - ; return (env', Bndr tv' vis) } - -zonkTopExpr :: HsExpr GhcTc -> TcM (HsExpr GhcTc) -zonkTopExpr e = initZonkEnv $ \ ze -> zonkExpr ze e - -zonkTopLExpr :: LHsExpr GhcTc -> TcM (LHsExpr GhcTc) -zonkTopLExpr e = initZonkEnv $ \ ze -> zonkLExpr ze e - -zonkTopDecls :: Bag EvBind - -> LHsBinds GhcTc - -> [LRuleDecl GhcTc] -> [LTcSpecPrag] - -> [LForeignDecl GhcTc] - -> TcM (TypeEnv, - Bag EvBind, - LHsBinds GhcTc, - [LForeignDecl GhcTc], - [LTcSpecPrag], - [LRuleDecl GhcTc]) -zonkTopDecls ev_binds binds rules imp_specs fords - = do { (env1, ev_binds') <- initZonkEnv $ \ ze -> zonkEvBinds ze ev_binds - ; (env2, binds') <- zonkRecMonoBinds env1 binds - -- Top level is implicitly recursive - ; rules' <- zonkRules env2 rules - ; specs' <- zonkLTcSpecPrags env2 imp_specs - ; fords' <- zonkForeignExports env2 fords - ; return (zonkEnvIds env2, ev_binds', binds', fords', specs', rules') } - ---------------------------------------------- -zonkLocalBinds :: ZonkEnv -> HsLocalBinds GhcTc - -> TcM (ZonkEnv, HsLocalBinds GhcTc) -zonkLocalBinds env (EmptyLocalBinds x) - = return (env, (EmptyLocalBinds x)) - -zonkLocalBinds _ (HsValBinds _ (ValBinds {})) - = panic "zonkLocalBinds" -- Not in typechecker output - -zonkLocalBinds env (HsValBinds x (XValBindsLR (NValBinds binds sigs))) - = do { (env1, new_binds) <- go env binds - ; return (env1, HsValBinds x (XValBindsLR (NValBinds new_binds sigs))) } - where - go env [] - = return (env, []) - go env ((r,b):bs) - = do { (env1, b') <- zonkRecMonoBinds env b - ; (env2, bs') <- go env1 bs - ; return (env2, (r,b'):bs') } - -zonkLocalBinds env (HsIPBinds x (IPBinds dict_binds binds )) = do - new_binds <- mapM (wrapLocMA zonk_ip_bind) binds - let - env1 = extendIdZonkEnvRec env - [ n | (L _ (IPBind n _ _)) <- new_binds] - (env2, new_dict_binds) <- zonkTcEvBinds env1 dict_binds - return (env2, HsIPBinds x (IPBinds new_dict_binds new_binds)) - where - zonk_ip_bind (IPBind dict_id n e) - = do dict_id' <- zonkIdBndr env dict_id - e' <- zonkLExpr env e - return (IPBind dict_id' n e') - ---------------------------------------------- -zonkRecMonoBinds :: ZonkEnv -> LHsBinds GhcTc -> TcM (ZonkEnv, LHsBinds GhcTc) -zonkRecMonoBinds env binds - = fixM (\ ~(_, new_binds) -> do - { let env1 = extendIdZonkEnvRec env (collectHsBindsBinders CollNoDictBinders new_binds) - ; binds' <- zonkMonoBinds env1 binds - ; return (env1, binds') }) - ---------------------------------------------- -zonkMonoBinds :: ZonkEnv -> LHsBinds GhcTc -> TcM (LHsBinds GhcTc) -zonkMonoBinds env binds = mapBagM (zonk_lbind env) binds - -zonk_lbind :: ZonkEnv -> LHsBind GhcTc -> TcM (LHsBind GhcTc) -zonk_lbind env = wrapLocMA (zonk_bind env) - -zonk_bind :: ZonkEnv -> HsBind GhcTc -> TcM (HsBind GhcTc) -zonk_bind env bind@(PatBind { pat_lhs = pat, pat_rhs = grhss - , pat_ext = (ty, ticks)}) - = do { (_env, new_pat) <- zonkPat env pat -- Env already extended - ; new_grhss <- zonkGRHSs env zonkLExpr grhss - ; new_ty <- zonkTcTypeToTypeX env ty - ; return (bind { pat_lhs = new_pat, pat_rhs = new_grhss - , pat_ext = (new_ty, ticks) }) } - -zonk_bind env (VarBind { var_ext = x - , var_id = var, var_rhs = expr }) - = do { new_var <- zonkIdBndr env var - ; new_expr <- zonkLExpr env expr - ; return (VarBind { var_ext = x - , var_id = new_var - , var_rhs = new_expr }) } - -zonk_bind env bind@(FunBind { fun_id = L loc var - , fun_matches = ms - , fun_ext = (co_fn, ticks) }) - = do { new_var <- zonkIdBndr env var - ; (env1, new_co_fn) <- zonkCoFn env co_fn - ; new_ms <- zonkMatchGroup env1 zonkLExpr ms - ; return (bind { fun_id = L loc new_var - , fun_matches = new_ms - , fun_ext = (new_co_fn, ticks) }) } - -zonk_bind env (XHsBindsLR (AbsBinds { abs_tvs = tyvars, abs_ev_vars = evs - , abs_ev_binds = ev_binds - , abs_exports = exports - , abs_binds = val_binds - , abs_sig = has_sig })) - = assert ( all isImmutableTyVar tyvars ) $ - do { (env0, new_tyvars) <- zonkTyBndrsX env tyvars - ; (env1, new_evs) <- zonkEvBndrsX env0 evs - ; (env2, new_ev_binds) <- zonkTcEvBinds_s env1 ev_binds - ; (new_val_bind, new_exports) <- fixM $ \ ~(new_val_binds, _) -> - do { let env3 = extendIdZonkEnvRec env2 $ - collectHsBindsBinders CollNoDictBinders new_val_binds - ; new_val_binds <- mapBagM (zonk_val_bind env3) val_binds - ; new_exports <- mapM (zonk_export env3) exports - ; return (new_val_binds, new_exports) } - ; return $ XHsBindsLR $ - AbsBinds { abs_tvs = new_tyvars, abs_ev_vars = new_evs - , abs_ev_binds = new_ev_binds - , abs_exports = new_exports, abs_binds = new_val_bind - , abs_sig = has_sig } } - where - zonk_val_bind env lbind - | has_sig - , (L loc bind@(FunBind { fun_id = (L mloc mono_id) - , fun_matches = ms - , fun_ext = (co_fn, ticks) })) <- lbind - = do { new_mono_id <- updateIdTypeAndMultM (zonkTcTypeToTypeX env) mono_id - -- Specifically /not/ zonkIdBndr; we do not want to - -- complain about a representation-polymorphic binder - ; (env', new_co_fn) <- zonkCoFn env co_fn - ; new_ms <- zonkMatchGroup env' zonkLExpr ms - ; return $ L loc $ - bind { fun_id = L mloc new_mono_id - , fun_matches = new_ms - , fun_ext = (new_co_fn, ticks) } } - | otherwise - = zonk_lbind env lbind -- The normal case - - zonk_export :: ZonkEnv -> ABExport -> TcM ABExport - zonk_export env (ABE{ abe_wrap = wrap - , abe_poly = poly_id - , abe_mono = mono_id - , abe_prags = prags }) - = do new_poly_id <- zonkIdBndr env poly_id - (_, new_wrap) <- zonkCoFn env wrap - new_prags <- zonkSpecPrags env prags - return (ABE{ abe_wrap = new_wrap - , abe_poly = new_poly_id - , abe_mono = zonkIdOcc env mono_id - , abe_prags = new_prags }) - -zonk_bind env (PatSynBind x bind@(PSB { psb_id = L loc id - , psb_args = details - , psb_def = lpat - , psb_dir = dir })) - = do { id' <- zonkIdBndr env id - ; (env1, lpat') <- zonkPat env lpat - ; details' <- zonkPatSynDetails env1 details - ; (_env2, dir') <- zonkPatSynDir env1 dir - ; return $ PatSynBind x $ - bind { psb_id = L loc id' - , psb_args = details' - , psb_def = lpat' - , psb_dir = dir' } } - -zonkPatSynDetails :: ZonkEnv - -> HsPatSynDetails GhcTc - -> TcM (HsPatSynDetails GhcTc) -zonkPatSynDetails env (PrefixCon _ as) - = pure $ PrefixCon noTypeArgs (map (zonkLIdOcc env) as) -zonkPatSynDetails env (InfixCon a1 a2) - = pure $ InfixCon (zonkLIdOcc env a1) (zonkLIdOcc env a2) -zonkPatSynDetails env (RecCon flds) - = RecCon <$> mapM (zonkPatSynField env) flds - -zonkPatSynField :: ZonkEnv -> RecordPatSynField GhcTc -> TcM (RecordPatSynField GhcTc) -zonkPatSynField env (RecordPatSynField x y) = - RecordPatSynField <$> zonkFieldOcc env x <*> pure (zonkLIdOcc env y) - -zonkPatSynDir :: ZonkEnv -> HsPatSynDir GhcTc - -> TcM (ZonkEnv, HsPatSynDir GhcTc) -zonkPatSynDir env Unidirectional = return (env, Unidirectional) -zonkPatSynDir env ImplicitBidirectional = return (env, ImplicitBidirectional) -zonkPatSynDir env (ExplicitBidirectional mg) = do - mg' <- zonkMatchGroup env zonkLExpr mg - return (env, ExplicitBidirectional mg') - -zonkSpecPrags :: ZonkEnv -> TcSpecPrags -> TcM TcSpecPrags -zonkSpecPrags _ IsDefaultMethod = return IsDefaultMethod -zonkSpecPrags env (SpecPrags ps) = do { ps' <- zonkLTcSpecPrags env ps - ; return (SpecPrags ps') } - -zonkLTcSpecPrags :: ZonkEnv -> [LTcSpecPrag] -> TcM [LTcSpecPrag] -zonkLTcSpecPrags env ps - = mapM zonk_prag ps - where - zonk_prag (L loc (SpecPrag id co_fn inl)) - = do { (_, co_fn') <- zonkCoFn env co_fn - ; return (L loc (SpecPrag (zonkIdOcc env id) co_fn' inl)) } - -{- -************************************************************************ -* * -\subsection[BackSubst-Match-GRHSs]{Match and GRHSs} -* * -************************************************************************ --} - -zonkMatchGroup :: Anno (GRHS GhcTc (LocatedA (body GhcTc))) ~ SrcAnn NoEpAnns - => ZonkEnv - -> (ZonkEnv -> LocatedA (body GhcTc) -> TcM (LocatedA (body GhcTc))) - -> MatchGroup GhcTc (LocatedA (body GhcTc)) - -> TcM (MatchGroup GhcTc (LocatedA (body GhcTc))) -zonkMatchGroup env zBody (MG { mg_alts = L l ms - , mg_ext = MatchGroupTc arg_tys res_ty origin - }) - = do { ms' <- mapM (zonkMatch env zBody) ms - ; arg_tys' <- zonkScaledTcTypesToTypesX env arg_tys - ; res_ty' <- zonkTcTypeToTypeX env res_ty - ; return (MG { mg_alts = L l ms' - , mg_ext = MatchGroupTc arg_tys' res_ty' origin - }) } - -zonkMatch :: Anno (GRHS GhcTc (LocatedA (body GhcTc))) ~ SrcAnn NoEpAnns - => ZonkEnv - -> (ZonkEnv -> LocatedA (body GhcTc) -> TcM (LocatedA (body GhcTc))) - -> LMatch GhcTc (LocatedA (body GhcTc)) - -> TcM (LMatch GhcTc (LocatedA (body GhcTc))) -zonkMatch env zBody (L loc match@(Match { m_pats = pats - , m_grhss = grhss })) - = do { (env1, new_pats) <- zonkPats env pats - ; new_grhss <- zonkGRHSs env1 zBody grhss - ; return (L loc (match { m_pats = new_pats, m_grhss = new_grhss })) } - -------------------------------------------------------------------------- -zonkGRHSs :: Anno (GRHS GhcTc (LocatedA (body GhcTc))) ~ SrcAnn NoEpAnns - => ZonkEnv - -> (ZonkEnv -> LocatedA (body GhcTc) -> TcM (LocatedA (body GhcTc))) - -> GRHSs GhcTc (LocatedA (body GhcTc)) - -> TcM (GRHSs GhcTc (LocatedA (body GhcTc))) - -zonkGRHSs env zBody (GRHSs x grhss binds) = do - (new_env, new_binds) <- zonkLocalBinds env binds - let - zonk_grhs (GRHS xx guarded rhs) - = do (env2, new_guarded) <- zonkStmts new_env zonkLExpr guarded - new_rhs <- zBody env2 rhs - return (GRHS xx new_guarded new_rhs) - new_grhss <- mapM (wrapLocMA zonk_grhs) grhss - return (GRHSs x new_grhss new_binds) - -{- -************************************************************************ -* * -\subsection[BackSubst-HsExpr]{Running a zonkitution over a TypeCheckedExpr} -* * -************************************************************************ --} - -zonkLExprs :: ZonkEnv -> [LHsExpr GhcTc] -> TcM [LHsExpr GhcTc] -zonkLExpr :: ZonkEnv -> LHsExpr GhcTc -> TcM (LHsExpr GhcTc) -zonkExpr :: ZonkEnv -> HsExpr GhcTc -> TcM (HsExpr GhcTc) - -zonkLExprs env exprs = mapM (zonkLExpr env) exprs -zonkLExpr env expr = wrapLocMA (zonkExpr env) expr - -zonkExpr env (HsVar x (L l id)) - = assertPpr (isNothing (isDataConId_maybe id)) (ppr id) $ - return (HsVar x (L l (zonkIdOcc env id))) - -zonkExpr env (HsUnboundVar her occ) - = do her' <- zonk_her her - return (HsUnboundVar her' occ) - where - zonk_her :: HoleExprRef -> TcM HoleExprRef - zonk_her (HER ref ty u) - = do updMutVarM ref (zonkEvTerm env) - ty' <- zonkTcTypeToTypeX env ty - return (HER ref ty' u) - -zonkExpr env (HsRecSel _ (FieldOcc v occ)) - = return (HsRecSel noExtField (FieldOcc (zonkIdOcc env v) occ)) - -zonkExpr _ (HsIPVar x _) = dataConCantHappen x - -zonkExpr _ (HsOverLabel x _ _) = dataConCantHappen x - -zonkExpr env (HsLit x (HsRat e f ty)) - = do new_ty <- zonkTcTypeToTypeX env ty - return (HsLit x (HsRat e f new_ty)) - -zonkExpr _ (HsLit x lit) - = return (HsLit x lit) - -zonkExpr env (HsOverLit x lit) - = do { lit' <- zonkOverLit env lit - ; return (HsOverLit x lit') } - -zonkExpr env (HsLam x matches) - = do new_matches <- zonkMatchGroup env zonkLExpr matches - return (HsLam x new_matches) - -zonkExpr env (HsLamCase x lc_variant matches) - = do new_matches <- zonkMatchGroup env zonkLExpr matches - return (HsLamCase x lc_variant new_matches) - -zonkExpr env (HsApp x e1 e2) - = do new_e1 <- zonkLExpr env e1 - new_e2 <- zonkLExpr env e2 - return (HsApp x new_e1 new_e2) - -zonkExpr env (HsAppType ty e at t) - = do new_e <- zonkLExpr env e - new_ty <- zonkTcTypeToTypeX env ty - return (HsAppType new_ty new_e at t) - -- NB: the type is an HsType; can't zonk that! - -zonkExpr env (HsTypedBracket hsb_tc body) - = (\x -> HsTypedBracket x body) <$> zonkBracket env hsb_tc - -zonkExpr env (HsUntypedBracket hsb_tc body) - = (\x -> HsUntypedBracket x body) <$> zonkBracket env hsb_tc - -zonkExpr env (HsTypedSplice s _) = runTopSplice s >>= zonkExpr env - -zonkExpr _ e@(HsUntypedSplice _ _) = pprPanic "zonkExpr: HsUntypedSplice" (ppr e) - -zonkExpr _ (OpApp x _ _ _) = dataConCantHappen x - -zonkExpr env (NegApp x expr op) - = do (env', new_op) <- zonkSyntaxExpr env op - new_expr <- zonkLExpr env' expr - return (NegApp x new_expr new_op) - -zonkExpr env (HsPar x lpar e rpar) - = do new_e <- zonkLExpr env e - return (HsPar x lpar new_e rpar) - -zonkExpr _ (SectionL x _ _) = dataConCantHappen x -zonkExpr _ (SectionR x _ _) = dataConCantHappen x -zonkExpr env (ExplicitTuple x tup_args boxed) - = do { new_tup_args <- mapM zonk_tup_arg tup_args - ; return (ExplicitTuple x new_tup_args boxed) } - where - zonk_tup_arg (Present x e) = do { e' <- zonkLExpr env e - ; return (Present x e') } - zonk_tup_arg (Missing t) = do { t' <- zonkScaledTcTypeToTypeX env t - ; return (Missing t') } - - -zonkExpr env (ExplicitSum args alt arity expr) - = do new_args <- mapM (zonkTcTypeToTypeX env) args - new_expr <- zonkLExpr env expr - return (ExplicitSum new_args alt arity new_expr) - -zonkExpr env (HsCase x expr ms) - = do new_expr <- zonkLExpr env expr - new_ms <- zonkMatchGroup env zonkLExpr ms - return (HsCase x new_expr new_ms) - -zonkExpr env (HsIf x e1 e2 e3) - = do new_e1 <- zonkLExpr env e1 - new_e2 <- zonkLExpr env e2 - new_e3 <- zonkLExpr env e3 - return (HsIf x new_e1 new_e2 new_e3) - -zonkExpr env (HsMultiIf ty alts) - = do { alts' <- mapM (wrapLocMA zonk_alt) alts - ; ty' <- zonkTcTypeToTypeX env ty - ; return $ HsMultiIf ty' alts' } - where zonk_alt (GRHS x guard expr) - = do { (env', guard') <- zonkStmts env zonkLExpr guard - ; expr' <- zonkLExpr env' expr - ; return $ GRHS x guard' expr' } - -zonkExpr env (HsLet x tkLet binds tkIn expr) - = do (new_env, new_binds) <- zonkLocalBinds env binds - new_expr <- zonkLExpr new_env expr - return (HsLet x tkLet new_binds tkIn new_expr) - -zonkExpr env (HsDo ty do_or_lc (L l stmts)) - = do (_, new_stmts) <- zonkStmts env zonkLExpr stmts - new_ty <- zonkTcTypeToTypeX env ty - return (HsDo new_ty do_or_lc (L l new_stmts)) - -zonkExpr env (ExplicitList ty exprs) - = do new_ty <- zonkTcTypeToTypeX env ty - new_exprs <- zonkLExprs env exprs - return (ExplicitList new_ty new_exprs) - -zonkExpr env expr@(RecordCon { rcon_ext = con_expr, rcon_flds = rbinds }) - = do { new_con_expr <- zonkExpr env con_expr - ; new_rbinds <- zonkRecFields env rbinds - ; return (expr { rcon_ext = new_con_expr - , rcon_flds = new_rbinds }) } - -zonkExpr env (ExprWithTySig _ e ty) - = do { e' <- zonkLExpr env e - ; return (ExprWithTySig noExtField e' ty) } - -zonkExpr env (ArithSeq expr wit info) - = do (env1, new_wit) <- zonkWit env wit - new_expr <- zonkExpr env expr - new_info <- zonkArithSeq env1 info - return (ArithSeq new_expr new_wit new_info) - where zonkWit env Nothing = return (env, Nothing) - zonkWit env (Just fln) = second Just <$> zonkSyntaxExpr env fln - -zonkExpr env (HsPragE x prag expr) - = do new_expr <- zonkLExpr env expr - return (HsPragE x prag new_expr) - --- arrow notation extensions -zonkExpr env (HsProc x pat body) - = do { (env1, new_pat) <- zonkPat env pat - ; new_body <- zonkCmdTop env1 body - ; return (HsProc x new_pat new_body) } - --- StaticPointers extension -zonkExpr env (HsStatic (fvs, ty) expr) - = do new_ty <- zonkTcTypeToTypeX env ty - HsStatic (fvs, new_ty) <$> zonkLExpr env expr - -zonkExpr env (XExpr (WrapExpr (HsWrap co_fn expr))) - = do (env1, new_co_fn) <- zonkCoFn env co_fn - new_expr <- zonkExpr env1 expr - return (XExpr (WrapExpr (HsWrap new_co_fn new_expr))) - -zonkExpr env (XExpr (ExpansionExpr (HsExpanded a b))) - = XExpr . ExpansionExpr . HsExpanded a <$> zonkExpr env b - -zonkExpr env (XExpr (ConLikeTc con tvs tys)) - = XExpr . ConLikeTc con tvs <$> mapM zonk_scale tys - where - zonk_scale (Scaled m ty) = Scaled <$> zonkTcTypeToTypeX env m <*> pure ty - -- Only the multiplicity can contain unification variables - -- The tvs come straight from the data-con, and so are strictly redundant - -- See Wrinkles of Note [Typechecking data constructors] in GHC.Tc.Gen.Head - -zonkExpr _ expr = pprPanic "zonkExpr" (ppr expr) - -------------------------------------------------------------------------- -{- -Note [Skolems in zonkSyntaxExpr] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider rebindable syntax with something like - - (>>=) :: (forall x. blah) -> (forall y. blah') -> blah'' - -The x and y become skolems that are in scope when type-checking the -arguments to the bind. This means that we must extend the ZonkEnv with -these skolems when zonking the arguments to the bind. But the skolems -are different between the two arguments, and so we should theoretically -carry around different environments to use for the different arguments. - -However, this becomes a logistical nightmare, especially in dealing with -the more exotic Stmt forms. So, we simplify by making the critical -assumption that the uniques of the skolems are different. (This assumption -is justified by the use of newUnique in GHC.Tc.Utils.TcMType.instSkolTyCoVarX.) -Now, we can safely just extend one environment. --} - --- See Note [Skolems in zonkSyntaxExpr] -zonkSyntaxExpr :: ZonkEnv -> SyntaxExpr GhcTc - -> TcM (ZonkEnv, SyntaxExpr GhcTc) -zonkSyntaxExpr env (SyntaxExprTc { syn_expr = expr - , syn_arg_wraps = arg_wraps - , syn_res_wrap = res_wrap }) - = do { (env0, res_wrap') <- zonkCoFn env res_wrap - ; expr' <- zonkExpr env0 expr - ; (env1, arg_wraps') <- mapAccumLM zonkCoFn env0 arg_wraps - ; return (env1, SyntaxExprTc { syn_expr = expr' - , syn_arg_wraps = arg_wraps' - , syn_res_wrap = res_wrap' }) } -zonkSyntaxExpr env NoSyntaxExprTc = return (env, NoSyntaxExprTc) - -------------------------------------------------------------------------- - -zonkLCmd :: ZonkEnv -> LHsCmd GhcTc -> TcM (LHsCmd GhcTc) -zonkCmd :: ZonkEnv -> HsCmd GhcTc -> TcM (HsCmd GhcTc) - -zonkLCmd env cmd = wrapLocMA (zonkCmd env) cmd - -zonkCmd env (XCmd (HsWrap w cmd)) - = do { (env1, w') <- zonkCoFn env w - ; cmd' <- zonkCmd env1 cmd - ; return (XCmd (HsWrap w' cmd')) } -zonkCmd env (HsCmdArrApp ty e1 e2 ho rl) - = do new_e1 <- zonkLExpr env e1 - new_e2 <- zonkLExpr env e2 - new_ty <- zonkTcTypeToTypeX env ty - return (HsCmdArrApp new_ty new_e1 new_e2 ho rl) - -zonkCmd env (HsCmdArrForm x op f fixity args) - = do new_op <- zonkLExpr env op - new_args <- mapM (zonkCmdTop env) args - return (HsCmdArrForm x new_op f fixity new_args) - -zonkCmd env (HsCmdApp x c e) - = do new_c <- zonkLCmd env c - new_e <- zonkLExpr env e - return (HsCmdApp x new_c new_e) - -zonkCmd env (HsCmdLam x matches) - = do new_matches <- zonkMatchGroup env zonkLCmd matches - return (HsCmdLam x new_matches) - -zonkCmd env (HsCmdPar x lpar c rpar) - = do new_c <- zonkLCmd env c - return (HsCmdPar x lpar new_c rpar) - -zonkCmd env (HsCmdCase x expr ms) - = do new_expr <- zonkLExpr env expr - new_ms <- zonkMatchGroup env zonkLCmd ms - return (HsCmdCase x new_expr new_ms) - -zonkCmd env (HsCmdLamCase x lc_variant ms) - = do new_ms <- zonkMatchGroup env zonkLCmd ms - return (HsCmdLamCase x lc_variant new_ms) - -zonkCmd env (HsCmdIf x eCond ePred cThen cElse) - = do { (env1, new_eCond) <- zonkSyntaxExpr env eCond - ; new_ePred <- zonkLExpr env1 ePred - ; new_cThen <- zonkLCmd env1 cThen - ; new_cElse <- zonkLCmd env1 cElse - ; return (HsCmdIf x new_eCond new_ePred new_cThen new_cElse) } - -zonkCmd env (HsCmdLet x tkLet binds tkIn cmd) - = do (new_env, new_binds) <- zonkLocalBinds env binds - new_cmd <- zonkLCmd new_env cmd - return (HsCmdLet x tkLet new_binds tkIn new_cmd) - -zonkCmd env (HsCmdDo ty (L l stmts)) - = do (_, new_stmts) <- zonkStmts env zonkLCmd stmts - new_ty <- zonkTcTypeToTypeX env ty - return (HsCmdDo new_ty (L l new_stmts)) - - - -zonkCmdTop :: ZonkEnv -> LHsCmdTop GhcTc -> TcM (LHsCmdTop GhcTc) -zonkCmdTop env cmd = wrapLocMA (zonk_cmd_top env) cmd - -zonk_cmd_top :: ZonkEnv -> HsCmdTop GhcTc -> TcM (HsCmdTop GhcTc) -zonk_cmd_top env (HsCmdTop (CmdTopTc stack_tys ty ids) cmd) - = do new_cmd <- zonkLCmd env cmd - new_stack_tys <- zonkTcTypeToTypeX env stack_tys - new_ty <- zonkTcTypeToTypeX env ty - new_ids <- mapSndM (zonkExpr env) ids - - massert (isLiftedTypeKind (typeKind 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 - - return (HsCmdTop (CmdTopTc new_stack_tys new_ty new_ids) new_cmd) - -------------------------------------------------------------------------- -zonkCoFn :: ZonkEnv -> HsWrapper -> TcM (ZonkEnv, HsWrapper) -zonkCoFn env WpHole = return (env, WpHole) -zonkCoFn env (WpCompose c1 c2) = do { (env1, c1') <- zonkCoFn env c1 - ; (env2, c2') <- zonkCoFn env1 c2 - ; return (env2, WpCompose c1' c2') } -zonkCoFn env (WpFun c1 c2 t1) = do { (env1, c1') <- zonkCoFn env c1 - ; (env2, c2') <- zonkCoFn env1 c2 - ; t1' <- zonkScaledTcTypeToTypeX env2 t1 - ; return (env2, WpFun c1' c2' t1') } -zonkCoFn env (WpCast co) = do { co' <- zonkCoToCo env co - ; return (env, WpCast co') } -zonkCoFn env (WpEvLam ev) = do { (env', ev') <- zonkEvBndrX env ev - ; return (env', WpEvLam ev') } -zonkCoFn env (WpEvApp arg) = do { arg' <- zonkEvTerm env arg - ; return (env, WpEvApp arg') } -zonkCoFn env (WpTyLam tv) = assert (isImmutableTyVar tv) $ - do { (env', tv') <- zonkTyBndrX env tv - ; return (env', WpTyLam tv') } -zonkCoFn env (WpTyApp ty) = do { ty' <- zonkTcTypeToTypeX env ty - ; return (env, WpTyApp ty') } -zonkCoFn env (WpLet bs) = do { (env1, bs') <- zonkTcEvBinds env bs - ; return (env1, WpLet bs') } -zonkCoFn env (WpMultCoercion co) = do { co' <- zonkCoToCo env co - ; return (env, WpMultCoercion co') } - -------------------------------------------------------------------------- -zonkOverLit :: ZonkEnv -> HsOverLit GhcTc -> TcM (HsOverLit GhcTc) -zonkOverLit env lit@(OverLit {ol_ext = x@OverLitTc { ol_witness = e, ol_type = ty } }) - = do { ty' <- zonkTcTypeToTypeX env ty - ; e' <- zonkExpr env e - ; return (lit { ol_ext = x { ol_witness = e' - , ol_type = ty' } }) } - -------------------------------------------------------------------------- -zonkBracket :: ZonkEnv -> HsBracketTc -> TcM HsBracketTc -zonkBracket env (HsBracketTc hsb_thing ty wrap bs) - = do wrap' <- traverse zonkQuoteWrap wrap - bs' <- mapM (zonk_b env) bs - new_ty <- zonkTcTypeToTypeX env ty - return (HsBracketTc hsb_thing new_ty wrap' bs') - where - zonkQuoteWrap (QuoteWrapper ev ty) = do - let ev' = zonkIdOcc env ev - ty' <- zonkTcTypeToTypeX env ty - return (QuoteWrapper ev' ty') - - zonk_b env' (PendingTcSplice n e) = do e' <- zonkLExpr env' e - return (PendingTcSplice n e') - -------------------------------------------------------------------------- -zonkArithSeq :: ZonkEnv -> ArithSeqInfo GhcTc -> TcM (ArithSeqInfo GhcTc) - -zonkArithSeq env (From e) - = do new_e <- zonkLExpr env e - return (From new_e) - -zonkArithSeq env (FromThen e1 e2) - = do new_e1 <- zonkLExpr env e1 - new_e2 <- zonkLExpr env e2 - return (FromThen new_e1 new_e2) - -zonkArithSeq env (FromTo e1 e2) - = do new_e1 <- zonkLExpr env e1 - new_e2 <- zonkLExpr env e2 - return (FromTo new_e1 new_e2) - -zonkArithSeq env (FromThenTo e1 e2 e3) - = do new_e1 <- zonkLExpr env e1 - new_e2 <- zonkLExpr env e2 - new_e3 <- zonkLExpr env e3 - return (FromThenTo new_e1 new_e2 new_e3) - -------------------------------------------------------------------------- -zonkStmts :: Anno (StmtLR GhcTc GhcTc (LocatedA (body GhcTc))) ~ SrcSpanAnnA - => ZonkEnv - -> (ZonkEnv -> LocatedA (body GhcTc) -> TcM (LocatedA (body GhcTc))) - -> [LStmt GhcTc (LocatedA (body GhcTc))] - -> TcM (ZonkEnv, [LStmt GhcTc (LocatedA (body GhcTc))]) -zonkStmts env _ [] = return (env, []) -zonkStmts env zBody (s:ss) = do { (env1, s') <- wrapLocSndMA (zonkStmt env zBody) s - ; (env2, ss') <- zonkStmts env1 zBody ss - ; return (env2, s' : ss') } - -zonkStmt :: Anno (StmtLR GhcTc GhcTc (LocatedA (body GhcTc))) ~ SrcSpanAnnA - => ZonkEnv - -> (ZonkEnv -> LocatedA (body GhcTc) -> TcM (LocatedA (body GhcTc))) - -> Stmt GhcTc (LocatedA (body GhcTc)) - -> TcM (ZonkEnv, Stmt GhcTc (LocatedA (body GhcTc))) -zonkStmt env _ (ParStmt bind_ty stmts_w_bndrs mzip_op bind_op) - = do { (env1, new_bind_op) <- zonkSyntaxExpr env bind_op - ; new_bind_ty <- zonkTcTypeToTypeX env1 bind_ty - ; new_stmts_w_bndrs <- mapM (zonk_branch env1) stmts_w_bndrs - ; let new_binders = [b | ParStmtBlock _ _ bs _ <- new_stmts_w_bndrs - , b <- bs] - env2 = extendIdZonkEnvRec env1 new_binders - ; new_mzip <- zonkExpr env2 mzip_op - ; return (env2 - , ParStmt new_bind_ty new_stmts_w_bndrs new_mzip new_bind_op)} - where - zonk_branch :: ZonkEnv -> ParStmtBlock GhcTc GhcTc - -> TcM (ParStmtBlock GhcTc GhcTc) - zonk_branch env1 (ParStmtBlock x stmts bndrs return_op) - = do { (env2, new_stmts) <- zonkStmts env1 zonkLExpr stmts - ; (env3, new_return) <- zonkSyntaxExpr env2 return_op - ; return (ParStmtBlock x new_stmts (zonkIdOccs env3 bndrs) - new_return) } - -zonkStmt env zBody (RecStmt { recS_stmts = L _ segStmts, recS_later_ids = lvs - , recS_rec_ids = rvs - , recS_ret_fn = ret_id, recS_mfix_fn = mfix_id - , recS_bind_fn = bind_id - , recS_ext = - RecStmtTc { recS_bind_ty = bind_ty - , recS_later_rets = later_rets - , recS_rec_rets = rec_rets - , recS_ret_ty = ret_ty} }) - = do { (env1, new_bind_id) <- zonkSyntaxExpr env bind_id - ; (env2, new_mfix_id) <- zonkSyntaxExpr env1 mfix_id - ; (env3, new_ret_id) <- zonkSyntaxExpr env2 ret_id - ; new_bind_ty <- zonkTcTypeToTypeX env3 bind_ty - ; new_rvs <- zonkIdBndrs env3 rvs - ; new_lvs <- zonkIdBndrs env3 lvs - ; new_ret_ty <- zonkTcTypeToTypeX env3 ret_ty - ; let env4 = extendIdZonkEnvRec env3 new_rvs - ; (env5, new_segStmts) <- zonkStmts env4 zBody segStmts - -- Zonk the ret-expressions in an envt that - -- has the polymorphic bindings in the envt - ; new_later_rets <- mapM (zonkExpr env5) later_rets - ; new_rec_rets <- mapM (zonkExpr env5) rec_rets - ; return (extendIdZonkEnvRec env3 new_lvs, -- Only the lvs are needed - RecStmt { recS_stmts = noLocA new_segStmts - , recS_later_ids = new_lvs - , recS_rec_ids = new_rvs, recS_ret_fn = new_ret_id - , recS_mfix_fn = new_mfix_id, recS_bind_fn = new_bind_id - , recS_ext = RecStmtTc - { recS_bind_ty = new_bind_ty - , recS_later_rets = new_later_rets - , recS_rec_rets = new_rec_rets - , recS_ret_ty = new_ret_ty } }) } - -zonkStmt env zBody (BodyStmt ty body then_op guard_op) - = do (env1, new_then_op) <- zonkSyntaxExpr env then_op - (env2, new_guard_op) <- zonkSyntaxExpr env1 guard_op - new_body <- zBody env2 body - new_ty <- zonkTcTypeToTypeX env2 ty - return (env2, BodyStmt new_ty new_body new_then_op new_guard_op) - -zonkStmt env zBody (LastStmt x body noret ret_op) - = do (env1, new_ret) <- zonkSyntaxExpr env ret_op - new_body <- zBody env1 body - return (env, LastStmt x new_body noret new_ret) - -zonkStmt env _ (TransStmt { trS_stmts = stmts, trS_bndrs = binderMap - , trS_by = by, trS_form = form, trS_using = using - , trS_ret = return_op, trS_bind = bind_op - , trS_ext = bind_arg_ty - , trS_fmap = liftM_op }) - = do { - ; (env1, bind_op') <- zonkSyntaxExpr env bind_op - ; bind_arg_ty' <- zonkTcTypeToTypeX env1 bind_arg_ty - ; (env2, stmts') <- zonkStmts env1 zonkLExpr stmts - ; by' <- traverse (zonkLExpr env2) by - ; using' <- zonkLExpr env2 using - - ; (env3, return_op') <- zonkSyntaxExpr env2 return_op - ; binderMap' <- mapM (zonkBinderMapEntry env3) binderMap - ; liftM_op' <- zonkExpr env3 liftM_op - ; let env3' = extendIdZonkEnvRec env3 (map snd binderMap') - ; return (env3', TransStmt { trS_stmts = stmts', trS_bndrs = binderMap' - , trS_by = by', trS_form = form, trS_using = using' - , trS_ret = return_op', trS_bind = bind_op' - , trS_ext = bind_arg_ty' - , trS_fmap = liftM_op' }) } - where - zonkBinderMapEntry env (oldBinder, newBinder) = do - let oldBinder' = zonkIdOcc env oldBinder - newBinder' <- zonkIdBndr env newBinder - return (oldBinder', newBinder') - -zonkStmt env _ (LetStmt x binds) - = do (env1, new_binds) <- zonkLocalBinds env binds - return (env1, LetStmt x new_binds) - -zonkStmt env zBody (BindStmt xbs pat body) - = do { (env1, new_bind) <- zonkSyntaxExpr env (xbstc_bindOp xbs) - ; new_w <- zonkTcTypeToTypeX env1 (xbstc_boundResultMult xbs) - ; new_bind_ty <- zonkTcTypeToTypeX env1 (xbstc_boundResultType xbs) - ; new_body <- zBody env1 body - ; (env2, new_pat) <- zonkPat env1 pat - ; new_fail <- case xbstc_failOp xbs of - Nothing -> return Nothing - Just f -> fmap (Just . snd) (zonkSyntaxExpr env1 f) - ; return ( env2 - , BindStmt (XBindStmtTc - { xbstc_bindOp = new_bind - , xbstc_boundResultType = new_bind_ty - , xbstc_boundResultMult = new_w - , xbstc_failOp = new_fail - }) - new_pat new_body) } - --- Scopes: join > ops (in reverse order) > pats (in forward order) --- > rest of stmts -zonkStmt env _zBody (ApplicativeStmt body_ty args mb_join) - = do { (env1, new_mb_join) <- zonk_join env mb_join - ; (env2, new_args) <- zonk_args env1 args - ; new_body_ty <- zonkTcTypeToTypeX env2 body_ty - ; return ( env2 - , ApplicativeStmt new_body_ty new_args new_mb_join) } - where - zonk_join env Nothing = return (env, Nothing) - zonk_join env (Just j) = second Just <$> zonkSyntaxExpr env j - - get_pat :: (SyntaxExpr GhcTc, ApplicativeArg GhcTc) -> LPat GhcTc - get_pat (_, ApplicativeArgOne _ pat _ _) = pat - get_pat (_, ApplicativeArgMany _ _ _ pat _) = pat - - replace_pat :: LPat GhcTc - -> (SyntaxExpr GhcTc, ApplicativeArg GhcTc) - -> (SyntaxExpr GhcTc, ApplicativeArg GhcTc) - replace_pat pat (op, ApplicativeArgOne fail_op _ a isBody) - = (op, ApplicativeArgOne fail_op pat a isBody) - replace_pat pat (op, ApplicativeArgMany x a b _ c) - = (op, ApplicativeArgMany x a b pat c) - - zonk_args env args - = do { (env1, new_args_rev) <- zonk_args_rev env (reverse args) - ; (env2, new_pats) <- zonkPats env1 (map get_pat args) - ; return (env2, zipWithEqual "zonkStmt" replace_pat - new_pats (reverse new_args_rev)) } - - -- these need to go backward, because if any operators are higher-rank, - -- later operators may introduce skolems that are in scope for earlier - -- arguments - zonk_args_rev env ((op, arg) : args) - = do { (env1, new_op) <- zonkSyntaxExpr env op - ; new_arg <- zonk_arg env1 arg - ; (env2, new_args) <- zonk_args_rev env1 args - ; return (env2, (new_op, new_arg) : new_args) } - zonk_args_rev env [] = return (env, []) - - zonk_arg env (ApplicativeArgOne fail_op pat expr isBody) - = do { new_expr <- zonkLExpr env expr - ; new_fail <- forM fail_op $ \old_fail -> - do { (_, fail') <- zonkSyntaxExpr env old_fail - ; return fail' - } - ; return (ApplicativeArgOne new_fail pat new_expr isBody) } - zonk_arg env (ApplicativeArgMany x stmts ret pat ctxt) - = do { (env1, new_stmts) <- zonkStmts env zonkLExpr stmts - ; new_ret <- zonkExpr env1 ret - ; return (ApplicativeArgMany x new_stmts new_ret pat ctxt) } - -------------------------------------------------------------------------- -zonkRecFields :: ZonkEnv -> HsRecordBinds GhcTc -> TcM (HsRecordBinds GhcTc) -zonkRecFields env (HsRecFields flds dd) - = do { flds' <- mapM zonk_rbind flds - ; return (HsRecFields flds' dd) } - where - zonk_rbind (L l fld) - = do { new_id <- wrapLocMA (zonkFieldOcc env) (hfbLHS fld) - ; new_expr <- zonkLExpr env (hfbRHS fld) - ; return (L l (fld { hfbLHS = new_id - , hfbRHS = new_expr })) } - -{- -************************************************************************ -* * -\subsection[BackSubst-Pats]{Patterns} -* * -************************************************************************ --} - -zonkPat :: ZonkEnv -> LPat GhcTc -> TcM (ZonkEnv, 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 --- to the right) -zonkPat env pat = wrapLocSndMA (zonk_pat env) pat - -zonk_pat :: ZonkEnv -> Pat GhcTc -> TcM (ZonkEnv, Pat GhcTc) -zonk_pat env (ParPat x lpar p rpar) - = do { (env', p') <- zonkPat env p - ; return (env', ParPat x lpar p' rpar) } - -zonk_pat env (WildPat ty) - = do { ty' <- zonkTcTypeToTypeX env ty - ; return (env, WildPat ty') } - -zonk_pat env (VarPat x (L l v)) - = do { v' <- zonkIdBndr env v - ; return (extendIdZonkEnv env v', VarPat x (L l v')) } - -zonk_pat env (LazyPat x pat) - = do { (env', pat') <- zonkPat env pat - ; return (env', LazyPat x pat') } - -zonk_pat env (BangPat x pat) - = do { (env', pat') <- zonkPat env pat - ; return (env', BangPat x pat') } - -zonk_pat env (AsPat x (L loc v) at pat) - = do { v' <- zonkIdBndr env v - ; (env', pat') <- zonkPat (extendIdZonkEnv env v') pat - ; return (env', AsPat x (L loc v') at pat') } - -zonk_pat env (ViewPat ty expr pat) - = do { expr' <- zonkLExpr env expr - ; (env', pat') <- zonkPat env pat - ; ty' <- zonkTcTypeToTypeX env ty - ; return (env', ViewPat ty' expr' pat') } - -zonk_pat env (ListPat ty pats) - = do { ty' <- zonkTcTypeToTypeX env ty - ; (env', pats') <- zonkPats env pats - ; return (env', ListPat ty' pats') } - -zonk_pat env (TuplePat tys pats boxed) - = do { tys' <- mapM (zonkTcTypeToTypeX env) tys - ; (env', pats') <- zonkPats env pats - ; return (env', TuplePat tys' pats' boxed) } - -zonk_pat env (SumPat tys pat alt arity ) - = do { tys' <- mapM (zonkTcTypeToTypeX env) tys - ; (env', pat') <- zonkPat env pat - ; return (env', SumPat tys' pat' alt arity) } - -zonk_pat env p@(ConPat { pat_args = args - , pat_con_ext = p'@(ConPatTc - { cpt_tvs = tyvars - , cpt_dicts = evs - , cpt_binds = binds - , cpt_wrap = wrapper - , cpt_arg_tys = tys - }) - }) - = assert (all isImmutableTyVar tyvars) $ - do { new_tys <- mapM (zonkTcTypeToTypeX env) tys - ; (env0, new_tyvars) <- zonkTyBndrsX env tyvars - -- Must zonk the existential variables, because their - -- /kind/ need potential zonking. - -- cf typecheck/should_compile/tc221.hs - ; (env1, new_evs) <- zonkEvBndrsX env0 evs - ; (env2, new_binds) <- zonkTcEvBinds env1 binds - ; (env3, new_wrapper) <- zonkCoFn env2 wrapper - ; (env', new_args) <- zonkConStuff env3 args - ; pure ( env' - , p - { pat_args = new_args - , pat_con_ext = p' - { cpt_arg_tys = new_tys - , cpt_tvs = new_tyvars - , cpt_dicts = new_evs - , cpt_binds = new_binds - , cpt_wrap = new_wrapper - } - } - ) - } - -zonk_pat env (LitPat x lit) = return (env, LitPat x lit) - -zonk_pat env (SigPat ty pat hs_ty) - = do { ty' <- zonkTcTypeToTypeX env ty - ; (env', pat') <- zonkPat env pat - ; return (env', SigPat ty' pat' hs_ty) } - -zonk_pat env (NPat ty (L l lit) mb_neg eq_expr) - = do { (env1, eq_expr') <- zonkSyntaxExpr env eq_expr - ; (env2, mb_neg') <- case mb_neg of - Nothing -> return (env1, Nothing) - Just n -> second Just <$> zonkSyntaxExpr env1 n - - ; lit' <- zonkOverLit env2 lit - ; ty' <- zonkTcTypeToTypeX env2 ty - ; return (env2, NPat ty' (L l lit') mb_neg' eq_expr') } - -zonk_pat env (NPlusKPat ty (L loc n) (L l lit1) lit2 e1 e2) - = do { (env1, e1') <- zonkSyntaxExpr env e1 - ; (env2, e2') <- zonkSyntaxExpr env1 e2 - ; n' <- zonkIdBndr env2 n - ; lit1' <- zonkOverLit env2 lit1 - ; lit2' <- zonkOverLit env2 lit2 - ; ty' <- zonkTcTypeToTypeX env2 ty - ; return (extendIdZonkEnv env2 n', - NPlusKPat ty' (L loc n') (L l lit1') lit2' e1' e2') } -zonk_pat env (XPat ext) = case ext of - { ExpansionPat orig pat-> - do { (env, pat') <- zonk_pat env pat - ; return $ (env, XPat $ ExpansionPat orig pat') } - ; CoPat co_fn pat ty -> - do { (env', co_fn') <- zonkCoFn env co_fn - ; (env'', pat') <- zonkPat env' (noLocA pat) - ; ty' <- zonkTcTypeToTypeX env'' ty - ; return (env'', XPat $ CoPat co_fn' (unLoc pat') ty') - }} - -zonk_pat _ pat = pprPanic "zonk_pat" (ppr pat) - ---------------------------- -zonkConStuff :: ZonkEnv -> HsConPatDetails GhcTc - -> TcM (ZonkEnv, HsConPatDetails GhcTc) -zonkConStuff env (PrefixCon tyargs pats) - = do { (env', pats') <- zonkPats env pats - ; return (env', PrefixCon tyargs pats') } - -zonkConStuff env (InfixCon p1 p2) - = do { (env1, p1') <- zonkPat env p1 - ; (env', p2') <- zonkPat env1 p2 - ; return (env', InfixCon p1' p2') } - -zonkConStuff env (RecCon (HsRecFields rpats dd)) - = do { (env', pats') <- zonkPats env (map (hfbRHS . unLoc) rpats) - ; let rpats' = zipWith (\(L l rp) p' -> - L l (rp { hfbRHS = p' })) - rpats pats' - ; return (env', RecCon (HsRecFields rpats' dd)) } - -- Field selectors have declared types; hence no zonking - ---------------------------- -zonkPats :: ZonkEnv -> [LPat GhcTc] -> TcM (ZonkEnv, [LPat GhcTc]) -zonkPats env [] = return (env, []) -zonkPats env (pat:pats) = do { (env1, pat') <- zonkPat env pat - ; (env', pats') <- zonkPats env1 pats - ; return (env', pat':pats') } - -{- -************************************************************************ -* * -\subsection[BackSubst-Foreign]{Foreign exports} -* * -************************************************************************ --} - -zonkForeignExports :: ZonkEnv -> [LForeignDecl GhcTc] - -> TcM [LForeignDecl GhcTc] -zonkForeignExports env ls = mapM (wrapLocMA (zonkForeignExport env)) ls - -zonkForeignExport :: ZonkEnv -> ForeignDecl GhcTc -> TcM (ForeignDecl GhcTc) -zonkForeignExport env (ForeignExport { fd_name = i, fd_e_ext = co - , fd_fe = spec }) - = return (ForeignExport { fd_name = zonkLIdOcc env i - , fd_sig_ty = undefined, fd_e_ext = co - , fd_fe = spec }) -zonkForeignExport _ for_imp - = return for_imp -- Foreign imports don't need zonking - -zonkRules :: ZonkEnv -> [LRuleDecl GhcTc] -> TcM [LRuleDecl GhcTc] -zonkRules env rs = mapM (wrapLocMA (zonkRule env)) rs - -zonkRule :: ZonkEnv -> RuleDecl GhcTc -> TcM (RuleDecl GhcTc) -zonkRule env rule@(HsRule { rd_tmvs = tm_bndrs{-::[RuleBndr TcId]-} - , rd_lhs = lhs - , rd_rhs = rhs }) - = do { (env_inside, new_tm_bndrs) <- mapAccumLM zonk_tm_bndr env tm_bndrs - - ; let env_lhs = setZonkType env_inside SkolemiseFlexi - -- See Note [Zonking the LHS of a RULE] - - ; new_lhs <- zonkLExpr env_lhs lhs - ; new_rhs <- zonkLExpr env_inside rhs - - ; return $ rule { rd_tmvs = new_tm_bndrs - , rd_lhs = new_lhs - , rd_rhs = new_rhs } } - where - zonk_tm_bndr :: ZonkEnv -> LRuleBndr GhcTc -> TcM (ZonkEnv, LRuleBndr GhcTc) - zonk_tm_bndr env (L l (RuleBndr x (L loc v))) - = do { (env', v') <- zonk_it env v - ; return (env', L l (RuleBndr x (L loc v'))) } - zonk_tm_bndr _ (L _ (RuleBndrSig {})) = panic "zonk_tm_bndr RuleBndrSig" - - zonk_it env v - | isId v = do { v' <- zonkIdBndr env v - ; return (extendIdZonkEnvRec env [v'], v') } - | otherwise = assert (isImmutableTyVar v) - zonkTyBndrX env v - -- DV: used to be return (env,v) but that is plain - -- wrong because we may need to go inside the kind - -- of v and zonk there! - -{- -************************************************************************ -* * - Constraints and evidence -* * -************************************************************************ --} - -zonkEvTerm :: ZonkEnv -> EvTerm -> TcM EvTerm -zonkEvTerm env (EvExpr e) - = EvExpr <$> zonkCoreExpr env e -zonkEvTerm env (EvTypeable ty ev) - = EvTypeable <$> zonkTcTypeToTypeX env ty <*> zonkEvTypeable env ev -zonkEvTerm env (EvFun { et_tvs = tvs, et_given = evs - , et_binds = ev_binds, et_body = body_id }) - = do { (env0, new_tvs) <- zonkTyBndrsX env tvs - ; (env1, new_evs) <- zonkEvBndrsX env0 evs - ; (env2, new_ev_binds) <- zonkTcEvBinds env1 ev_binds - ; let new_body_id = zonkIdOcc env2 body_id - ; return (EvFun { et_tvs = new_tvs, et_given = new_evs - , et_binds = new_ev_binds, et_body = new_body_id }) } - -zonkCoreExpr :: ZonkEnv -> CoreExpr -> TcM CoreExpr -zonkCoreExpr env (Var v) - | isCoVar v - = Coercion <$> zonkCoVarOcc env v - | otherwise - = return (Var $ zonkIdOcc env v) -zonkCoreExpr _ (Lit l) - = return $ Lit l -zonkCoreExpr env (Coercion co) - = Coercion <$> zonkCoToCo env co -zonkCoreExpr env (Type ty) - = Type <$> zonkTcTypeToTypeX env ty - -zonkCoreExpr env (Cast e co) - = Cast <$> zonkCoreExpr env e <*> zonkCoToCo env co -zonkCoreExpr env (Tick t e) - = Tick t <$> zonkCoreExpr env e -- Do we need to zonk in ticks? - -zonkCoreExpr env (App e1 e2) - = App <$> zonkCoreExpr env e1 <*> zonkCoreExpr env e2 -zonkCoreExpr env (Lam v e) - = do { (env1, v') <- zonkCoreBndrX env v - ; Lam v' <$> zonkCoreExpr env1 e } -zonkCoreExpr env (Let bind e) - = do (env1, bind') <- zonkCoreBind env bind - Let bind'<$> zonkCoreExpr env1 e -zonkCoreExpr env (Case scrut b ty alts) - = do scrut' <- zonkCoreExpr env scrut - ty' <- zonkTcTypeToTypeX env ty - b' <- zonkIdBndr env b - let env1 = extendIdZonkEnv env b' - alts' <- mapM (zonkCoreAlt env1) alts - return $ Case scrut' b' ty' alts' - -zonkCoreAlt :: ZonkEnv -> CoreAlt -> TcM CoreAlt -zonkCoreAlt env (Alt dc bndrs rhs) - = do (env1, bndrs') <- zonkCoreBndrsX env bndrs - rhs' <- zonkCoreExpr env1 rhs - return $ Alt dc bndrs' rhs' - -zonkCoreBind :: ZonkEnv -> CoreBind -> TcM (ZonkEnv, CoreBind) -zonkCoreBind env (NonRec v e) - = do v' <- zonkIdBndr env v - e' <- zonkCoreExpr env e - let env1 = extendIdZonkEnv env v' - return (env1, NonRec v' e') -zonkCoreBind env (Rec pairs) - = do (env1, pairs') <- fixM go - return (env1, Rec pairs') - where - go ~(_, new_pairs) = do - let env1 = extendIdZonkEnvRec env (map fst new_pairs) - pairs' <- mapM (zonkCorePair env1) pairs - return (env1, pairs') - -zonkCorePair :: ZonkEnv -> (CoreBndr, CoreExpr) -> TcM (CoreBndr, CoreExpr) -zonkCorePair env (v,e) = (,) <$> zonkIdBndr env v <*> zonkCoreExpr env e - -zonkEvTypeable :: ZonkEnv -> EvTypeable -> TcM EvTypeable -zonkEvTypeable env (EvTypeableTyCon tycon e) - = do { e' <- mapM (zonkEvTerm env) e - ; return $ EvTypeableTyCon tycon e' } -zonkEvTypeable env (EvTypeableTyApp t1 t2) - = do { t1' <- zonkEvTerm env t1 - ; t2' <- zonkEvTerm env t2 - ; return (EvTypeableTyApp t1' t2') } -zonkEvTypeable env (EvTypeableTrFun tm t1 t2) - = do { tm' <- zonkEvTerm env tm - ; t1' <- zonkEvTerm env t1 - ; t2' <- zonkEvTerm env t2 - ; return (EvTypeableTrFun tm' t1' t2') } -zonkEvTypeable env (EvTypeableTyLit t1) - = do { t1' <- zonkEvTerm env t1 - ; return (EvTypeableTyLit t1') } - -zonkTcEvBinds_s :: ZonkEnv -> [TcEvBinds] -> TcM (ZonkEnv, [TcEvBinds]) -zonkTcEvBinds_s env bs = do { (env, bs') <- mapAccumLM zonk_tc_ev_binds env bs - ; return (env, [EvBinds (unionManyBags bs')]) } - -zonkTcEvBinds :: ZonkEnv -> TcEvBinds -> TcM (ZonkEnv, TcEvBinds) -zonkTcEvBinds env bs = do { (env', bs') <- zonk_tc_ev_binds env bs - ; return (env', EvBinds bs') } - -zonk_tc_ev_binds :: ZonkEnv -> TcEvBinds -> TcM (ZonkEnv, Bag EvBind) -zonk_tc_ev_binds env (TcEvBinds var) = zonkEvBindsVar env var -zonk_tc_ev_binds env (EvBinds bs) = zonkEvBinds env bs - -zonkEvBindsVar :: ZonkEnv -> EvBindsVar -> TcM (ZonkEnv, Bag EvBind) -zonkEvBindsVar env (EvBindsVar { ebv_binds = ref }) - = do { bs <- readMutVar ref - ; zonkEvBinds env (evBindMapBinds bs) } -zonkEvBindsVar env (CoEvBindsVar {}) = return (env, emptyBag) - -zonkEvBinds :: ZonkEnv -> Bag EvBind -> TcM (ZonkEnv, Bag EvBind) -zonkEvBinds env binds - = {-# SCC "zonkEvBinds" #-} - fixM (\ ~( _, new_binds) -> do - { let env1 = extendIdZonkEnvRec env (collect_ev_bndrs new_binds) - ; binds' <- mapBagM (zonkEvBind env1) binds - ; return (env1, binds') }) - where - collect_ev_bndrs :: Bag EvBind -> [EvVar] - collect_ev_bndrs = foldr add [] - add (EvBind { eb_lhs = var }) vars = var : vars - -zonkEvBind :: ZonkEnv -> EvBind -> TcM EvBind -zonkEvBind env bind@(EvBind { eb_lhs = var, eb_rhs = term }) - = do { var' <- {-# SCC "zonkEvBndr" #-} zonkEvBndr env var - - -- Optimise the common case of Refl coercions - -- See Note [Optimise coercion zonking] - -- This has a very big effect on some programs (eg #5030) - - ; term' <- case getEqPredTys_maybe (idType var') of - Just (r, ty1, ty2) | ty1 `eqType` ty2 - -> return (evCoercion (mkReflCo r ty1)) - _other -> zonkEvTerm env term - - ; return (bind { eb_lhs = var', eb_rhs = term' }) } - -{- Note [Optimise coercion zonking] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When optimising evidence binds we may come across situations where -a coercion looks like - cv = ReflCo ty -or cv1 = cv2 -where the type 'ty' is big. In such cases it is a waste of time to zonk both - * The variable on the LHS - * The coercion on the RHS -Rather, we can zonk the variable, and if its type is (ty ~ ty), we can just -use Refl on the right, ignoring the actual coercion on the RHS. - -This can have a very big effect, because the constraint solver sometimes does go -to a lot of effort to prove Refl! (Eg when solving 10+3 = 10+3; cf #5030) - - -************************************************************************ -* * - Zonking types -* * -************************************************************************ --} - -{- Note [Sharing when zonking to Type] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Problem: - - In GHC.Tc.Utils.TcMType.zonkTcTyVar, we short-circuit (Indirect ty) to - (Indirect zty), see Note [Sharing in zonking] in GHC.Tc.Utils.TcMType. But we - /can't/ do this when zonking a TcType to a Type (#15552, esp - comment:3). Suppose we have - - alpha -> alpha - where - alpha is already unified: - alpha := T{tc-tycon} Int -> Int - and T is knot-tied - - By "knot-tied" I mean that the occurrence of T is currently a TcTyCon, - but the global env contains a mapping "T" :-> T{knot-tied-tc}. See - Note [Type checking recursive type and class declarations] in - GHC.Tc.TyCl. - - Now we call zonkTcTypeToType on that (alpha -> alpha). If we follow - the same path as Note [Sharing in zonking] in GHC.Tc.Utils.TcMType, we'll - update alpha to - alpha := T{knot-tied-tc} Int -> Int - - But alas, if we encounter alpha for a /second/ time, we end up - looking at T{knot-tied-tc} and fall into a black hole. The whole - point of zonkTcTypeToType is that it produces a type full of - knot-tied tycons, and you must not look at the result!! - - To put it another way (zonkTcTypeToType . zonkTcTypeToType) is not - the same as zonkTcTypeToType. (If we distinguished TcType from - Type, this issue would have been a type error!) - -Solutions: (see #15552 for other variants) - -One possible solution is simply not to do the short-circuiting. -That has less sharing, but maybe sharing is rare. And indeed, -that usually turns out to be viable from a perf point of view - -But zonkTyVarOcc implements something a bit better - -* ZonkEnv contains ze_meta_tv_env, which maps - from a MetaTyVar (unification variable) - to a Type (not a TcType) - -* In zonkTyVarOcc, we check this map to see if we have zonked - this variable before. If so, use the previous answer; if not - zonk it, and extend the map. - -* The map is of course stateful, held in a TcRef. (That is unlike - the treatment of lexically-scoped variables in ze_tv_env and - ze_id_env.) - -* In zonkTyVarOcc we read the TcRef to look up the unification - variable: - - if we get a hit we use the zonked result; - - if not, in zonk_meta we see if the variable is `Indirect ty`, - zonk that, and update the map (in finish_meta) - But Nota Bene that the "update map" step must re-read the TcRef - (or, more precisely, use updTcRef) because the zonking of the - `Indirect ty` may have added lots of stuff to the map. See - #19668 for an example where this made an asymptotic difference! - -Is it worth the extra work of carrying ze_meta_tv_env? Some -non-systematic perf measurements suggest that compiler allocation is -reduced overall (by 0.5% or so) but compile time really doesn't -change. But in some cases it makes a HUGE difference: see test -T9198 and #19668. So yes, it seems worth it. --} - -zonkTyVarOcc :: HasDebugCallStack => ZonkEnv -> TcTyVar -> TcM Type -zonkTyVarOcc env@(ZonkEnv { ze_flexi = flexi - , ze_tv_env = tv_env - , ze_meta_tv_env = mtv_env_ref }) tv - | isTcTyVar tv - = case tcTyVarDetails tv of - SkolemTv {} -> lookup_in_tv_env - RuntimeUnk {} -> lookup_in_tv_env - MetaTv { mtv_ref = ref } - -> do { mtv_env <- readTcRef mtv_env_ref - -- See Note [Sharing when zonking to Type] - ; case lookupVarEnv mtv_env tv of - Just ty -> return ty - Nothing -> do { mtv_details <- readTcRef ref - ; zonk_meta ref mtv_details } } - | otherwise -- This should never really happen; - -- TyVars should not occur in the typechecker - = lookup_in_tv_env - - where - lookup_in_tv_env -- Look up in the env just as we do for Ids - = case lookupVarEnv tv_env tv of - Nothing -> -- TyVar/SkolemTv/RuntimeUnk that isn't in the ZonkEnv - -- This can happen for RuntimeUnk variables (which - -- should stay as RuntimeUnk), but I think it should - -- not happen for SkolemTv. - mkTyVarTy <$> updateTyVarKindM (zonkTcTypeToTypeX env) tv - - Just tv' -> return (mkTyVarTy tv') - - zonk_meta ref Flexi - = do { kind <- zonkTcTypeToTypeX env (tyVarKind tv) - ; ty <- commitFlexi flexi tv kind - ; writeMetaTyVarRef tv ref ty -- Belt and braces - ; finish_meta ty } - - zonk_meta _ (Indirect ty) - = do { zty <- zonkTcTypeToTypeX env ty - ; finish_meta zty } - - finish_meta ty - = do { updTcRef mtv_env_ref (\env -> extendVarEnv env tv ty) - ; return ty } - -lookupTyVarX :: ZonkEnv -> TcTyVar -> TyVar -lookupTyVarX (ZonkEnv { ze_tv_env = tv_env }) tv - = case lookupVarEnv tv_env tv of - Just tv -> tv - Nothing -> pprPanic "lookupTyVarOcc" (ppr tv $$ ppr tv_env) - -commitFlexi :: ZonkFlexi -> TcTyVar -> Kind -> TcM Type --- Only monadic so we can do tc-tracing -commitFlexi flexi tv zonked_kind - = case flexi of - SkolemiseFlexi -> return (mkTyVarTy (mkTyVar name zonked_kind)) - - DefaultFlexi - -- Normally, RuntimeRep variables are defaulted in 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 $ TcRnCannotDefaultConcrete 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 - - NoFlexi -> pprPanic "NoFlexi" (ppr tv <+> dcolon <+> ppr zonked_kind) - - where - name = tyVarName tv - -zonkCoVarOcc :: ZonkEnv -> CoVar -> TcM Coercion -zonkCoVarOcc (ZonkEnv { ze_tv_env = tyco_env }) cv - | Just cv' <- lookupVarEnv tyco_env cv -- don't look in the knot-tied env - = return $ mkCoVarCo cv' - | otherwise - = do { cv' <- zonkCoVar cv; return (mkCoVarCo cv') } - -zonkCoHole :: ZonkEnv -> CoercionHole -> TcM Coercion -zonkCoHole env hole@(CoercionHole { ch_ref = ref, ch_co_var = cv }) - = do { contents <- readTcRef ref - ; case contents of - Just co -> do { co' <- zonkCoToCo env co - ; checkCoercionHole cv co' } - - -- This next case should happen only in the presence of - -- (undeferred) type errors. Originally, I put in a panic - -- here, but that caused too many uses of `failIfErrsM`. - Nothing -> do { traceTc "Zonking unfilled coercion hole" (ppr hole) - ; cv' <- zonkCoVar cv - ; return $ mkCoVarCo cv' } } - -- This will be an out-of-scope variable, but keeping - -- this as a coercion hole led to #15787 - -zonk_tycomapper :: TyCoMapper ZonkEnv TcM -zonk_tycomapper = TyCoMapper - { tcm_tyvar = zonkTyVarOcc - , tcm_covar = zonkCoVarOcc - , tcm_hole = zonkCoHole - , tcm_tycobinder = \env tv _vis -> zonkTyBndrX env tv - , tcm_tycon = zonkTcTyConToTyCon } - --- Zonk a TyCon by changing a TcTyCon to a regular TyCon -zonkTcTyConToTyCon :: TcTyCon -> TcM TyCon -zonkTcTyConToTyCon tc - | isTcTyCon tc = do { thing <- tcLookupGlobalOnly (getName tc) - ; case thing of - ATyCon real_tc -> return real_tc - _ -> pprPanic "zonkTcTyCon" (ppr tc $$ ppr thing) } - | otherwise = return tc -- it's already zonked - --- Confused by zonking? See Note [What is zonking?] in GHC.Tc.Utils.TcMType. -zonkTcTypeToType :: TcType -> TcM Type -zonkTcTypeToType ty = initZonkEnv $ \ ze -> zonkTcTypeToTypeX ze ty - -zonkScaledTcTypeToTypeX :: ZonkEnv -> Scaled TcType -> TcM (Scaled TcType) -zonkScaledTcTypeToTypeX env (Scaled m ty) = Scaled <$> zonkTcTypeToTypeX env m - <*> zonkTcTypeToTypeX env ty - -zonkTcTypeToTypeX :: ZonkEnv -> TcType -> TcM Type -zonkTcTypesToTypesX :: ZonkEnv -> [TcType] -> TcM [Type] -zonkCoToCo :: ZonkEnv -> Coercion -> TcM Coercion -(zonkTcTypeToTypeX, zonkTcTypesToTypesX, zonkCoToCo, _) - = mapTyCoX zonk_tycomapper - -zonkScaledTcTypesToTypesX :: ZonkEnv -> [Scaled TcType] -> TcM [Scaled Type] -zonkScaledTcTypesToTypesX env scaled_tys = - mapM (zonkScaledTcTypeToTypeX env) scaled_tys - -zonkTcMethInfoToMethInfoX :: ZonkEnv -> TcMethInfo -> TcM MethInfo -zonkTcMethInfoToMethInfoX ze (name, ty, gdm_spec) - = do { ty' <- zonkTcTypeToTypeX ze ty - ; gdm_spec' <- zonk_gdm gdm_spec - ; return (name, ty', gdm_spec') } - where - zonk_gdm :: Maybe (DefMethSpec (SrcSpan, TcType)) - -> TcM (Maybe (DefMethSpec (SrcSpan, Type))) - zonk_gdm Nothing = return Nothing - zonk_gdm (Just VanillaDM) = return (Just VanillaDM) - zonk_gdm (Just (GenericDM (loc, ty))) - = do { ty' <- zonkTcTypeToTypeX ze ty - ; return (Just (GenericDM (loc, ty'))) } - ---------------------------------------- -{- Note [Zonking the LHS of a RULE] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -See also GHC.HsToCore.Binds Note [Free tyvars on rule LHS] - -We need to gather the type variables mentioned on the LHS so we can -quantify over them. Example: - 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)) and we do -not want to zap the unbound meta-tyvar 'alpha' to Any, because that -limits the applicability of the rule. Instead, we want to quantify -over it! - -We do this in two stages. - -* During zonking, we skolemise the TcTyVar 'alpha' to TyVar 'a'. We - do this by using zonkTvSkolemising as the UnboundTyVarZonker in the - ZonkEnv. (This is in fact the whole reason that the ZonkEnv has a - UnboundTyVarZonker.) - -* In GHC.HsToCore.Binds, we quantify over it. See GHC.HsToCore.Binds - Note [Free tyvars on rule LHS] - -Quantifying here is awkward because (a) the data type is big and (b) -finding the free type vars of an expression is necessarily monadic -operation. (consider /\a -> f @ b, where b is side-effected to a) --} diff --git a/GHC/Tc/Validity.hs b/GHC/Tc/Validity.hs --- a/GHC/Tc/Validity.hs +++ b/GHC/Tc/Validity.hs @@ -1,7 +1,5 @@ {-# LANGUAGE DerivingStrategies #-} - -{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} +{-# LANGUAGE LambdaCase #-} {- (c) The University of Glasgow 2006 @@ -14,8 +12,8 @@ checkValidInstance, checkValidInstHead, validDerivPred, checkTySynRhs, checkEscapingKind, checkValidCoAxiom, checkValidCoAxBranch, + checkFamPatBinders, checkTyFamEqnValidityInfo, checkValidTyFamEqn, checkValidAssocTyFamDeflt, checkConsistentFamInst, - arityErr, checkTyConTelescope, ) where @@ -27,22 +25,22 @@ -- friends: import GHC.Tc.Utils.Unify ( tcSubTypeAmbiguity ) import GHC.Tc.Solver ( simplifyAmbiguityCheck ) -import GHC.Tc.Instance.Class ( matchGlobalInst, ClsInstResult(..), InstanceWhat(..), AssocInstInfo(..) ) -import GHC.Tc.Utils.TcType +import GHC.Tc.Instance.Class ( matchGlobalInst, ClsInstResult(..), AssocInstInfo(..) ) +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.Utils.Env ( tcInitTidyEnv, tcInitOpenTidyEnv ) -import GHC.Tc.Instance.FunDeps -import GHC.Tc.Instance.Family +import GHC.Tc.Zonk.TcType import GHC.Builtin.Types import GHC.Builtin.Names import GHC.Builtin.Uniques ( mkAlphaTyVarUnique ) import GHC.Core.Type -import GHC.Core.Unify ( tcMatchTyX_BM, BindFlag(..) ) +import GHC.Core.Unify ( typesAreApart, tcMatchTyX_BM, BindFlag(..) ) import GHC.Core.Coercion import GHC.Core.Coercion.Axiom import GHC.Core.Class @@ -51,22 +49,24 @@ 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(..) ) -import GHC.Iface.Type ( pprIfaceType, pprIfaceTypeApp ) -import GHC.CoreToIface ( toIfaceTyCon, toIfaceTcArgs, toIfaceType ) import GHC.Hs import GHC.Driver.Session 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 -import GHC.Types.Var ( VarBndr(..), isInvisibleFunArg, mkTyVar ) +import GHC.Types.Var ( VarBndr(..), isInvisibleFunArg, mkTyVar, tyVarName ) +import GHC.Types.SourceFile import GHC.Types.SrcLoc +import GHC.Types.TyThing ( TyThing(..) ) import GHC.Types.Unique.Set( isEmptyUniqSet ) import GHC.Utils.FV @@ -84,6 +84,7 @@ import Data.Function import Data.List ( (\\) ) import qualified Data.List.NonEmpty as NE +import Data.List.NonEmpty ( NonEmpty(..) ) {- ************************************************************************ @@ -232,29 +233,23 @@ checkAmbiguity :: UserTypeCtxt -> Type -> TcM () checkAmbiguity ctxt ty | wantAmbiguityCheck ctxt - = do { traceTc "Ambiguity check for" (ppr ty) + = do { traceTc "Ambiguity check for {" (ppr ty) -- Solve the constraints eagerly because an ambiguous type -- can cause a cascade of further errors. Since the free -- tyvars are skolemised, we can safely use tcSimplifyTop ; allow_ambiguous <- xoptM LangExt.AllowAmbiguousTypes - ; (_wrap, wanted) <- addErrCtxt (mk_msg allow_ambiguous) $ - captureConstraints $ - tcSubTypeAmbiguity ctxt ty ty - -- See Note [Ambiguity check and deep subsumption] - -- in GHC.Tc.Utils.Unify - ; simplifyAmbiguityCheck ty wanted + ; unless allow_ambiguous $ + do { (_wrap, wanted) <- addErrCtxt (AmbiguityCheckCtxt ctxt allow_ambiguous) $ + captureConstraints $ + tcSubTypeAmbiguity ctxt ty ty + -- See Note [Ambiguity check and deep subsumption] + -- in GHC.Tc.Utils.Unify + ; simplifyAmbiguityCheck ty wanted } - ; traceTc "Done ambiguity check for" (ppr ty) } + ; traceTc "} Done ambiguity check for" (ppr ty) } | 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 @@ -284,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 <- tcInitTidyEnv - ; let (env1, tidy_msg) = tidyOpenType env0 msg - ; failWithTcM (env1, TcRnUserTypeError tidy_msg) - } + = return () {- Note [When we don't check for ambiguity] @@ -387,7 +372,6 @@ = case ctxt of DefaultDeclCtxt-> MustBeMonoType PatSigCtxt -> rank0 - RuleSigCtxt {} -> rank1 TySynCtxt _ -> rank0 ExprSigCtxt {} -> rank1 @@ -411,15 +395,16 @@ 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 - ; env <- tcInitOpenTidyEnv (tyCoVarsOfTypeList ty) + ; env <- liftZonkM $ tcInitOpenTidyEnv (tyCoVarsOfTypeList ty) ; expand <- initialExpandMode ; let ve = ValidityEnv{ ve_tidy_env = env, ve_ctxt = ctxt , ve_rank = rank, ve_expand = expand } @@ -442,7 +427,7 @@ checkValidMonoType :: Type -> TcM () -- Assumes argument is fully zonked checkValidMonoType ty - = do { env <- tcInitOpenTidyEnv (tyCoVarsOfTypeList ty) + = do { env <- liftZonkM $ tcInitOpenTidyEnv (tyCoVarsOfTypeList ty) ; expand <- initialExpandMode ; let ve = ValidityEnv{ ve_tidy_env = env, ve_ctxt = SigmaCtxt , ve_rank = MustBeMonoType, ve_expand = expand } @@ -475,7 +460,7 @@ MkT :: forall l. T @l :: TYPE (BoxedRep l) which is ill-kinded. -For ordinary /user-written type signatures f :: blah, we make this +For ordinary /user-written/ type signatures f :: blah, we make this check as part of kind-checking the type signature in tcHsSigType; see Note [Escaping kind in type signatures] in GHC.Tc.Gen.HsType. @@ -548,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 @@ -571,6 +556,8 @@ typeOrKindCtxt (TySynKindCtxt {}) = OnlyKindCtxt typeOrKindCtxt (TyFamResKindCtxt {}) = OnlyKindCtxt +-- These cases are also described in Note [No constraints in kinds], so any +-- change here should be reflected in that note. typeOrKindCtxt (TySynCtxt {}) = BothTypeAndKindCtxt -- Type synonyms can have types and kinds on their RHSs typeOrKindCtxt (GhciCtxt {}) = BothTypeAndKindCtxt @@ -594,7 +581,6 @@ -- | Returns 'True' if the supplied 'UserTypeCtxt' is unambiguously not the -- context for a kind of a type, where the arbitrary use of constraints is -- currently disallowed. --- (See @Note [Constraints in kinds]@ in "GHC.Core.TyCo.Rep".) allConstraintsAllowed :: UserTypeCtxt -> Bool allConstraintsAllowed = typeLevelUserTypeCtxt @@ -775,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 @@ -789,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 @@ -827,7 +824,8 @@ where (arg_rank, res_rank) = funArgResRank rank -check_type _ ty = pprPanic "check_type" (ppr ty) +check_type _ ty@(ForAllTy {}) = pprPanic "check_type" (ppr ty) +check_type _ ty@(CoercionTy {}) = pprPanic "check_type" (ppr ty) ---------------------------------------- check_syn_tc_app :: ValidityEnv @@ -873,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) {- @@ -924,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 @@ -985,21 +985,48 @@ checkConstraintsOK ve theta ty | null theta = return () | allConstraintsAllowed (ve_ctxt ve) = return () - | otherwise - = -- We are in a kind, where we allow only equality predicates - -- See Note [Constraints in kinds] in GHC.Core.TyCo.Rep, and #16263 - checkTcM (all isEqPred theta) (env, TcRnConstraintInKind (tidyType env ty)) + | otherwise -- We are unambiguously in a kind; see + -- Note [No constraints in kinds] + = failWithTcM (env, TcRnConstraintInKind (tidyType env ty)) where env = ve_tidy_env ve 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 +in kinds were allowed from GHC 8.0, but this "feature" was removed +as part of Proposal #547 (https://github.com/ghc-proposals/ghc-proposals/pull/547), +which contains further context and motivation for the removal. + +The lack of constraints in kinds is enforced by checkConstraintsOK, which +uses the UserTypeCtxt to determine if we are unambiguously checking a kind. +There are two ambiguous contexts (constructor BothTypeAndKindCtxt of TypeOrKindCtxt) +as written in typeOfKindCtxt: + - TySynCtxt: this is the RHS of a type synonym. We check the expansion of type + synonyms for constraints, so this is handled at the usage site of the synonym. + - GhciCtxt: This is the type in a :kind command. A constraint here does not cause + any trouble, because the type cannot be used to classify a type. + +Beyond these two cases, we also promote data constructors. We check for constraints +in data constructor types in GHC.Tc.Gen.HsType.tcTyVar. + Note [Liberal type synonyms] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ If -XLiberalTypeSynonyms is on, expand closed type synonyms *before* @@ -1054,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} @@ -1077,7 +1180,7 @@ -- Assumes argument is fully zonked checkValidTheta ctxt theta = addErrCtxtM (checkThetaCtxt ctxt theta) $ - do { env <- tcInitOpenTidyEnv (tyCoVarsOfTypesList theta) + do { env <- liftZonkM $ tcInitOpenTidyEnv (tyCoVarsOfTypesList theta) ; expand <- initialExpandMode ; check_valid_theta env ctxt expand theta } @@ -1166,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 @@ -1210,7 +1313,7 @@ check_class_pred :: TidyEnv -> DynFlags -> UserTypeCtxt -> PredType -> Class -> [TcType] -> TcM () check_class_pred env dflags ctxt pred cls tys - | isEqPredClass cls -- (~) and (~~) are classified as classes, + | isEqualityClass cls -- (~) and (~~) and Coercible are classified as classes, -- but here we want to treat them as equalities = -- Equational constraints are valid in all contexts, and -- we do not need to check e.g. for FlexibleContexts here, so just do nothing @@ -1257,33 +1360,21 @@ -- (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 } - -> let dia = mkTcRnUnknownMessage $ - mkPlainDiagnostic (WarningWithFlag Opt_WarnSimplifiableClassConstraints) - noHints - (simplifiable_constraint_warn what) - in addDiagnosticTc dia - _ -> return () } + -> addDiagnosticTc (TcRnSimplifiableConstraint pred what) + _ -> return () } where - pred = mkClassPred cls tys - - simplifiable_constraint_warn :: InstanceWhat -> SDoc - simplifiable_constraint_warn what - = vcat [ hang (text "The constraint" <+> quotes (ppr (tidyType env 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") ] + pred = tidyType env (mkClassPred cls tys) {- Note [Simplifiable given constraints] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ A type signature like f :: Eq [(a,b)] => a -> b -is very fragile, for reasons described at length in GHC.Tc.Solver.Interact +is very fragile, for reasons described at length in GHC.Tc.Solver.Dict Note [Instance and Given overlap]. As that Note discusses, for the -most part the clever stuff in GHC.Tc.Solver.Interact means that we don't use a +most part the clever stuff in GHC.Tc.Solver.Dict means that we don't use a top-level instance if a local Given might fire, so there is no fragility. But if we /infer/ the type of a local let-binding, things can go wrong (#11948 is an example, discussed in the Note). @@ -1295,7 +1386,7 @@ The warning only fires if the constraint in the signature matches the top-level instances in only one way, and with no unifiers -- that is, under the same circumstances that -GHC.Tc.Solver.Interact.matchInstEnv fires an interaction with the top +GHC.Tc.Instance.Class.matchInstEnv fires an interaction with the top level instances. For example (#13526), consider instance {-# OVERLAPPABLE #-} Eq (T a) where ... @@ -1335,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 @@ -1364,11 +1455,9 @@ generalized actually. -} -checkThetaCtxt :: UserTypeCtxt -> ThetaType -> TidyEnv -> TcM (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 @@ -1376,8 +1465,7 @@ -- ignoring the /invisible/ arguments, which the user does not see. -- (e.g. #10516) tyConArityErr tc tks - = arityErr (ppr (tyConFlavour tc)) (tyConName tc) - tc_type_arity tc_type_args + = TcRnArityMismatch (ATyCon tc) tc_type_arity tc_type_args where vis_tks = filterOutInvisibleTypes tc tks @@ -1386,17 +1474,6 @@ tc_type_arity = count isVisibleTyConBinder (tyConBinders tc) tc_type_args = length vis_tks -arityErr :: Outputable a => SDoc -> a -> Int -> Int -> TcRnMessage -arityErr what name n m - = mkTcRnUnknownMessage $ mkPlainError noHints $ - hsep [ text "The" <+> what, quotes (ppr name), text "should have", - n_arguments <> comma, text "but has been given", - if m==0 then text "none" else int m] - where - n_arguments | n == 0 = text "no arguments" - | n == 1 = text "1 argument" - | True = hsep [int n, text "arguments"] - {- ************************************************************************ * * @@ -1417,9 +1494,8 @@ checkValidInstHead :: UserTypeCtxt -> Class -> [Type] -> TcM () checkValidInstHead ctxt clas cls_args = do { dflags <- getDynFlags - ; is_boot <- tcIsHsBootOrSig - ; is_sig <- tcIsHsig - ; check_special_inst_head dflags is_boot is_sig ctxt clas cls_args + ; hsc_src <- tcHscSource + ; check_special_inst_head dflags hsc_src ctxt clas cls_args ; checkValidTypePats (classTyCon clas) cls_args } @@ -1449,16 +1525,17 @@ -} -check_special_inst_head :: DynFlags -> Bool -> Bool - -> UserTypeCtxt -> Class -> [Type] -> TcM () +check_special_inst_head :: DynFlags -> HscSource -> UserTypeCtxt + -> Class -> [Type] -> TcM () -- Wow! There are a surprising number of ad-hoc special cases here. -- TODO: common up the logic for special typeclasses (see GHC ticket #20441). -check_special_inst_head dflags is_boot is_sig ctxt clas cls_args +check_special_inst_head dflags hs_src ctxt clas cls_args - -- If not in an hs-boot file, abstract classes cannot have instances + -- Abstract classes cannot have instances, except in hs-boot or signature files. | isAbstractClass clas - , not is_boot - = failWithTc (TcRnAbstractClassInst clas) + , hs_src == HsSrcFile + = fail_with_inst_err $ IllegalInstanceHead + $ InstHeadAbstractClass (noUserRdr $ className clas) -- Complain about hand-written instances of built-in classes -- Typeable, KnownNat, KnownSymbol, Coercible, HasField. @@ -1467,31 +1544,36 @@ -- allow a standalone deriving declaration: they are no-ops, -- and we warn about them in GHC.Tc.Deriv.deriveStandalone. | clas_nm == typeableClassName - , not is_sig + , not (hs_src == HsigFile) -- Note [Instances of built-in classes in signature files] , hand_written_bindings - = failWithTc $ TcRnSpecialClassInst clas False + = fail_with_inst_err $ IllegalSpecialClassInstance clas False -- 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 ] - , (not is_sig && hand_written_bindings) || derived_instance + -- 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] - = failWithTc $ TcRnSpecialClassInst clas False + = fail_with_inst_err $ IllegalSpecialClassInstance clas False -- For the most part we don't allow -- instances for (~), (~~), or Coercible; -- but we DO want to allow them in quantified constraints: -- f :: (forall a b. Coercible a b => Coercible (m a) (m b)) => ...m... - | clas_nm `elem` [ heqTyConName, eqTyConName, coercibleTyConName, withDictClassName ] + | clas_nm `elem` + [ heqTyConName, eqTyConName, coercibleTyConName + , withDictClassName, unsatisfiableClassName ] , not quantified_constraint - = failWithTc $ TcRnSpecialClassInst clas False + = fail_with_inst_err $ IllegalSpecialClassInstance clas False -- Check for hand-written Generic instances (disallowed in Safe Haskell) | clas_nm `elem` genericClassNames , hand_written_bindings - = do { failIfTc (safeLanguageOn dflags) (TcRnSpecialClassInst clas True) + = do { when (safeLanguageOn dflags) $ + fail_with_inst_err $ IllegalSpecialClassInstance clas True ; when (safeInferOn dflags) (recordUnsafeInfer emptyMessages) } | clas_nm == hasFieldClassName @@ -1502,16 +1584,27 @@ = 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 - , Just msg <- mb_ty_args_msg - = failWithTc (instTypeErr clas cls_args msg) + , Just illegal_head <- mb_ty_args_type + = fail_with_inst_err $ IllegalInstanceHead illegal_head | otherwise = pure () where + + fail_with_inst_err err = + failWithTc $ TcRnIllegalInstance + $ IllegalClassInstance + (TypeThing $ mkClassPred clas cls_args) + $ err + clas_nm = getName clas ty_args = filterOutInvisibleTypes (classTyCon clas) cls_args @@ -1545,34 +1638,19 @@ SigmaCtxt -> True _ -> False - head_type_synonym_msg = parens ( - text "All instance types must be of the form (T t1 ... tn)" $$ - text "where T is not a synonym." $$ - text "Use TypeSynonymInstances if you want to disable this.") - - head_type_args_tyvars_msg = parens (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.", - text "Use FlexibleInstances if you want to disable this."]) - - head_one_type_msg = parens $ - text "Only one type can be given in an instance head." $$ - text "Use MultiParamTypeClasses if you want to allow more, or zero." - - mb_ty_args_msg + mb_ty_args_type | not (xopt LangExt.TypeSynonymInstances dflags) , not (all tcInstHeadTyNotSynonym ty_args) - = Just head_type_synonym_msg + = Just InstHeadTySynArgs | not (xopt LangExt.FlexibleInstances dflags) , not (all tcInstHeadTyAppAllTyVars ty_args) - = Just head_type_args_tyvars_msg + = Just InstHeadNonTyVarArgs | length ty_args /= 1 , not (xopt LangExt.MultiParamTypeClasses dflags) , not (xopt LangExt.NullaryTypeClasses dflags && null ty_args) - = Just head_one_type_msg + = Just InstHeadMultiParam | otherwise = Nothing @@ -1629,32 +1707,38 @@ dropCastsB :: TyVarBinder -> TyVarBinder dropCastsB b = b -- Don't bother in the kind of a forall -instTypeErr :: Class -> [Type] -> SDoc -> TcRnMessage -instTypeErr cls tys msg - = mkTcRnUnknownMessage $ mkPlainError noHints $ - hang (hang (text "Illegal instance declaration for") - 2 (quotes (pprClassPred cls tys))) - 2 msg - -- | See Note [Validity checking of HasField instances] checkHasFieldInst :: Class -> [Type] -> TcM () -checkHasFieldInst cls tys@[_k_ty, x_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 -> whoops (text "Record data type must be specified") + Nothing -> add_err IllegalHasFieldInstanceNotATyCon Just (tc, _) | isFamilyTyCon tc - -> whoops (text "Record data type may not be a data family") - | otherwise -> case isStrLitTy x_ty of + -> add_err IllegalHasFieldInstanceFamilyTyCon + | otherwise -> case isStrLitTy lbl_ty of Just lbl - | isJust (lookupTyConFieldLabel (FieldLabelString lbl) tc) - -> whoops (ppr tc <+> text "already has a field" - <+> quotes (ppr lbl)) - | otherwise -> return () + | let lbl_str = FieldLabelString lbl + , isJust (lookupTyConFieldLabel lbl_str tc) + -> add_err $ IllegalHasFieldInstanceTyConHasField tc lbl_str + | otherwise + -> return () Nothing - | null (tyConFieldLabels tc) -> return () - | otherwise -> whoops (ppr tc <+> text "has fields") + -- If the label is not a literal, we need to ensure it can't unify + -- with any of the field labels of the TyCon. + | null (tyConFieldLabels tc) + -- No field labels at all: nothing to check. + || typesAreApart (typeKind lbl_ty) typeSymbolKind + -- If the label has a type whose kind can't unify with Symbol, + -- then it definitely can't unify with any of the field labels. + -> return () + | otherwise + -> add_err $ IllegalHasFieldInstanceTyConHasFields tc lbl_ty where - whoops = addErrTc . instTypeErr cls tys + add_err err = addErrTc $ TcRnIllegalInstance + $ IllegalClassInstance + (TypeThing $ mkClassPred cls tys) + $ IllegalHasFieldInstance err + checkHasFieldInst _ tys = pprPanic "checkHasFieldInst" (ppr tys) {- Note [Casts during validity checking] @@ -1675,7 +1759,7 @@ Note [Validity checking of HasField instances] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The HasField class has magic constraint solving behaviour (see Note -[HasField instances] in GHC.Tc.Solver.Interact). However, we permit users to +[HasField instances] in GHC.Tc.Instance.Class). However, we permit users to declare their own instances, provided they do not clash with the built-in behaviour. In particular, we forbid: @@ -1694,35 +1778,166 @@ Note [Valid 'deriving' predicate] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -validDerivPred checks for OK 'deriving' context. -See Note [Exotic derived instance contexts] in GHC.Tc.Deriv.Infer. However the predicate is -here because it is quite similar to checkInstTermination. +In a 'derived' instance declaration, we *infer* the context. It's a bit unclear +what rules we should apply for this; the Haskell report is silent. Obviously, +constraints like `Eq a` are fine, but what about -It checks for two things: + data T f a = MkT (f a) deriving Eq -(VD1) The Paterson conditions; see Note [Paterson conditions] - Not on do we want to check for termination (of course), but it also - deals with a nasty corner case: - instance C a b => D (T a) where ... - Note that 'b' isn't a parameter of T. This gives rise to all sorts of - problems; in particular, it's hard to compare solutions for equality - when finding the fixpoint, and that means the inferContext loop does - not converge. See #5287, #21302 +where we'd get an `Eq (f a)` constraint. That's probably fine too. -(VD2) No type constructors; no foralls, no equalities: - see Note [Exotic derived instance contexts] in GHC.Tc.Deriv.Infer +On the other hand, we don't want to allow *every* inferred constraint, as there +are some particularly complex constraints that are tricky to handle. If GHC +encounters a constraint that is too complex, it will reject it, and you will +have to use StandaloneDeriving to manually specify the instance context that +you want. - We check the no-type-constructor bit using tyConsOfType. - Wrinkle: we look only at the /visible/ arguments of the class type - constructor. Including the non-visible arguments can cause the following, - perfectly valid instance to be rejected: - class Category (cat :: k -> k -> *) where ... - newtype T (c :: * -> * -> *) a b = MkT (c a b) - instance Category c => Category (T c) where ... - since the first argument to Category is a non-visible *, which has a - type constructor! See #11833. +There are two criteria for a constraint inferred by a `deriving` clause to be +considered valid, which are described below as (VD1) and (VD2). (Here, "VD" +stands for "valid deriving".) `validDerivPred` implements these checks. While +`validDerivPred` is similar to other things defined in GHC.Tc.Deriv.Infer, we +define it here in GHC.Tc.Validity because it is quite similar to +`checkInstTermination`. +----------------------------------- +-- (VD1) The Paterson conditions -- +----------------------------------- +Constraints must satisfy the Paterson conditions (see Note [Paterson +conditions]) to be valid. Not only does this check for termination (of course), +but it also deals with a nasty corner case: + + instance C a b => D (T a) where ... + +Note that `b` isn't a parameter of T. This gives rise to all sorts of +problems; in particular, it's hard to compare solutions for equality when +finding the fixpoint, and that means the +GHC.Tc.Deriv.Infer.simplifyInstanceContexts loop does not converge. +See #5287 and #21302. + +Another common situation in which a derived instance's context fails to meet +the Paterson conditions is when a constraint mentions a type variable more +often than the instance head, e.g., + + data Fix f = In (f (Fix f)) deriving Eq + +This would result in the following derived `Eq` instance: + + instance Eq (f (Fix f)) => Eq (Fix f) + +Because `f` is mentioned more often in the `Eq (f (Fix f))` constraint than in +the instance head `Eq (Fix f)`, GHC rejects this instance. + +This is a somewhat contentious restriction, and some have suggested that +instances like this one should be accepted if UndecidableInstances is enabled +(see #15868 for one such discussion). If we *do* lift this restriction in the +future, we should make sure to still meet the termination conditions. If not, +the deriving mechanism generates larger and larger constraints. Example: + + data Succ a = S a + data Seq a = Cons a (Seq (Succ a)) | Nil deriving Show + +Note the lack of a Show instance for Succ. First we'll generate: + + instance (Show (Succ a), Show a) => Show (Seq a) + +and then: + + instance (Show (Succ (Succ a)), Show (Succ a), Show a) => Show (Seq a) + +and so on. Instead we want to complain of no instance for (Show (Succ a)). + +--------------------------------- +-- (VD2) No exotic constraints -- +--------------------------------- + +A constraint must satisfy one of the following properties in order to be valid: + +* It is a `ClassPred` of the form `C a_1 ... a_n`, where C is a type class + constructor and a_1, ..., a_n are either raw type variables or applications + of type variables (e.g., `f a`). +* It is an `IrredPred` of the form `c a_1 ... a_n`, where `c` is a raw type + variable and a_1, ..., a_n are either raw type variables or applications of + type variables (e.g., `f a`). + +If a constraint does not meet either of these properties, it is considered +*exotic*. A constraint will be exotic if it contains: + +* Other type constructors (besides the class in a `ClassPred`), +* Foralls, or +* Equalities + +A common form of exotic constraint is one that mentions another type +constructor. For example, given the following: + + data NotAShowInstance + data Foo = MkFoo Int NotAShowInstance deriving Show + +GHC would attempt to generate the following derived `Show` instance: + + instance (Show Int, Show NotAShowInstance) => Show Foo + +Note that because there is a top-level `Show Int` instance, GHC is able to +simplify away the inferred `Show Int` constraint. However, it cannot do the +same for the `Show NotAShowInstance` constraint. One possibility would be to +generate this instance: + + instance Show NotAShowInstance => Show Foo + +But this is almost surely not what we want most of the time. For this reason, +we reject the constraint above as being exotic. + +Here are some other interesting examples: + +* Derived instances whose instance context would mention TypeError, such as the + code from the deriving/should_fail/T14339 test case, are exotic. For example: + + newtype Foo = Foo Int + + class Bar a where + bar :: a + + instance (TypeError (Text "Boo")) => Bar Foo where + bar = undefined + + newtype Baz = Baz Foo + deriving Bar + + The `deriving Bar` clause would generate this instance: + + instance TypeError (Text "Boo") => Bar Baz + + The instance context is exotic, as `TypeError` is not a type constructor, and + `Text "Boo"` is not an application of type variables. As such, GHC rejects + it. This has the desirable side effect of causing the TypeError to fire in + the resulting error message. + +* The following `IrredPred`s are not exotic: + + instance c => C (T c a) + instance c a => C (T c a) + + This `IrredPred`, however, *is* exotic: + + instance c NotAShowInstance => C (T c) + + This is rejected for the same reasons that we do not permit a `ClassPred` + with a type constructor argument, such as the `Show NotAShowInstance` example + above. + +As part of implementing this check, GHC calls `tyConsOfType` on the arguments +of the constraint, ensuring that there are no other type constructors. +Wrinkle: for `ClassPred`s, we look only at the /visible/ arguments of the class +type constructor. Including the non-visible arguments can cause the following, +perfectly valid instance to be rejected: + + class Category (cat :: k -> k -> Type) where ... + newtype T (c :: Type -> Type -> Type) a b = MkT (c a b) + instance Category c => Category (T c) where ... + +since the first argument to `Category` is a non-visible `Type`, which has a type +constructor! See #11833. + Note [Equality class instances] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We can't have users writing instances for the equality classes. But we @@ -1734,23 +1949,17 @@ -- See Note [Valid 'deriving' predicate] validDerivPred head_size pred = case classifyPredType pred of - EqPred {} -> False -- Reject equality constraints - ForAllPred {} -> False -- Rejects quantified predicates + EqPred {} -> False -- Reject equality constraints (VD2) + ForAllPred {} -> False -- Rejects quantified predicates (VD2) - ClassPred cls tys -> check_size (pSizeClassPred cls tys) - && isEmptyUniqSet (tyConsOfTypes visible_tys) + ClassPred cls tys -> check_size (pSizeClassPred cls tys) -- (VD1) + && isEmptyUniqSet (tyConsOfTypes visible_tys) -- (VD2) where - visible_tys = filterOutInvisibleTypes (classTyCon cls) tys -- (VD2) + -- See the wrinkle about visible arguments in (VD2) + visible_tys = filterOutInvisibleTypes (classTyCon cls) tys - IrredPred {} -> check_size (pSizeType pred) - -- Very important that we do the "too many variable occurrences" - -- check here, via check_size. Example (test T21302): - -- instance c Eq a => Eq (BoxAssoc a) - -- data BAD = BAD (BoxAssoc Int) deriving( Eq ) - -- We don't want to accept an inferred predicate (c0 Eq Int) - -- from that `deriving(Eq)` clause, because the c0 is fresh, - -- so we'll think it's a "new" one, and loop in - -- GHC.Tc.Deriv.Infer.simplifyInstanceContexts + IrredPred {} -> check_size (pSizeType pred) -- (VD1) + && isEmptyUniqSet (tyConsOfType pred) -- (VD2) where check_size pred_size = isNothing (pred_size `ltPatersonSize` head_size) @@ -1834,15 +2043,15 @@ checkValidInstance :: UserTypeCtxt -> LHsSigType GhcRn -> Type -> TcM () checkValidInstance ctxt hs_type ty = case tau of -- See Note [Instances and constraint synonyms] - TyConApp tc inst_tys -> case tyConClass_maybe tc of - Nothing -> failWithTc (TcRnIllegalClassInst (tyConFlavour tc)) - Just clas -> do + TyConApp tc inst_tys + | Just clas <- tyConClass_maybe tc + -> do { setSrcSpanA head_loc $ checkValidInstHead ctxt clas inst_tys ; traceTc "checkValidInstance {" (ppr ty) - ; env0 <- tcInitTidyEnv + ; env0 <- liftZonkM $ tcInitTidyEnv ; expand <- initialExpandMode ; check_valid_theta env0 ctxt expand theta @@ -1863,17 +2072,26 @@ ; traceTc "cvi 2" (ppr ty) - ; case (checkInstCoverage undecidable_ok clas theta inst_tys) of - IsValid -> return () -- Check succeeded - NotValid msg -> addErrTc (instTypeErr clas inst_tys msg) - - ; traceTc "End checkValidInstance }" empty + ; case checkInstCoverage undecidable_ok clas theta inst_tys of + IsValid + -> return () -- Check succeeded + NotValid coverageInstErr + -> addErrTc $ mk_err + $ IllegalInstanceFailsCoverageCondition clas coverageInstErr - ; return () } - _ -> failWithTc (TcRnNoClassInstHead tau) + ; traceTc "End checkValidInstance }" empty } + | otherwise + -> failWithTc $ mk_err $ IllegalInstanceHead + $ InstHeadNonClassHead + $ InstNonClassTyCon (noUserRdr $ tyConName tc) (fmap tyConName $ tyConFlavour tc) + _ -> failWithTc $ mk_err $ IllegalInstanceHead + $ InstHeadNonClassHead InstNonTyCon where (theta, tau) = splitInstTyForValidity ty + mk_err err = TcRnIllegalInstance + $ IllegalClassInstance (TypeThing tau) err + -- The location of the "head" of the instance head_loc = getLoc (getLHsInstDeclHead hs_type) @@ -1934,40 +2152,9 @@ where check2 pred_size = case pred_size `ltPatersonSize` head_size of - Just ps_failure -> failWithTc $ mkInstSizeError ps_failure head_pred pred + Just pc_failure -> failWithTc $ TcRnPatersonCondFailure pc_failure InInstanceDecl pred head_pred Nothing -> return () - -mkInstSizeError :: PatersonSizeFailure -> TcPredType -> TcPredType -> TcRnMessage -mkInstSizeError ps_failure head_pred pred - = mkTcRnUnknownMessage $ mkPlainError noHints $ - vcat [ main_msg - , parens undecidableMsg ] - where - pp_head = text "instance head" <+> quotes (ppr head_pred) - pp_pred = text "constraint" <+> quotes (ppr pred) - - main_msg = case ps_failure of - PSF_TyFam tc -> -- See (PC3) of Note [Paterson conditions] - hang (text "Illegal use of type family" <+> quotes (ppr tc)) - 2 (text "in the" <+> pp_pred) - PSF_TyVar tvs -> hang (occMsg tvs) - 2 (sep [ text "in the" <+> pp_pred - , text "than in the" <+> pp_head ]) - PSF_Size -> hang (text "The" <+> pp_pred) - 2 (sep [ text "is no smaller than", text "the" <+> pp_head ]) - -occMsg :: [TyVar] -> SDoc -occMsg tvs = text "Variable" <> plural tvs <+> quotes (pprWithCommas ppr tvs) - <+> pp_occurs <+> text "more often" - where - pp_occurs | isSingleton tvs = text "occurs" - | otherwise = text "occur" - -undecidableMsg :: SDoc -undecidableMsg = text "Use UndecidableInstances to permit this" - - {- Note [Instances and constraint synonyms] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Currently, we don't allow instances for constraint synonyms at all. @@ -2022,8 +2209,7 @@ -- (b) failure of injectivity check_branch_compat prev_branches cur_branch | cur_branch `isDominatedBy` prev_branches - = do { let dia = mkTcRnUnknownMessage $ - mkPlainDiagnostic WarningWithoutFlag noHints (inaccessibleCoAxBranch fam_tc cur_branch) + = do { let dia = TcRnInaccessibleCoAxBranch fam_tc cur_branch ; addDiagnosticAt (coAxBranchSpan cur_branch) dia ; return prev_branches } | otherwise @@ -2064,28 +2250,32 @@ -- Check that a "type instance" is well-formed (which includes decidability -- unless -XUndecidableInstances is given). -- +-- See also the separate 'checkFamPatBinders' which performs scoping checks +-- on a type family equation. +-- (It's separate because it expects 'TyFamEqnValidityInfo', which comes from a +-- separate place e.g. for associated type defaults.) checkValidCoAxBranch :: TyCon -> CoAxBranch -> TcM () checkValidCoAxBranch fam_tc - (CoAxBranch { cab_tvs = tvs, cab_cvs = cvs - , cab_lhs = typats + (CoAxBranch { cab_lhs = typats , cab_rhs = rhs, cab_loc = loc }) = setSrcSpan loc $ - checkValidTyFamEqn fam_tc (tvs++cvs) typats rhs + checkValidTyFamEqn fam_tc typats rhs -- | Do validity checks on a type family equation, including consistency -- with any enclosing class instance head, termination, and lack of -- polytypes. -checkValidTyFamEqn :: TyCon -- ^ of the type family - -> [Var] -- ^ Bound variables in the equation - -> [Type] -- ^ Type patterns - -> Type -- ^ Rhs +-- +-- See also the separate 'checkFamPatBinders' which performs scoping checks +-- on a type family equation. +-- (It's separate because it expects 'TyFamEqnValidityInfo', which comes from a +-- separate place e.g. for associated type defaults.) +checkValidTyFamEqn :: TyCon -- ^ of the type family + -> [Type] -- ^ Type patterns + -> Type -- ^ Rhs -> TcM () -checkValidTyFamEqn fam_tc qvs typats rhs +checkValidTyFamEqn fam_tc typats rhs = do { checkValidTypePats fam_tc typats - -- Check for things used on the right but not bound on the left - ; checkFamPatBinders fam_tc qvs typats rhs - -- Check for oversaturated visible kind arguments in a type family -- equation. -- See Note [Oversaturated type family equations] @@ -2139,10 +2329,11 @@ extract_tv pat pat_vis = case getTyVar_maybe pat of Just tv -> pure tv - Nothing -> failWithTc $ mkTcRnUnknownMessage $ mkPlainError noHints $ - pprWithExplicitKindsWhen (isInvisibleForAllTyFlag pat_vis) $ - hang (text "Illegal argument" <+> quotes (ppr pat) <+> text "in:") - 2 (vcat [ppr_eqn, suggestion]) + Nothing -> failWithTc $ TcRnIllegalInstance + $ IllegalFamilyInstance + $ InvalidAssoc $ InvalidAssocDefault + $ AssocDefaultBadArgs fam_tc pats + $ AssocDefaultNonTyVarArg (pat, pat_vis) -- Checks that no type variables in an associated default declaration are -- duplicated. If that is the case, throw an error. @@ -2156,23 +2347,13 @@ check_all_distinct_tvs cpt_tvs_vis = let dups = findDupsEq ((==) `on` fst) cpt_tvs_vis in traverse_ - (\d -> let (pat_tv, pat_vis) = NE.head d in failWithTc $ - mkTcRnUnknownMessage $ mkPlainError noHints $ - pprWithExplicitKindsWhen (isInvisibleForAllTyFlag pat_vis) $ - hang (text "Illegal duplicate variable" - <+> quotes (ppr pat_tv) <+> text "in:") - 2 (vcat [ppr_eqn, suggestion])) + (\d -> failWithTc $ TcRnIllegalInstance + $ IllegalFamilyInstance + $ InvalidAssoc $ InvalidAssocDefault + $ AssocDefaultBadArgs fam_tc pats + $ AssocDefaultDuplicateTyVars d) dups - ppr_eqn :: SDoc - ppr_eqn = - quotes (text "type" <+> ppr (mkTyConApp fam_tc pats) - <+> equals <+> text "...") - - suggestion :: SDoc - suggestion = text "The arguments to" <+> quotes (ppr fam_tc) - <+> text "must all be distinct type variables" - checkFamInstRhs :: TyCon -> [Type] -- LHS -> [(TyCon, [Type])] -- type family calls in RHS -> [TcRnMessage] @@ -2190,44 +2371,53 @@ lhs_size = pSizeTypes lhs_tys check (tc, tys) | not (isStuckTypeFamily tc) -- (TF1) - , Just ps_failure <- pSizeTypes tys `ltPatersonSize` lhs_size -- (TF2) - = Just $ mkFamSizeError ps_failure (TyConApp lhs_tc lhs_tys) (TyConApp tc tys) + , Just pc_failure <- pSizeTypes tys `ltPatersonSize` lhs_size -- (TF2) + = Just $ TcRnPatersonCondFailure pc_failure InTyFamEquation (TyConApp lhs_tc lhs_tys) (TyConApp tc tys) | otherwise = Nothing -mkFamSizeError :: PatersonSizeFailure -> Type -> Type -> TcRnMessage -mkFamSizeError ps_failure lhs fam_call - = mkTcRnUnknownMessage $ mkPlainError noHints $ - vcat [ main_msg - , parens undecidableMsg ] - where - pp_lhs = text "LHS of the family instance" <+> quotes (ppr lhs) - pp_call = text "type-family application" <+> quotes (ppr fam_call) +----------------- - main_msg = case ps_failure of - PSF_TyFam tc -> -- See (PC3) of Note [Paterson conditions] - hang (text "Illegal nested use of type family" <+> quotes (ppr tc)) - 2 (text "in the arguments of the" <+> pp_call) - PSF_TyVar tvs -> hang (occMsg tvs) - 2 (sep [ text "in the" <+> pp_call - , text "than in the" <+> pp_lhs ]) - PSF_Size -> hang (text "The" <+> pp_call) - 2 (sep [ text "is no smaller than", text "the" <+> pp_lhs ]) +-- | Perform scoping check on a type family equation. +-- +-- See 'TyFamEqnValidityInfo'. +checkTyFamEqnValidityInfo :: TyCon -> TyFamEqnValidityInfo -> TcM () +checkTyFamEqnValidityInfo fam_tc = \ case + NoVI -> return () + VI { vi_loc = loc + , vi_qtvs = qtvs + , vi_non_user_tvs = non_user_tvs + , vi_pats = pats + , vi_rhs = rhs } -> + setSrcSpan loc $ + checkFamPatBinders fam_tc qtvs non_user_tvs pats rhs ------------------ +-- | Check binders for a type or data family declaration. +-- +-- Specifically, this function checks for: +-- +-- - type variables used on the RHS but not bound (explicitly or implicitly) +-- in the LHS, +-- - variables bound by a forall in the LHS but not used in the RHS. +-- +-- See Note [Check type family instance binders]. checkFamPatBinders :: TyCon - -> [TcTyVar] -- Bound on LHS of family instance - -> [TcType] -- LHS patterns - -> Type -- RHS + -> [TcTyVar] -- ^ Bound on LHS of family instance + -> TyVarSet -- ^ non-user-written tyvars + -> [TcType] -- ^ LHS patterns + -> TcType -- ^ RHS -> TcM () -checkFamPatBinders fam_tc qtvs pats rhs +checkFamPatBinders fam_tc qtvs non_user_tvs pats rhs = do { traceTc "checkFamPatBinders" $ vcat [ debugPprType (mkTyConApp fam_tc pats) , ppr (mkTyConApp fam_tc pats) + , text "rhs:" <+> ppr rhs , text "qtvs:" <+> ppr qtvs - , text "rhs_tvs:" <+> ppr (fvVarSet rhs_fvs) + , text "rhs_fvs:" <+> ppr (fvVarSet rhs_fvs) , text "cpt_tvs:" <+> ppr cpt_tvs - , text "inj_cpt_tvs:" <+> ppr inj_cpt_tvs ] + , text "inj_cpt_tvs:" <+> ppr inj_cpt_tvs + , text "bad_rhs_tvs:" <+> ppr bad_rhs_tvs + , text "bad_qtvs:" <+> ppr (map ifiqtv bad_qtvs) ] -- Check for implicitly-bound tyvars, mentioned on the -- RHS but not bound on the LHS @@ -2235,18 +2425,19 @@ -- data family D Int = MkD (forall (a::k). blah) -- In both cases, 'k' is not bound on the LHS, but is used on the RHS -- We catch the former in kcDeclHeader, and the latter right here - -- See Note [Check type-family instance binders] - ; check_tvs bad_rhs_tvs (text "mentioned in the RHS") - (text "bound on the LHS of") + -- See Note [Check type family instance binders] + ; check_tvs (FamInstRHSOutOfScopeTyVars (Just (fam_tc, pats, dodgy_tvs))) + (map tyVarName bad_rhs_tvs) -- Check for explicitly forall'd variable that is not bound on LHS -- data instance forall a. T Int = MkT Int -- See Note [Unused explicitly bound variables in a family pattern] - -- See Note [Check type-family instance binders] - ; check_tvs bad_qtvs (text "bound by a forall") - (text "used in") + -- See Note [Check type family instance binders] + ; check_tvs FamInstLHSUnusedBoundTyVars bad_qtvs } where + rhs_fvs = tyCoFVsOfType rhs + cpt_tvs = tyCoVarsOfTypes pats inj_cpt_tvs = fvVarSet $ injectiveVarsOfTypes False pats -- The type variables that are in injective positions. @@ -2257,29 +2448,42 @@ -- NB: It's OK to use the nondeterministic `fvVarSet` function here, -- since the order of `inj_cpt_tvs` is never revealed in an error -- message. - rhs_fvs = tyCoFVsOfType rhs - used_tvs = cpt_tvs `unionVarSet` fvVarSet rhs_fvs - bad_qtvs = filterOut (`elemVarSet` used_tvs) qtvs - -- Bound but not used at all - bad_rhs_tvs = filterOut (`elemVarSet` inj_cpt_tvs) (fvVarList rhs_fvs) - -- Used on RHS but not bound on LHS - dodgy_tvs = cpt_tvs `minusVarSet` inj_cpt_tvs - check_tvs tvs what what2 - = unless (null tvs) $ addErrAt (getSrcSpan (head tvs)) $ mkTcRnUnknownMessage $ mkPlainError noHints $ - hang (text "Type variable" <> plural tvs <+> pprQuotedList tvs - <+> isOrAre tvs <+> what <> comma) - 2 (vcat [ text "but not" <+> what2 <+> text "the family instance" - , mk_extra tvs ]) + -- Bound but not used at all + bad_qtvs = mapMaybe bad_qtv_maybe qtvs - -- mk_extra: #7536: give a decent error message for - -- type T a = Int - -- type instance F (T a) = a - mk_extra tvs = ppWhen (any (`elemVarSet` dodgy_tvs) tvs) $ - hang (text "The real LHS (expanding synonyms) is:") - 2 (pprTypeApp fam_tc (map expandTypeSynonyms pats)) + bad_qtv_maybe qtv + | not_bound_in_pats + = let reason + | dodgy + = InvalidFamInstQTvDodgy + | used_in_rhs + = InvalidFamInstQTvNotBoundInPats + | otherwise + = InvalidFamInstQTvNotUsedInRHS + in Just $ InvalidFamInstQTv + { ifiqtv = qtv + , ifiqtv_user_written = not $ qtv `elemVarSet` non_user_tvs + , ifiqtv_reason = reason + } + | otherwise + = Nothing + where + not_bound_in_pats = not $ qtv `elemVarSet` inj_cpt_tvs + dodgy = not_bound_in_pats && qtv `elemVarSet` cpt_tvs + used_in_rhs = qtv `elemVarSet` fvVarSet rhs_fvs + -- Used on RHS but not bound on LHS + bad_rhs_tvs = filterOut ((`elemVarSet` inj_cpt_tvs) <||> (`elem` qtvs)) (fvVarList rhs_fvs) + dodgy_tvs = cpt_tvs `minusVarSet` inj_cpt_tvs + + check_tvs mk_err tvs + = for_ (NE.nonEmpty tvs) $ \ ne_tvs@(tv0 :| _) -> + addErrAt (getSrcSpan tv0) $ + TcRnIllegalInstance $ IllegalFamilyInstance $ + mk_err ne_tvs + -- | Checks that a list of type patterns is valid in a matching (LHS) -- position of a class instances or type/data family instance. -- @@ -2297,26 +2501,13 @@ -- Ensure that no type family applications occur a type pattern ; case tcTyConAppTyFamInstsAndVis tc pat_ty_args of [] -> pure () - ((tf_is_invis_arg, tf_tc, tf_args):_) -> failWithTc $ mkTcRnUnknownMessage $ mkPlainError noHints $ - ty_fam_inst_illegal_err tf_is_invis_arg - (mkTyConApp tf_tc tf_args) } + ((tf_is_invis_arg, tf_tc, tf_args):_) -> + failWithTc $ TcRnIllegalInstance $ + IllegalFamilyApplicationInInstance inst_ty + tf_is_invis_arg tf_tc tf_args } where inst_ty = mkTyConApp tc pat_ty_args - ty_fam_inst_illegal_err :: Bool -> Type -> SDoc - ty_fam_inst_illegal_err invis_arg ty - = pprWithExplicitKindsWhen invis_arg $ - hang (text "Illegal type synonym family application" - <+> quotes (ppr ty) <+> text "in instance" <> colon) - 2 (ppr inst_ty) - --- Error messages - -inaccessibleCoAxBranch :: TyCon -> CoAxBranch -> SDoc -inaccessibleCoAxBranch fam_tc cur_branch - = text "Type family instance equation is overlapped:" $$ - nest 2 (pprCoAxBranchUser fam_tc cur_branch) - ------------------------- checkConsistentFamInst :: AssocInstInfo -> TyCon -- ^ Family tycon @@ -2340,8 +2531,10 @@ -- Check that the associated type indeed comes from this class -- See [Mismatched class methods and associated type families] -- in TcInstDecls. - ; checkTc (Just (classTyCon clas) == tyConAssoc_maybe fam_tc) - (TcRnBadAssociatedType (className clas) (tyConName fam_tc)) + ; checkTc (Just (classTyCon clas) == tyConAssoc_maybe fam_tc) $ + TcRnIllegalInstance $ IllegalFamilyInstance $ + InvalidAssoc $ InvalidAssocInstance $ + AssocNotInThisClass clas fam_tc ; check_match arg_triples } @@ -2356,29 +2549,12 @@ ax_arg_tys , Just cls_arg_ty <- [lookupVarEnv mini_env fam_tc_tv] ] - pp_wrong_at_arg vis - = pprWithExplicitKindsWhen (isInvisibleForAllTyFlag vis) $ - vcat [ text "Type indexes must match class instance head" - , text "Expected:" <+> pp_expected_ty - , text " Actual:" <+> pp_actual_ty ] - -- Fiddling around to arrange that wildcards unconditionally print as "_" -- We only need to print the LHS, not the RHS at all -- See Note [Printing conflicts with class header] (tidy_env1, _) = tidyVarBndrs emptyTidyEnv inst_tvs (tidy_env2, _) = tidyCoAxBndrsForUser tidy_env1 (ax_tvs \\ inst_tvs) - pp_expected_ty = pprIfaceTypeApp topPrec (toIfaceTyCon fam_tc) $ - toIfaceTcArgs fam_tc $ - [ case lookupVarEnv mini_env at_tv of - Just cls_arg_ty -> tidyType tidy_env2 cls_arg_ty - Nothing -> mk_wildcard at_tv - | at_tv <- tyConTyVars fam_tc ] - - pp_actual_ty = pprIfaceTypeApp topPrec (toIfaceTyCon fam_tc) $ - toIfaceTcArgs fam_tc $ - tidyTypes tidy_env2 ax_arg_tys - mk_wildcard at_tv = mkTyVarTy (mkTyVar tv_name (tyVarKind at_tv)) tv_name = mkInternalName (mkAlphaTyVarUnique 1) (mkTyVarOccFS (fsLit "_")) noSrcSpan @@ -2393,16 +2569,26 @@ , Just rl_subst1 <- tcMatchTyX_BM bind_me rl_subst ty2 ty1 = go lr_subst1 rl_subst1 triples | otherwise - = addErrTc (mkTcRnUnknownMessage $ mkPlainError noHints $ pp_wrong_at_arg vis) + = addErrTc $ TcRnIllegalInstance $ IllegalFamilyInstance + $ InvalidAssoc $ InvalidAssocInstance + $ AssocTyVarsDontMatch vis fam_tc exp_tys act_tys + -- Expected/actual family argument types (for error messages) + exp_tys = + [ case lookupVarEnv mini_env at_tv of + Just cls_arg_ty -> tidyType tidy_env2 cls_arg_ty + Nothing -> mk_wildcard at_tv + | at_tv <- tyConTyVars fam_tc ] + act_tys = tidyTypes tidy_env2 ax_arg_tys + -- 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 -{- Note [Check type-family instance binders] +{- Note [Check type family instance binders] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ In a type family instance, we require (of course), type variables used on the RHS are matched on the LHS. This is checked by @@ -2821,19 +3007,12 @@ checkTyConTelescope tc | bad_scope = -- See "Ill-scoped binders" in Note [Bad TyCon telescopes] - addErr $ mkTcRnUnknownMessage $ mkPlainError noHints $ - 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) ] + addErr $ TcRnBadTyConTelescope tc | otherwise = return () where tcbs = tyConBinders tc - tvs = binderVars tcbs - sorted_tvs = scopedSort tvs (_, bad_scope) = foldl add_one (emptyVarSet, False) tcbs @@ -2844,34 +3023,3 @@ where tv = binderVar tcb fkvs = tyCoVarsOfType (tyVarKind tv) - - inferred_tvs = [ binderVar tcb - | tcb <- tcbs, Inferred == tyConBinderForAllTyFlag tcb ] - specified_tvs = [ binderVar tcb - | tcb <- tcbs, Specified == tyConBinderForAllTyFlag tcb ] - - pp_inf = parens (text "namely:" <+> pprTyVars inferred_tvs) - pp_spec = parens (text "namely:" <+> pprTyVars specified_tvs) - - 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 - - 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]]) - diff --git a/GHC/Tc/Zonk/Env.hs b/GHC/Tc/Zonk/Env.hs new file mode 100644 --- /dev/null +++ b/GHC/Tc/Zonk/Env.hs @@ -0,0 +1,375 @@ +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE NoPolyKinds #-} + +-- | The 'ZonkEnv' zonking environment, and the 'ZonkT' and 'ZonkBndrT' +-- monad transformers, for the final zonking to type in "GHC.Tc.Zonk.Type". +-- +-- See Note [Module structure for zonking] in GHC.Tc.Zonk.Type. +module GHC.Tc.Zonk.Env + ( -- * The 'ZonkEnv' + ZonkEnv(..), getZonkEnv + , ZonkFlexi(..) + , initZonkEnv + + -- * The 'ZonkT' and 'ZonkBndrT' zonking monad transformers + , ZonkT(ZonkT,runZonkT), ZonkBndrT(..) + + -- ** Going between 'ZonkT' and 'ZonkBndrT' + , runZonkBndrT + , noBinders, don'tBind + + -- ** Modifying and extending the 'ZonkEnv' in 'ZonkBndrT' + , setZonkType + , extendZonkEnv + , extendIdZonkEnv, extendIdZonkEnvRec + , extendTyZonkEnv + + ) + where + +import GHC.Prelude + +import GHC.Core.TyCo.Rep ( Type ) +import GHC.Types.Var ( TyCoVar, Var, TyVar ) + +import GHC.Types.Var ( Id, isTyCoVar ) +import GHC.Types.Var.Env + +import GHC.Utils.Monad.Codensity +import GHC.Utils.Outputable + +import Control.Monad.Fix ( MonadFix(..) ) +import Control.Monad.IO.Class ( MonadIO(..) ) +import Control.Monad.Trans.Class ( MonadTrans(..) ) +import Data.Coerce ( coerce ) +import Data.IORef ( IORef, newIORef ) +import Data.List ( partition ) + +import GHC.Exts ( oneShot ) + +-------------------------------------------------------------------------------- + +-- | See Note [The ZonkEnv] +data ZonkEnv + = ZonkEnv { ze_flexi :: !ZonkFlexi + , ze_tv_env :: TyCoVarEnv TyCoVar + , ze_id_env :: IdEnv Id + , ze_meta_tv_env :: IORef (TyVarEnv Type) } + +-- | How should we handle unfilled unification variables in the zonker? +-- +-- See Note [Un-unified unification variables] +data ZonkFlexi + = 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 + +instance Outputable ZonkEnv where + ppr (ZonkEnv { ze_tv_env = tv_env + , ze_id_env = id_env }) + = text "ZE" <+> braces (vcat + [ text "ze_tv_env =" <+> ppr tv_env + , text "ze_id_env =" <+> ppr id_env ]) + +{- Note [The ZonkEnv] +~~~~~~~~~~~~~~~~~~~~~ +* ze_flexi :: ZonkFlexi says what to do with a + unification variable that is still un-unified. + See Note [Un-unified unification variables] + +* ze_tv_env :: TyCoVarEnv TyCoVar promotes sharing. At a binding site + of a tyvar or covar, we zonk the kind right away and add a mapping + to the env. This prevents re-zonking the kind at every + occurrence. But this is *just* an optimisation. + +* ze_id_env : IdEnv Id promotes sharing among Ids, by making all + occurrences of the Id point to a single zonked copy, built at the + binding site. + + Unlike ze_tv_env, it is knot-tied: see extendIdZonkEnvRec. + In a mutually recursive group + rec { f = ...g...; g = ...f... } + we want the occurrence of g to point to the one zonked Id for g, + and the same for f. + + Because it is knot-tied, we must be careful to consult it lazily. + +* ze_meta_tv_env: see Note [Sharing when zonking to Type] + + +Notes: + * We must be careful never to put coercion variables (which are Ids, + after all) in the knot-tied ze_id_env, because coercions can + appear in types, and we sometimes inspect a zonked type in + the GHC.Tc.Zonk.Type module. [Question: where, precisely?] + + * An obvious suggestion would be to have one VarEnv Var to + replace both ze_id_env and ze_tv_env, but that doesn't work + because of the knot-tying stuff mentioned above. + +Note [Un-unified unification variables] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +What should we do if we find a Flexi unification variable? +There are three possibilities: + +* DefaultFlexi: this is the common case, in situations like + length @alpha ([] @alpha) + It really doesn't matter what type we choose for alpha. But + we must choose a type! We can't leave mutable unification + variables floating around: after typecheck is complete, every + type variable occurrence must have a binding site. + + So we default it to 'Any' of the right kind. + + All this works for both type and kind variables (indeed + the two are the same thing). + +* SkolemiseFlexi: is a special case for the LHS of RULES. + See Note [Zonking the LHS of a RULE] + +* RuntimeUnkFlexi: is a special case for the GHCi debugger. + It's a way to have a variable that is not a mutable + unification variable, but doesn't have a binding site + either. + +* NoFlexi: See Note [Error on unconstrained meta-variables] + in GHC.Tc.Utils.TcMType. This mode will panic on unfilled + meta-variables. +-} + +-- | A reader monad over 'ZonkEnv', for zonking computations which +-- don't modify the 'ZonkEnv' (e.g. don't bind any variables). +-- +-- Use 'ZonkBndrT' when you need to modify the 'ZonkEnv' (e.g. to bind +-- a variable). +newtype ZonkT m a = ZonkT' { runZonkT :: ZonkEnv -> m a } + +{- Note [Instances for ZonkT] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Below, we derive the following instances by hand: + + newtype ZonkT m a = ZonkT { runZonkT :: ZonkEnv -> m a } + deriving (Functor, Applicative, Monad, MonadIO, MonadFix) + via ReaderT ZonkEnv m + deriving MonadTrans + via ReaderT ZonkEnv + +Why? Two reasons: + + 1. To use oneShot. See Note [The one-shot state monad trick] in GHC.Utils.Monad. + 2. To be strict in the ZonkEnv. This allows us to worker-wrapper functions, + passing them individual fields of the ZonkEnv instead of the whole record. + When this happens, we avoid allocating a ZonkEnv, which is a win. +-} + +-- See Note [The one-shot state monad trick] in GHC.Utils.Monad +{-# COMPLETE ZonkT #-} +pattern ZonkT :: forall m a. (ZonkEnv -> m a) -> ZonkT m a +pattern ZonkT m <- ZonkT' m + where + ZonkT m = ZonkT' (oneShot m) + +-- See Note [Instances for ZonkT] +instance Functor m => Functor (ZonkT m) where + fmap f (ZonkT g) = ZonkT $ \ !env -> fmap f (g env) + a <$ ZonkT g = ZonkT $ \ !env -> a <$ g env + {-# INLINE fmap #-} + {-# INLINE (<$) #-} + +-- See Note [Instances for ZonkT] +instance Applicative m => Applicative (ZonkT m) where + pure a = ZonkT (\ !_ -> pure a) + ZonkT f <*> ZonkT x = ZonkT (\ !env -> f env <*> x env ) + ZonkT m *> f = ZonkT (\ !env -> m env *> runZonkT f env) + {-# INLINE pure #-} + {-# INLINE (<*>) #-} + {-# INLINE (*>) #-} + +-- See Note [Instances for ZonkT] +instance Monad m => Monad (ZonkT m) where + ZonkT m >>= f = + ZonkT (\ !env -> do { r <- m env + ; runZonkT (f r) env }) + (>>) = (*>) + {-# INLINE (>>=) #-} + {-# INLINE (>>) #-} + +-- See Note [Instances for ZonkT] +instance MonadIO m => MonadIO (ZonkT m) where + liftIO f = ZonkT (\ !_ -> liftIO f) + {-# INLINE liftIO #-} + +-- See Note [Instances for ZonkT] +instance MonadTrans ZonkT where + lift ma = ZonkT $ \ !_ -> ma + {-# INLINE lift #-} + +-- See Note [Instances for ZonkT] +instance MonadFix m => MonadFix (ZonkT m) where + mfix f = ZonkT $ \ !r -> mfix $ oneShot $ \ a -> runZonkT (f a) r + {-# INLINE mfix #-} + +-- | Zonk binders, bringing them into scope in the inner computation. +-- +-- Can be thought of as a state monad transformer @StateT ZonkEnv m a@, +-- but written in continuation-passing style. +-- +-- See Note [Continuation-passing style for zonking]. +newtype ZonkBndrT m a = ZonkBndrT { runZonkBndrT' :: forall r. (a -> ZonkT m r) -> ZonkT m r } + deriving (Functor, Applicative, Monad, MonadIO, MonadFix) + via Codensity (ZonkT m) + -- See GHC.Utils.Monad.Codensity for the instance definitions. + -- See Note [Continuation-passing style for zonking] for why we use + -- continuation-passing style instead of a direct state monad. + +{- Note [Continuation-passing style for zonking] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +While zonking, we sometimes need to modify the ZonkEnv. For example, when +zonking a binder with zonkTyBndrX, we extend the type variable ZonkEnv. + +We could use direct state passing: + + zonkTyBndrX :: ZonkEnv -> TcTyVar -> TcM (ZonkEnv, TyVar) + zonkTyBndrX ze tv = + do { tv' <- ... ze tv + ; let ze' = extendTyZonkEnv ze tv' + ; return (ze', tv') } + +but we can avoid allocating pairs by using continuation-passing style instead, +for example: + + zonkTyBndrX :: (ZonkEnv -> TcTyVar -> TcM r) -> ZonkEnv -> TcM r + zonkTyBndrX k ze = + do { tv' <- ... ze tv + ; let ze' = extendTyZonkEnv ze tv + ; k ze' tv' } + +We thus define: + + newtype ZonkBndrT m a = + ZonkBndrT { runZonkBndrT :: forall r. (a -> ZonkT m r) -> ZonkT m r } + +which is the type of continuation-passing computations over ZonkT m = ReaderT ZonkEnv m. +We thus have: + + zonkTyBndrX :: TcTyVar -> ZonkBndrT TcM TyVar + +which expresses the fact that zonkTyBndrX takes in a TcTyVar, returns a TyVar, +modifying the ZonkEnv state in the process. We can build computations out of it +by using runZonkBndrT and nesting. For example, zonking a type synonym: + + zonkTySynRHS :: [TcTyConBinder] -> [TcTyVar] -> ZonkT TcM ([TyConBinder], [TyVar]) + zonkTySynRHS tc_bndrs rhs_tc_ty = + runZonkBndrT (zonkTyVarBindersX tc_bndrs) $ \ bndrs -> + do { rhs_ty <- zonkTcTypeToTypeX rhs_tc_ty + ; return (bndrs, rhs_ty) } + +This is known as the codensity transformation, where + + newtype Codensity m a = Codensity { forall r. (a -> m r) -> m r } + +expresses continuation-passing computations in the monad m. + +Codensity (ReaderT s m) naturally corresponds to StateT s (Codensity m), and +the instances for Codensity reflect that, e.g. + + traverse :: (a -> ZonkBndrT m b) -> t a -> ZonkBndrT m (t b) + +naturally behaves like mapAccumLM, accumulating changes to the ZonkEnv as +we go. +-} + +-- | Zonk some binders and run the continuation. +-- +-- Example: +-- +-- > zonk (ForAllTy (Bndr tv vis) body_ty) +-- > = runZonkBndrT (zonkTyBndrX tv) $ \ tv' -> +-- > do { body_ty' <- zonkTcTypeToTypeX body_ty +-- > ; return (ForAllTy (Bndr tv' vis) body_ty') } +-- +-- See Note [Continuation-passing style for zonking]. +runZonkBndrT :: ZonkBndrT m a -> forall r. (a -> ZonkT m r) -> ZonkT m r +runZonkBndrT (ZonkBndrT k) f = k (oneShot f) +{-# INLINE runZonkBndrT #-} + +-- | Embed a computation that doesn't modify the 'ZonkEnv' into 'ZonkBndrT'. +noBinders :: Monad m => ZonkT m a -> ZonkBndrT m a +noBinders z = coerce $ toCodensity z +{-# INLINE noBinders #-} + +-- | Run a nested computation that modifies the 'ZonkEnv', +-- without affecting the outer environment. +don'tBind :: Monad m => ZonkBndrT m a -> ZonkT m a +don'tBind (ZonkBndrT k) = fromCodensity (Codensity k) +{-# INLINE don'tBind #-} + +initZonkEnv :: MonadIO m => ZonkFlexi -> ZonkT m b -> m b +initZonkEnv flexi thing_inside + = do { mtv_env_ref <- liftIO $ newIORef emptyVarEnv + ; let ze = ZonkEnv { ze_flexi = flexi + , ze_tv_env = emptyVarEnv + , ze_id_env = emptyVarEnv + , ze_meta_tv_env = mtv_env_ref } + + ; runZonkT thing_inside ze } +{-# INLINEABLE initZonkEnv #-} -- so it can be specialised + +nestZonkEnv :: (ZonkEnv -> ZonkEnv) -> ZonkBndrT m () +nestZonkEnv f = ZonkBndrT $ \ k -> + case k () of + ZonkT g -> ZonkT (g . f) +{-# INLINE nestZonkEnv #-} + +getZonkEnv :: Monad m => ZonkT m ZonkEnv +getZonkEnv = ZonkT return +{-# INLINE getZonkEnv #-} + +-- | Extend the knot-tied environment. +extendIdZonkEnvRec :: [Var] -> ZonkBndrT m () +extendIdZonkEnvRec ids = + nestZonkEnv $ + \ ze@(ZonkEnv { ze_id_env = id_env }) -> + -- NB: Don't look at the var to decide which env't to put it in. That + -- would end up knot-tying all the env'ts. + ze { ze_id_env = extendVarEnvList id_env [(id,id) | id <- ids] } + -- Given coercion variables will actually end up here. That's OK though: + -- coercion variables are never looked up in the knot-tied env't, so zonking + -- them simply doesn't get optimised. No one gets hurt. An improvement (?) + -- would be to do SCC analysis in zonkEvBinds and then only knot-tie the + -- recursive groups. But perhaps the time it takes to do the analysis is + -- more than the savings. + +extendZonkEnv :: [Var] -> ZonkBndrT m () +extendZonkEnv vars = + nestZonkEnv $ + \ ze@(ZonkEnv { ze_tv_env = tyco_env, ze_id_env = id_env }) -> + ze { ze_tv_env = extendVarEnvList tyco_env [(tv,tv) | tv <- tycovars] + , ze_id_env = extendVarEnvList id_env [(id,id) | id <- ids] } + where + (tycovars, ids) = partition isTyCoVar vars + +extendIdZonkEnv :: Var -> ZonkBndrT m () +extendIdZonkEnv id = + nestZonkEnv $ + \ ze@(ZonkEnv { ze_id_env = id_env }) -> + ze { ze_id_env = extendVarEnv id_env id id } + +extendTyZonkEnv :: TyVar -> ZonkBndrT m () +extendTyZonkEnv tv = + nestZonkEnv $ + \ ze@(ZonkEnv { ze_tv_env = ty_env }) -> + ze { ze_tv_env = extendVarEnv ty_env tv tv } + +setZonkType :: ZonkFlexi -> ZonkT m a -> ZonkT m a +setZonkType flexi (ZonkT f) = ZonkT $ \ ze -> + f $ ze { ze_flexi = flexi } diff --git a/GHC/Tc/Zonk/Monad.hs b/GHC/Tc/Zonk/Monad.hs new file mode 100644 --- /dev/null +++ b/GHC/Tc/Zonk/Monad.hs @@ -0,0 +1,115 @@ +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE RankNTypes #-} + +-- | The 'ZonkM' monad, a stripped down 'TcM', used when zonking within +-- the typechecker in "GHC.Tc.Zonk.TcType". +-- +-- See Note [Module structure for zonking] in GHC.Tc.Zonk.Type. +module GHC.Tc.Zonk.Monad + ( -- * The 'ZonkM' monad, a stripped down 'TcM' for zonking + ZonkM(ZonkM,runZonkM) + , ZonkGblEnv(..), getZonkGblEnv, getZonkTcLevel + + -- ** Logging within 'ZonkM' + , traceZonk + + ) + where + +import GHC.Prelude + +import GHC.Driver.Flags ( DumpFlag(Opt_D_dump_tc_trace) ) + +import GHC.Types.SrcLoc ( SrcSpan ) + +import GHC.Tc.Types.BasicTypes ( TcBinderStack ) +import GHC.Tc.Utils.TcType ( TcLevel ) + +import GHC.Utils.Logger +import GHC.Utils.Outputable + +import Control.Monad ( when ) +import Control.Monad.IO.Class ( MonadIO(..) ) + +import GHC.Exts ( oneShot ) + +-------------------------------------------------------------------------------- + +-- | Information needed by the 'ZonkM' monad, which is a slimmed down version +-- of 'TcM' with just enough information for zonking. +data ZonkGblEnv + = ZonkGblEnv + { zge_logger :: Logger -- needed for traceZonk + , zge_name_ppr_ctx :: NamePprCtx -- '' + , zge_src_span :: SrcSpan -- needed for skolemiseUnboundMetaTyVar + , zge_tc_level :: TcLevel -- '' + , zge_binder_stack :: TcBinderStack -- needed for tcInitTidyEnv + } + +-- | A stripped down version of 'TcM' which is sufficient for zonking types. +newtype ZonkM a = ZonkM' { runZonkM :: ZonkGblEnv -> IO a } +{- +NB: we write the following instances by hand: + +-- deriving (Functor, Applicative, Monad, MonadIO) +-- via ReaderT ZonkGblEnv IO + +See Note [Instances for ZonkT] in GHC.Tc.Zonk.Env for the reasoning: + + - oneShot annotations, + - strictness annotations to enable worker-wrapper. +-} + +{-# COMPLETE ZonkM #-} +pattern ZonkM :: forall a. (ZonkGblEnv -> IO a) -> ZonkM a +pattern ZonkM m <- ZonkM' m + where + ZonkM m = ZonkM' (oneShot m) +-- See Note [The one-shot state monad trick] in GHC.Utils.Monad + +instance Functor ZonkM where + fmap f (ZonkM g) = ZonkM $ \ !env -> fmap f (g env) + a <$ ZonkM g = ZonkM $ \ !env -> a <$ g env + {-# INLINE fmap #-} + {-# INLINE (<$) #-} +instance Applicative ZonkM where + pure a = ZonkM (\ !_ -> pure a) + ZonkM f <*> ZonkM x = ZonkM (\ !env -> f env <*> x env ) + ZonkM m *> f = ZonkM (\ !env -> m env *> runZonkM f env) + {-# INLINE pure #-} + {-# INLINE (<*>) #-} + {-# INLINE (*>) #-} + +instance Monad ZonkM where + ZonkM m >>= f = + ZonkM (\ !env -> do { r <- m env + ; runZonkM (f r) env }) + (>>) = (*>) + {-# INLINE (>>=) #-} + {-# INLINE (>>) #-} + +instance MonadIO ZonkM where + liftIO f = ZonkM (\ !_ -> f) + {-# INLINE liftIO #-} + +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 () +traceZonk herald doc = ZonkM $ + \ ( ZonkGblEnv { zge_logger = !logger, zge_name_ppr_ctx = ppr_ctx }) -> + do { let sty = mkDumpStyle ppr_ctx + flag = Opt_D_dump_tc_trace + title = "" + msg = hang (text herald) 2 doc + ; when (logHasDumpFlag logger flag) $ + logDumpFile logger sty flag title FormatText msg + } +{-# INLINE traceZonk #-} + -- see Note [INLINE conditional tracing utilities] in GHC.Tc.Utils.Monad diff --git a/GHC/Tc/Zonk/TcType.hs b/GHC/Tc/Zonk/TcType.hs new file mode 100644 --- /dev/null +++ b/GHC/Tc/Zonk/TcType.hs @@ -0,0 +1,818 @@ +{-# LANGUAGE DuplicateRecordFields #-} + +{- +(c) The University of Glasgow 2006 +(c) The AQUA Project, Glasgow University, 1996-1998 +-} + +-- | Zonking types within the typechecker. +-- +-- Distinct from the final zonking pass in "GHC.Tc.Zonk.Type"; +-- see Note [Module structure for zonking] in GHC.Tc.Zonk.Type. +module GHC.Tc.Zonk.TcType + ( -- * Zonking (within the typechecker) + + -- ** The 'ZonkM' monad and 'ZonkGblEnv' + module GHC.Tc.Zonk.Monad + + -- ** Zonking types + , zonkTcType, zonkTcTypes, zonkScaledTcType + , zonkTcTyVar, zonkTcTyVars + , zonkTcTyVarToTcTyVar, zonkTcTyVarsToTcTyVars + , zonkInvisTVBinder + , zonkCo + + -- ** Zonking 'TyCon's + , zonkTcTyCon + + -- *** FreeVars + , zonkTcTypeAndFV, zonkTyCoVarsAndFV, zonkTyCoVarsAndFVList + , zonkDTyCoVarSetAndFV + + -- ** Zonking 'CoVar's and 'Id's + , zonkId, zonkCoVar, zonkTyCoVar, zonkTyCoVarKind, zonkTyCoVarBndrKind + + -- ** Zonking skolem info + , zonkSkolemInfo, zonkSkolemInfoAnon + + -- ** Zonking constraints + , zonkCt, zonkWC, zonkSimples, zonkImplication + + -- * Rewriter sets + , zonkRewriterSet, zonkCtRewriterSet, zonkCtEvRewriterSet + + -- * Coercion holes + , isFilledCoercionHole, unpackCoercionHole, unpackCoercionHole_maybe + + + -- * Tidying + , tcInitTidyEnv, tcInitOpenTidyEnv + , tidyCt, tidyEvVar, tidyDelayedError + + -- ** Zonk & tidy + , zonkTidyTcType, zonkTidyTcTypes + , zonkTidyOrigin, zonkTidyOrigins + , zonkTidyFRRInfos + + -- * Writing to metavariables + , writeMetaTyVar, writeMetaTyVarRef + + -- * Handling coercion holes + , checkCoercionHole + + ) + where + +import GHC.Prelude + +import GHC.Types.Name +import GHC.Types.Var +import GHC.Types.Var.Env +import GHC.Types.Var.Set +import GHC.Types.Unique.Set + +import GHC.Tc.Errors.Types +import GHC.Tc.Errors.Ppr +import GHC.Tc.Types.Constraint +import GHC.Tc.Types.Origin +import GHC.Tc.Types.TcRef +import GHC.Tc.Types.Evidence +import GHC.Tc.Types.BasicTypes +import GHC.Tc.Utils.TcType +import GHC.Tc.Zonk.Monad + +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 as Outputable +import GHC.Utils.Misc +import GHC.Utils.Monad ( mapAccumLM ) +import GHC.Utils.Panic + +import GHC.Data.Bag +import GHC.Data.Pair + +import Data.Semigroup +import Data.Maybe + +{- ********************************************************************* +* * + Writing to metavariables +* * +************************************************************************ +-} + +-- | Write into a currently-empty MetaTyVar. +-- +-- Works with both type and kind variables. +writeMetaTyVar :: HasDebugCallStack + => TcTyVar -- ^ the type varfiable to write to + -> TcType -- ^ the type to write into the mutable reference + -> ZonkM () +writeMetaTyVar tyvar ty + | not debugIsOn + = writeMetaTyVarRef tyvar (metaTyVarRef tyvar) ty + +-- Everything from here on only happens if DEBUG is on + | not (isTcTyVar tyvar) + = massertPpr False (text "Writing to non-tc tyvar" <+> ppr tyvar) + + | MetaTv { mtv_ref = ref } <- tcTyVarDetails tyvar + = writeMetaTyVarRef tyvar ref ty + + | otherwise + = massertPpr False (text "Writing to non-meta tyvar" <+> ppr tyvar) +{-# INLINE writeMetaTyVar #-} -- See NOTE [Inlining writeMetaTyVar] + +-- | Write into the 'MetaDetails' mutable references of a 'MetaTv'. +writeMetaTyVarRef :: HasDebugCallStack + => TcTyVar -- ^ for debug assertions only; + -> TcRef MetaDetails -- ^ ref cell must be for the same tyvar + -> TcType -- ^ the type to write to the mutable reference + -> ZonkM () +writeMetaTyVarRef tyvar ref ty + | not debugIsOn + = do { traceZonk "writeMetaTyVar" (ppr tyvar <+> dcolon <+> ppr (tyVarKind tyvar) + <+> text ":=" <+> ppr ty) + ; writeTcRef ref (Indirect ty) } + + -- Everything from here on only happens if DEBUG is on + -- Need to zonk 'ty' because we may only recently have promoted + -- its free meta-tyvars (see GHC.Tc.Utils.Unify.checkPromoteFreeVars) + | otherwise + = do { meta_details <- readTcRef ref; + -- Zonk kinds to allow the error check to work + ; zonked_tv_kind <- zonkTcType tv_kind + ; zonked_ty <- zonkTcType ty + ; let zonked_ty_kind = typeKind zonked_ty + zonked_ty_lvl = tcTypeLevel zonked_ty + level_check_ok = not (zonked_ty_lvl `strictlyDeeperThan` tv_lvl) + level_check_msg = ppr zonked_ty_lvl $$ ppr tv_lvl $$ ppr tyvar $$ ppr ty $$ ppr zonked_ty + kind_check_ok = zonked_ty_kind `eqType` zonked_tv_kind + -- Note [Extra-constraint holes in partial type signatures] in GHC.Tc.Gen.HsType + + kind_msg = hang (text "Ill-kinded update to meta tyvar") + 2 ( ppr tyvar <+> text "::" <+> (ppr tv_kind $$ ppr zonked_tv_kind) + <+> text ":=" + <+> ppr ty <+> text "::" <+> (ppr zonked_ty_kind) ) + + ; traceZonk "writeMetaTyVar" (ppr tyvar <+> text ":=" <+> ppr ty) + + -- Check for double updates + ; massertPpr (isFlexi meta_details) (double_upd_msg meta_details) + + -- Check for level OK + ; massertPpr level_check_ok level_check_msg + + -- Check Kinds ok + ; massertPpr kind_check_ok kind_msg + + -- Do the write + ; writeTcRef ref (Indirect ty) } + where + tv_kind = tyVarKind tyvar + + tv_lvl = tcTyVarLevel tyvar + + + double_upd_msg details = hang (text "Double update of meta tyvar") + 2 (ppr tyvar $$ ppr details) +{-# INLINE writeMetaTyVarRef #-} -- See NOTE [Inlining writeMetaTyVar] + +{- NOTE [Inlining writeMetaTyVar] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +writeMetaTyVar is defined in the ZonkM monad, but it is often used within +TcM with the following idiom: + + liftZonkM $ writeMetaTyVar tv ty + +Using liftZonkM within TcM generally means extracting out a ZonkGblEnv +from the TcM monad to pass to the inner ZonkM computation (see the definition +of liftZonkM). This can cause writeMetaTyVar to allocate a ZonkGblEnv, which we +would much rather avoid! +Instead, we should directly pass the bits of the ZonkGblEnv that writeMetaTyVar +needs (the Logger and NamePprCtxt, which are needed for the traceZonk call +in writeMetaTyVar). This is achieved by inlining writeMetaTyVar and writeMetaTyVarRef. +These functions just wrap writeTcRef, with some extra tracing +(and some assertions if running in debug mode), so it's fine to inline them. + +See for example test T5631, which regresses without this change. +-} + +{- +************************************************************************ +* * + Zonking -- the main work-horses: zonkTcType, zonkTcTyVar +* * +************************************************************************ +-} + +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 +zonkTcType :: TcType -> ZonkM TcType +zonkTcTypes :: [TcType] -> ZonkM [TcType] +zonkCo :: Coercion -> ZonkM Coercion +(zonkTcType, zonkTcTypes, zonkCo, _) + = mapTyCo zonkTcTypeMapper + where + -- 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 +-- A non-poly TcTyCon may have unification +-- variables that need zonking, but poly ones cannot +zonkTcTyCon tc + | isMonoTcTyCon tc = do { tck' <- zonkTcType (tyConKind tc) + ; return (setTcTyConKind tc tck') } + | otherwise = return tc + +zonkTcTyVar :: TcTyVar -> ZonkM TcType +-- Simply look through all Flexis +zonkTcTyVar tv + | isTcTyVar tv + = case tcTyVarDetails tv of + SkolemTv {} -> zonk_kind_and_return + RuntimeUnk {} -> zonk_kind_and_return + MetaTv { mtv_ref = ref } + -> do { cts <- readTcRef ref + ; case cts of + Flexi -> zonk_kind_and_return + Indirect ty -> do { zty <- zonkTcType ty + ; writeTcRef ref (Indirect zty) + -- See Note [Sharing in zonking] + ; return zty } } + + | otherwise -- coercion variable + = zonk_kind_and_return + where + zonk_kind_and_return = do { z_tv <- zonkTyCoVarKind tv + ; return (mkTyVarTy z_tv) } + +-- Variant that assumes that any result of zonking is still a TyVar. +-- Should be used only on skolems and TyVarTvs +zonkTcTyVarsToTcTyVars :: HasDebugCallStack => [TcTyVar] -> ZonkM [TcTyVar] +zonkTcTyVarsToTcTyVars = mapM zonkTcTyVarToTcTyVar + +zonkTcTyVarToTcTyVar :: HasDebugCallStack => TcTyVar -> ZonkM TcTyVar +zonkTcTyVarToTcTyVar tv + = do { ty <- zonkTcTyVar tv + ; let tv' = case getTyVar_maybe ty of + Just tv' -> tv' + Nothing -> pprPanic "zonkTcTyVarToTcTyVar" + (ppr tv $$ ppr ty) + ; return tv' } + +zonkInvisTVBinder :: VarBndr TcTyVar spec -> ZonkM (VarBndr TcTyVar spec) +zonkInvisTVBinder (Bndr tv spec) = do { tv' <- zonkTcTyVarToTcTyVar tv + ; return (Bndr tv' spec) } + +{- ********************************************************************* +* * + Zonking types +* * +********************************************************************* -} + +zonkTcTypeAndFV :: TcType -> ZonkM DTyCoVarSet +-- Zonk a type and take its free variables +-- With kind polymorphism it can be essential to zonk *first* +-- so that we find the right set of free variables. Eg +-- forall k1. forall (a:k2). a +-- where k2:=k1 is in the substitution. We don't want +-- k2 to look free in this type! +zonkTcTypeAndFV ty + = tyCoVarsOfTypeDSet <$> zonkTcType ty + +zonkTyCoVar :: TyCoVar -> ZonkM TcType +-- Works on TyVars and TcTyVars +zonkTyCoVar tv | isTcTyVar tv = zonkTcTyVar tv + | isTyVar tv = mkTyVarTy <$> zonkTyCoVarKind tv + | otherwise = assertPpr (isCoVar tv) (ppr tv) $ + mkCoercionTy . mkCoVarCo <$> zonkTyCoVarKind tv + -- Hackily, when typechecking type and class decls + -- we have TyVars in scope added (only) in + -- GHC.Tc.Gen.HsType.bindTyClTyVars, but it seems + -- painful to make them into TcTyVars there + +zonkTyCoVarsAndFV :: TyCoVarSet -> ZonkM TyCoVarSet +zonkTyCoVarsAndFV tycovars + = tyCoVarsOfTypes <$> mapM zonkTyCoVar (nonDetEltsUniqSet tycovars) + -- It's OK to use nonDetEltsUniqSet here because we immediately forget about + -- the ordering by turning it into a nondeterministic set and the order + -- of zonking doesn't matter for determinism. + +zonkDTyCoVarSetAndFV :: DTyCoVarSet -> ZonkM DTyCoVarSet +zonkDTyCoVarSetAndFV tycovars + = mkDVarSet <$> (zonkTyCoVarsAndFVList $ dVarSetElems tycovars) + +-- Takes a list of TyCoVars, zonks them and returns a +-- deterministically ordered list of their free variables. +zonkTyCoVarsAndFVList :: [TyCoVar] -> ZonkM [TyCoVar] +zonkTyCoVarsAndFVList tycovars + = tyCoVarsOfTypesList <$> mapM zonkTyCoVar tycovars + +zonkTcTyVars :: [TcTyVar] -> ZonkM [TcType] +zonkTcTyVars tyvars = mapM zonkTcTyVar tyvars + +----------------- Types +zonkTyCoVarKind :: TyCoVar -> ZonkM TyCoVar +zonkTyCoVarKind tv = do { kind' <- zonkTcType (tyVarKind tv) + ; return (setTyVarKind tv kind') } + +zonkTyCoVarBndrKind :: VarBndr TyCoVar flag -> ZonkM (VarBndr TyCoVar flag) +zonkTyCoVarBndrKind (Bndr tv flag) = + do { tv' <- zonkTyCoVarKind tv + ; return (Bndr tv' flag) } + +-- | zonkId is used *during* typechecking just to zonk the 'Id''s type +zonkId :: TcId -> ZonkM TcId +zonkId id = updateIdTypeAndMultM zonkTcType id + +zonkCoVar :: CoVar -> ZonkM CoVar +zonkCoVar = zonkId + +{- +************************************************************************ +* * + Coercion holes +* * +************************************************************************ +-} + +-- | 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 +checkCoercionHole cv co + | debugIsOn + = do { cv_ty <- zonkTcType (varType cv) + -- co is already zonked, but cv might not be + ; return $ + assertPpr (ok cv_ty) + (text "Bad coercion hole" <+> + ppr cv Outputable.<> colon + <+> vcat [ ppr t1, ppr t2, ppr role, ppr cv_ty ]) + co } + | otherwise + = return co + + where + (Pair t1 t2, role) = coercionKindRole co + ok cv_ty | EqPred cv_rel cv_t1 cv_t2 <- classifyPredType cv_ty + = t1 `eqType` cv_t1 + && t2 `eqType` cv_t2 + && role == eqRelRole cv_rel + | otherwise + = False + + +{- +************************************************************************ +* * + Zonking constraints +* * +************************************************************************ +-} + +zonkImplication :: Implication -> ZonkM Implication +zonkImplication implic@(Implic { ic_skols = skols + , ic_given = given + , ic_wanted = wanted + , ic_info = info }) + = do { skols' <- mapM zonkTyCoVarKind skols -- Need to zonk their kinds! + -- as #7230 showed + ; given' <- mapM zonkEvVar given + ; info' <- zonkSkolemInfoAnon info + ; wanted' <- zonkWCRec wanted + ; return (implic { ic_skols = skols' + , ic_given = given' + , ic_wanted = wanted' + , ic_info = info' }) } + +zonkEvVar :: EvVar -> ZonkM EvVar +zonkEvVar var = updateIdTypeAndMultM zonkTcType var + + +zonkWC :: WantedConstraints -> ZonkM WantedConstraints +zonkWC wc = zonkWCRec wc + +zonkWCRec :: WantedConstraints -> ZonkM WantedConstraints +zonkWCRec (WC { wc_simple = simple, wc_impl = implic, wc_errors = errs }) + = do { simple' <- zonkSimples simple + ; implic' <- mapBagM zonkImplication implic + ; errs' <- mapBagM zonkDelayedError errs + ; return (WC { wc_simple = simple', wc_impl = implic', wc_errors = errs' }) } + +zonkSimples :: Cts -> ZonkM Cts +zonkSimples cts = do { cts' <- mapBagM zonkCt cts + ; traceZonk "zonkSimples done:" (ppr cts') + ; return cts' } + +zonkDelayedError :: DelayedError -> ZonkM DelayedError +zonkDelayedError (DE_Hole hole) + = 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 }) + = do { ty' <- zonkTcType ty + ; return (hole { hole_ty = ty' }) } + +zonkNotConcreteError :: NotConcreteError -> ZonkM NotConcreteError +zonkNotConcreteError err@(NCE_FRR { nce_frr_origin = frr_orig }) + = do { frr_orig <- zonkFRROrigin frr_orig + ; return $ err { nce_frr_origin = frr_orig } } + +zonkFRROrigin :: FixedRuntimeRepOrigin -> ZonkM FixedRuntimeRepOrigin +zonkFRROrigin (FixedRuntimeRepOrigin ty orig) + = do { ty' <- zonkTcType ty + ; return $ FixedRuntimeRepOrigin ty' orig } + +{- Note [zonkCt behaviour] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +zonkCt tries to maintain the canonical form of a Ct. For example, + - a CDictCan should stay a CDictCan; + - a CIrredCan should stay a CIrredCan with its cc_reason flag intact + +Why?, for example: +- For CDictCan, the @GHC.Tc.Solver.expandSuperClasses@ step, which runs after the + simple wanted and plugin loop, looks for @CDictCan@s. If a plugin is in use, + constraints are zonked before being passed to the plugin. This means if we + don't preserve a canonical form, @expandSuperClasses@ fails to expand + superclasses. This is what happened in #11525. + +- For CIrredCan we want to see if a constraint is insoluble with insolubleWC + +On the other hand, we change CEqCan to CNonCanonical, because of all of +CEqCan's invariants, which can break during zonking. (Example: a ~R alpha, where +we have alpha := N Int, where N is a newtype.) Besides, the constraint +will be canonicalised again, so there is little benefit in keeping the +CEqCan structure. + +NB: Constraints are always rewritten etc by the canonicaliser in +GHC.Tc.Solver.Solve.solveCt even if they come in as CDictCan. Only canonical +constraints that are actually in the inert set carry all the guarantees. So it +is okay if zonkCt creates e.g. a CDictCan where the cc_tyars are /not/ fully +reduced. +-} + +zonkCt :: Ct -> ZonkM Ct +-- See Note [zonkCt behaviour] +zonkCt (CDictCan dict@(DictCt { di_ev = ev, di_tys = args })) + = do { ev' <- zonkCtEvidence ev + ; args' <- mapM zonkTcType args + ; return (CDictCan (dict { di_ev = ev', di_tys = args' })) } + +zonkCt (CEqCan (EqCt { eq_ev = ev })) + = mkNonCanonical <$> zonkCtEvidence ev + +zonkCt (CIrredCan ir@(IrredCt { ir_ev = ev })) -- Preserve the ir_reason flag + = do { ev' <- zonkCtEvidence ev + ; return (CIrredCan (ir { ir_ev = ev' })) } + +zonkCt ct + = do { fl' <- zonkCtEvidence (ctEvidence ct) + ; return (mkNonCanonical fl') } + +zonkCtEvidence :: CtEvidence -> ZonkM CtEvidence +-- 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 + +zonkSkolemInfoAnon :: SkolemInfoAnon -> ZonkM SkolemInfoAnon +zonkSkolemInfoAnon (SigSkol cx ty tv_prs) = do { ty' <- zonkTcType ty + ; return (SigSkol cx ty' tv_prs) } +zonkSkolemInfoAnon (InferSkol ntys) = do { ntys' <- mapM do_one ntys + ; return (InferSkol ntys') } + where + do_one (n, ty) = do { ty' <- zonkTcType ty; return (n, ty') } +zonkSkolemInfoAnon skol_info = return skol_info + +{- Note [Sharing in zonking] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we have + alpha :-> beta :-> gamma :-> ty +where the ":->" means that the unification variable has been +filled in with Indirect. Then when zonking alpha, it'd be nice +to short-circuit beta too, so we end up with + alpha :-> zty + beta :-> zty + gamma :-> zty +where zty is the zonked version of ty. That way, if we come across +beta later, we'll have less work to do. (And indeed the same for +alpha.) + +This is easily achieved: just overwrite (Indirect ty) with (Indirect +zty). Non-systematic perf comparisons suggest that this is a modest +win. + +But c.f Note [Sharing when zonking to Type] in GHC.Tc.Zonk.Type. + +%************************************************************************ +%* * + 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 +* * +************************************************************************ +-} + +tcInitTidyEnv :: ZonkM TidyEnv +-- We initialise the "tidy-env", used for tidying types before printing, +-- by building a reverse map from the in-scope type variables to the +-- OccName that the programmer originally used for them +tcInitTidyEnv + = do { ZonkGblEnv { zge_binder_stack = bndrs } <- getZonkGblEnv + ; go emptyTidyEnv bndrs } + where + go (env, subst) [] + = return (env, subst) + go (env, subst) (b : bs) + | TcTvBndr name tyvar <- b + = do { let (env', occ') = tidyOccName env (nameOccName name) + name' = tidyNameOcc name occ' + tyvar1 = setTyVarName tyvar name' + ; tyvar2 <- zonkTcTyVarToTcTyVar tyvar1 + -- Be sure to zonk here! Tidying applies to zonked + -- types, so if we don't zonk we may create an + -- ill-kinded type (#14175) + ; go (env', extendVarEnv subst tyvar tyvar2) bs } + | otherwise + = go (env, subst) bs + +-- | Get a 'TidyEnv' that includes mappings for all vars free in the given +-- type. Useful when tidying open types. +tcInitOpenTidyEnv :: [TyCoVar] -> ZonkM TidyEnv +tcInitOpenTidyEnv tvs + = do { env1 <- tcInitTidyEnv + ; return (tidyFreeTyCoVars env1 tvs) } + +zonkTidyTcType :: TidyEnv -> TcType -> ZonkM (TidyEnv, TcType) +zonkTidyTcType env ty = do { ty' <- zonkTcType ty + ; return (tidyOpenTypeX env ty') } + +zonkTidyTcTypes :: TidyEnv -> [TcType] -> ZonkM (TidyEnv, [TcType]) +zonkTidyTcTypes = zonkTidyTcTypes' [] + where zonkTidyTcTypes' zs env [] = return (env, reverse zs) + zonkTidyTcTypes' zs env (ty:tys) + = do { (env', ty') <- zonkTidyTcType env ty + ; zonkTidyTcTypes' (ty':zs) env' tys } + +zonkTidyOrigin :: TidyEnv -> CtOrigin -> ZonkM (TidyEnv, CtOrigin) +zonkTidyOrigin env (GivenOrigin skol_info) + = do { skol_info1 <- zonkSkolemInfoAnon skol_info + ; let skol_info2 = tidySkolemInfoAnon env skol_info1 + ; return (env, GivenOrigin skol_info2) } +zonkTidyOrigin env (GivenSCOrigin skol_info sc_depth blocked) + = 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 + ; (env2, exp') <- zonkTidyTcType env1 exp + ; return ( env2, orig { uo_actual = act' + , uo_expected = exp' }) } +zonkTidyOrigin env (KindEqOrigin ty1 ty2 orig t_or_k) + = do { (env1, ty1') <- zonkTidyTcType env ty1 + ; (env2, ty2') <- zonkTidyTcType env1 ty2 + ; (env3, orig') <- zonkTidyOrigin env2 orig + ; return (env3, KindEqOrigin ty1' ty2' orig' t_or_k) } +zonkTidyOrigin env (FunDepOrigin1 p1 o1 l1 p2 o2 l2) + = do { (env1, p1') <- zonkTidyTcType env p1 + ; (env2, o1') <- zonkTidyOrigin env1 o1 + ; (env3, p2') <- zonkTidyTcType env2 p2 + ; (env4, o2') <- zonkTidyOrigin env3 o2 + ; return (env4, FunDepOrigin1 p1' o1' l1 p2' o2' l2) } +zonkTidyOrigin env (FunDepOrigin2 p1 o1 p2 l2) + = do { (env1, p1') <- zonkTidyTcType env p1 + ; (env2, p2') <- zonkTidyTcType env1 p2 + ; (env3, o1') <- zonkTidyOrigin env2 o1 + ; return (env3, FunDepOrigin2 p1' o1' p2' l2) } +zonkTidyOrigin env (InjTFOrigin1 pred1 orig1 loc1 pred2 orig2 loc2) + = do { (env1, pred1') <- zonkTidyTcType env pred1 + ; (env2, orig1') <- zonkTidyOrigin env1 orig1 + ; (env3, pred2') <- zonkTidyTcType env2 pred2 + ; (env4, orig2') <- zonkTidyOrigin env3 orig2 + ; return (env4, InjTFOrigin1 pred1' orig1' loc1 pred2' orig2' loc2) } +zonkTidyOrigin env (CycleBreakerOrigin orig) + = do { (env1, orig') <- zonkTidyOrigin env orig + ; return (env1, CycleBreakerOrigin orig') } +zonkTidyOrigin env (InstProvidedOrigin mod cls_inst) + = do { (env1, is_tys') <- mapAccumLM zonkTidyTcType env (is_tys cls_inst) + ; return (env1, InstProvidedOrigin mod (cls_inst {is_tys = is_tys'})) } +zonkTidyOrigin env (WantedSuperclassOrigin pty orig) + = do { (env1, pty') <- zonkTidyTcType env pty + ; (env2, orig') <- zonkTidyOrigin env1 orig + ; return (env2, WantedSuperclassOrigin pty' orig') } +zonkTidyOrigin env orig = return (env, orig) + +zonkTidyOrigins :: TidyEnv -> [CtOrigin] -> ZonkM (TidyEnv, [CtOrigin]) +zonkTidyOrigins = mapAccumLM zonkTidyOrigin + +zonkTidyFRRInfos :: TidyEnv + -> [FixedRuntimeRepErrorInfo] + -> ZonkM (TidyEnv, [FixedRuntimeRepErrorInfo]) +zonkTidyFRRInfos = go [] + 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 + , 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_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 $ tidyFreeTyCoVarX env tv + ; (env, ty) <- zonkTidyTcType env ty + ; return (env, Just (tv, ty)) } + +---------------- +tidyCt :: TidyEnv -> Ct -> Ct +-- Used only in error reporting +tidyCt env = updCtEvidence (tidyCtEvidence env) + +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 + = 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 = 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_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 }) + = err { nce_frr_origin = tidyFRROrigin env frr_orig } + +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 new file mode 100644 --- /dev/null +++ b/GHC/Tc/Zonk/Type.hs @@ -0,0 +1,1954 @@ +{-# LANGUAGE GADTs #-} + +{- +(c) The University of Glasgow 2006 +(c) The AQUA Project, Glasgow University, 1996-1998 +-} + +-- | Final zonking to 'Type'. See Note [Zonking to Type]. +-- +-- Distinct from the intra-typechecker zonking in "GHC.Tc.Zonk.TcType"; +-- see Note [Module structure for zonking]. +module GHC.Tc.Zonk.Type ( + -- * Zonking + -- | For a description of "zonking", see Note [What is zonking?]. + ZonkTcM, + zonkTopDecls, zonkTopExpr, zonkTopLExpr, + zonkTopBndrs, + zonkTyVarBindersX, zonkTyVarBinderX, + zonkTyBndrX, zonkTyBndrsX, + zonkTcTypeToType, zonkTcTypeToTypeX, + zonkTcTypesToTypesX, zonkScaledTcTypesToTypesX, + zonkTyVarOcc, + zonkCoToCo, + zonkEvBinds, zonkTcEvBinds, + zonkTcMethInfoToMethInfoX, + lookupTyVarX, + + -- ** 'ZonkEnv', and the 'ZonkT' and 'ZonkBndrT' monad transformers + module GHC.Tc.Zonk.Env, + + -- * Tidying + tcInitTidyEnv, tcInitOpenTidyEnv, + + + ) where + +import GHC.Prelude + +import GHC.Builtin.Types + +import GHC.Core.TyCo.Ppr ( pprTyVar ) + +import GHC.Hs + +import {-# SOURCE #-} GHC.Tc.Gen.Splice (runTopSplice) +import GHC.Tc.Types ( TcM ) +import GHC.Tc.Types.TcRef +import GHC.Tc.TyCl.Build ( TcMethInfo, MethInfo ) +import GHC.Tc.Utils.Env ( tcLookupGlobalOnly ) +import GHC.Tc.Utils.TcType +import GHC.Tc.Utils.Monad ( newZonkAnyType, setSrcSpanA, liftZonkM, traceTc, addErr ) +import GHC.Tc.Types.Evidence +import GHC.Tc.Errors.Types +import GHC.Tc.Zonk.Env +-- Very little shared code between GHC.Tc.Zonk.TcType and GHC.Tc.Zonk.Type. +-- See Note [Module structure for zonking] +import GHC.Tc.Zonk.TcType + ( tcInitTidyEnv, tcInitOpenTidyEnv + , writeMetaTyVarRef + , checkCoercionHole + , zonkCoVar ) + +import GHC.Core.Type +import GHC.Core.Coercion +import GHC.Core.TyCon + +import GHC.Utils.Outputable +import GHC.Utils.Misc +import GHC.Utils.Monad +import GHC.Utils.Panic + +import GHC.Core.Multiplicity +import GHC.Core +import GHC.Core.Predicate + +import GHC.Types.Name +import GHC.Types.Name.Env +import GHC.Types.Var +import GHC.Types.Var.Env +import GHC.Types.Id +import GHC.Types.TypeEnv +import GHC.Types.Basic +import GHC.Types.SrcLoc +import GHC.Types.Unique.FM +import GHC.Types.TyThing + +import GHC.Tc.Types.BasicTypes + +import GHC.Data.Maybe +import GHC.Data.Bag + +import Control.Monad +import Control.Monad.Trans.Class ( lift ) +import Data.List.NonEmpty ( NonEmpty ) +import Data.Foldable ( toList ) + +{- Note [What is zonking?] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +GHC relies heavily on mutability in the typechecker for efficient operation. +For this reason, throughout much of the type checking process, meta type +variables (the MetaTv constructor of TcTyVarDetails) are represented by mutable +variables (known as TcRefs). + +Zonking is the process of replacing each such mutable variable with a Type. +This involves traversing the entire type expression, but the interesting part, +replacing the mutable variables, occurs in zonkTyVarOcc. + +There are two ways to zonk a Type, using one of two entirely separate zonkers, +that share essentially no code: + +* GHC.Tc.Zonk.TcType.zonkTcType, which is used /during/ type checking: + * It leaves unfilled metavars untouched, so the resulting Type can contain TcTyVars + * It is only defined for Type and Coercion, not for HsExpr + * It works in a very stripped-down monad, ZonkM, make it clear that it uses + very few effects (for example, it can't throw errors). + +* GHC.Tc.Zonk.Type.zonkTcTypeToType, is used /after/ typechecking is complete: + * It always returns a Type with no remaining TcTyVars; no meta-tyvars remain. + * It does defaulting, replacing an unconstrained TcTyVar with Any, or failing + (determined by the ZonkFlexi parameter used; see GHC.Tc.Zonk.Type.commitFlexi). + * It works over HsExpr and HsBinds as well as Type and Coercion. As part of this, + it also removes the mutable variables in evidence bindings. + * It works in the full TcM monad, augmented with an environment. + More precisely, it uses ZonkTcM and ZonkBndrTcM, which augment TcM with a + ZonkEnv environment using the zonking monad transformers ZonkT and ZonkBndrT + (see Note [The ZonkEnv] in GHC.Tc.Zonk.Env). + + Why TcM rather than a smaller monad? See Note [Using TcM for zonking to Type]. + +Note [Module structure for zonking] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +As remarked in Note [What is zonking?], there are really two different zonkers; +we have GHC.Tc.Zonk.TcType for zonking within the typechecker and +GHC.Tc.Zonk.Type for the final zonking pass. + +The code relating to zonking is thus split up across the following modules: + + I. Zonking within the typechecker + 1. GHC.Tc.Zonk.Monad + 2. GHC.Tc.Zonk.TcType + + II. Final zonking to Type + 1. GHC.Tc.Zonk.Env + 2. GHC.Tc.Zonk.Type + +I.1. GHC.Tc.Zonk.Monad - the ZonkM monad + + GHC.Tc.Zonk.Monad defines the ZonkM monad, which is a stripped down version + of TcM which has just enough information to be able to zonk types. + + This is the monad used for zonking inside the typechecker, + as used in GHC.Tc.Zonk.TcType. + + Crucially, it never errors. It is the monad we use when reporting errors + (see ErrCtxt), and it would be quite bad if we could error in the middle + of reporting an error! + +I.2. GHC.Tc.Zonk.TcType - zonking types in the typechecker + + GHC.Tc.Zonk.TcType contains code for zonking types and constraints, for use + within the typechecker. It uses the ZonkM monad. + For example, it defines: + + zonkTcType :: TcType -> ZonkM TcType + zonkCt :: Ct -> ZonkM Ct + +II.1. GHC.Tc.Zonk.Env - the ZonkEnv and ZonkT/ZonkBndrT monad transformers + + GHC.Tc.Zonk.Env defines the the ZonkT and ZonkBndrT monad transformers. + These are essentially "ReaderT ZonkEnv" and "StateT ZonkEnv", except + that ZonkBndrT use continuation-passing style instead of an explicit state. + See Note [The ZonkEnv] in GHC.Tc.Zonk.Env. + + These are used for the final zonking to type, in GHC.Tc.Zonk.Type. + +II.2. GHC.Tc.Zonk.Type - final zonking to type + + GHC.Tc.Zonk.Type is concerned with the "final zonking" pass, after we finish + typechecking. It zonks not only types, but terms. It uses the monads + + type ZonkTcM = ZonkT TcM + type ZonkBndrTcM = ZonkBndrTcM + + for example: + + zonkTyBndrX :: TcTyVar -> ZonkBndrTcM TyVar + zonkTcTypeToTypeX :: TcType -> ZonkT TcM Type + +Note that ZonkTcM does a lot more things than ZonkM: + + - it uses a separate ZonkEnv state to accumulate zonked type + (see Note [The ZonkEnv] in GHC.Tc.Zonk.Env) + - it defaults type variables, + (see Note [Un-unified unification variables] in GHC.Tc.Zonk.Env) + - turns TcTyVars into TyVars, + - ... + +This means that there is essentially no code shared between "GHC.Tc.Zonk.TcType" +and "GHC.Tc.Zonk.Type'; they're really two different zonkers. + +Note [Zonking to Type] +~~~~~~~~~~~~~~~~~~~~~~ +Zonking to Type is a final zonking pass done *after* typechecking. +It runs over the bindings + + a) to convert TcTyVars to TyVars etc, dereferencing any bindings etc + b) convert unbound TcTyVar to Void + c) convert each TcId to an Id by zonking its type + +The type variables are converted by binding mutable tyvars to immutable ones +and then zonking as normal. + +The Ids are converted by binding them in the normal Tc envt; that +way we maintain sharing; eg an Id is zonked at its binding site and they +all occurrences of that Id point to the common zonked copy + +It's all pretty boring stuff, because HsSyn is such a large type, and +the environment manipulation is tiresome. + +Note [Sharing when zonking to Type] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Problem: + + In GHC.Tc.Zonk.TcType.zonkTcTyVar, we short-circuit (Indirect ty) to + (Indirect zty), see Note [Sharing in zonking] in GHC.Tc.Zonk.TcType. + But we /can't/ do this when zonking a TcType to a Type (#15552, esp comment:3). + Suppose we have + + alpha -> alpha + where + alpha is already unified: + alpha := T{tc-tycon} Int -> Int + and T is knot-tied + + By "knot-tied" I mean that the occurrence of T is currently a TcTyCon, + but the global env contains a mapping "T" :-> T{knot-tied-tc}. See + Note [Type checking recursive type and class declarations] in + GHC.Tc.TyCl. + + Now we call zonkTcTypeToType on that (alpha -> alpha). If we follow + the same path as Note [Sharing in zonking] in GHC.Tc.Zonk.TcType, we'll + update alpha to + alpha := T{knot-tied-tc} Int -> Int + + But alas, if we encounter alpha for a /second/ time, we end up + looking at T{knot-tied-tc} and fall into a black hole. The whole + point of zonkTcTypeToType is that it produces a type full of + knot-tied tycons, and you must not look at the result!! + + To put it another way (zonkTcTypeToType . zonkTcTypeToType) is not + the same as zonkTcTypeToType. (If we distinguished TcType from + Type, this issue would have been a type error!) + +Solutions: (see #15552 for other variants) + +One possible solution is simply not to do the short-circuiting. +That has less sharing, but maybe sharing is rare. And indeed, +that usually turns out to be viable from a perf point of view + +But zonkTyVarOcc implements something a bit better + +* ZonkEnv contains ze_meta_tv_env, which maps + from a MetaTyVar (unification variable) + to a Type (not a TcType) + +* In zonkTyVarOcc, we check this map to see if we have zonked + this variable before. If so, use the previous answer; if not + zonk it, and extend the map. + +* The map is of course stateful, held in a TcRef. (That is unlike + the treatment of lexically-scoped variables in ze_tv_env and + ze_id_env.) + +* In zonkTyVarOcc we read the TcRef to look up the unification + variable: + - if we get a hit we use the zonked result; + - if not, in zonk_meta we see if the variable is `Indirect ty`, + zonk that, and update the map (in finish_meta) + But Nota Bene that the "update map" step must re-read the TcRef + (or, more precisely, use updTcRef) because the zonking of the + `Indirect ty` may have added lots of stuff to the map. See + #19668 for an example where this made an asymptotic difference! + +Is it worth the extra work of carrying ze_meta_tv_env? Some +non-systematic perf measurements suggest that compiler allocation is +reduced overall (by 0.5% or so) but compile time really doesn't +change. But in some cases it makes a HUGE difference: see test +T9198 and #19668. So yes, it seems worth it. + +Note [Using TcM for zonking to Type] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The main zonking monads currently wrap TcM, because we need access to +the full TcM monad in order to expand typed TH splices. +See zonkExpr (HsTypedSplice s _) = ... + +After the Typed TH plan has been implemented, this should no longer be necessary, +and we should be able to use a stripped down monad, similar to the ZonkM monad +which we use for zonking within the typechecker (but we will need a place to +accumulate errors). + +Note [Inlining ZonkBndrT computations] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Computations that use the ZonkBndrT monad transformer must be inlined: +ZonkBndrT uses continuation-passing style; failing to inline means applying +an unknown continuation (unknown function call), which prevents many +optimisations from taking place. + +See test cases T14683, which regresses without these changes. +-} + +-- Why do we use TcM below? See Note [Using TcM for zonking to Type] + +-- | Zonking monad for a computation that zonks to Type, reading from a 'ZonkEnv' +-- but not extending or modifying it. +-- +-- See Note [Zonking to Type]. +type ZonkTcM = ZonkT TcM + +-- | Zonking monad for a computation that zonks to Type, reading from +-- and extending or modifying a 'ZonkEnv'. +-- +-- See Note [Zonking to Type]. +type ZonkBndrTcM = ZonkBndrT TcM + +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 (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 + +-------------------------------------------------------------------------------- + +zonkTyBndrsX :: [TcTyVar] -> ZonkBndrTcM [TcTyVar] +zonkTyBndrsX = traverse zonkTyBndrX +{-# INLINE zonkTyBndrsX #-} -- See Note [Inlining ZonkBndrT computations] + +zonkTyBndrX :: TcTyVar -> ZonkBndrTcM TyVar +-- This guarantees to return a TyVar (not a TcTyVar) +-- then we add it to the envt, so all occurrences are replaced +-- +-- It does not clone: the new TyVar has the sane Name +-- as the old one. This important when zonking the +-- TyVarBndrs of a TyCon, whose Names may scope. +zonkTyBndrX tv + = assertPpr (isImmutableTyVar tv) (ppr tv <+> dcolon <+> ppr (tyVarKind tv)) $ + do { ki <- noBinders $ zonkTcTypeToTypeX (tyVarKind tv) + -- Internal names tidy up better, for iface files. + ; let tv' = mkTyVar (tyVarName tv) ki + ; extendTyZonkEnv tv' + ; return tv' } +{-# INLINE zonkTyBndrX #-} -- See Note [Inlining ZonkBndrT computations] + +zonkTyVarBindersX :: [VarBndr TcTyVar vis] + -> ZonkBndrTcM [VarBndr TyVar vis] +zonkTyVarBindersX = traverse zonkTyVarBinderX +{-# INLINE zonkTyVarBindersX #-} -- See Note [Inlining ZonkBndrT computations] + +zonkTyVarBinderX :: VarBndr TcTyVar vis + -> ZonkBndrTcM (VarBndr TyVar vis) +-- Takes a TcTyVar and guarantees to return a TyVar +zonkTyVarBinderX (Bndr tv vis) + = do { tv' <- zonkTyBndrX tv + ; return (Bndr tv' vis) } +{-# INLINE zonkTyVarBinderX #-} -- See Note [Inlining ZonkBndrT computations] + +zonkTyVarOcc :: HasDebugCallStack => TcTyVar -> ZonkTcM Type +zonkTyVarOcc tv + = 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 + Nothing -> -- TyVar/SkolemTv/RuntimeUnk that isn't in the ZonkEnv + -- This can happen for RuntimeUnk variables (which + -- should stay as RuntimeUnk), but I think it should + -- not happen for SkolemTv. + mkTyVarTy <$> updateTyVarKindM zonkTcTypeToTypeX tv + + Just tv' -> return (mkTyVarTy tv') + + zonk_meta ref Flexi + = do { kind <- zonkTcTypeToTypeX (tyVarKind tv) + ; ty <- lift $ commitFlexi zonk_flexi tv kind + + ; lift $ liftZonkM $ writeMetaTyVarRef tv ref ty -- Belt and braces + ; finish_meta ty } + + zonk_meta _ (Indirect ty) + = do { zty <- zonkTcTypeToTypeX ty + ; finish_meta zty } + + finish_meta ty + = do { extendMetaEnv tv ty + ; return ty } + + ; if isTcTyVar tv + then case tcTyVarDetails tv of + SkolemTv {} -> lookup_in_tv_env + RuntimeUnk {} -> lookup_in_tv_env + MetaTv { mtv_ref = ref } + -> do { mb_ty <- lookupMetaTv tv + -- See Note [Sharing when zonking to Type] + ; case mb_ty of + Just ty -> return ty + Nothing -> do { mtv_details <- readTcRef ref + ; zonk_meta ref mtv_details } } + + -- This should never really happen; + -- TyVars should not occur in the typechecker + else lookup_in_tv_env } + +extendMetaEnv :: TcTyVar -> Type -> ZonkTcM () +extendMetaEnv tv ty = + ZonkT $ \ ( ZonkEnv { ze_meta_tv_env = mtv_env_ref } ) -> + updTcRef mtv_env_ref (\env -> extendVarEnv env tv ty) + +lookupMetaTv :: TcTyVar -> ZonkTcM (Maybe Type) +lookupMetaTv tv = + ZonkT $ \ ( ZonkEnv { ze_meta_tv_env = mtv_env_ref } ) -> + do { mtv_env <- readTcRef mtv_env_ref + ; return $ lookupVarEnv mtv_env tv } + +lookupTyVarX :: TcTyVar -> ZonkTcM TyVar +lookupTyVarX tv + = do { ZonkEnv { ze_tv_env = tv_env } <- getZonkEnv + ; let !res = case lookupVarEnv tv_env tv of + Just tv -> tv + Nothing -> pprPanic "lookupTyVarOcc" (ppr tv $$ ppr tv_env) + ; return res } + +commitFlexi :: ZonkFlexi -> TcTyVar -> Kind -> TcM Type +commitFlexi NoFlexi tv zonked_kind + = 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) } + +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 + = do { ZonkEnv { ze_tv_env = tyco_env } <- getZonkEnv + -- don't look in the knot-tied env + ; case lookupVarEnv tyco_env cv of + Just cv' -> return $ mkCoVarCo cv' + _ -> mkCoVarCo <$> (lift $ liftZonkM $ zonkCoVar cv) } + +zonkCoHole :: CoercionHole -> ZonkTcM Coercion +zonkCoHole hole@(CoercionHole { ch_ref = ref, ch_co_var = cv }) + = do { contents <- readTcRef ref + ; case contents of + Just co -> do { co' <- zonkCoToCo co + ; lift $ liftZonkM $ checkCoercionHole cv co' } + + -- This next case should happen only in the presence of + -- (undeferred) type errors. Originally, I put in a panic + -- here, but that caused too many uses of `failIfErrsM`. + Nothing -> do { lift $ traceTc "Zonking unfilled coercion hole" (ppr hole) + ; cv' <- lift $ liftZonkM $ zonkCoVar cv + ; return $ mkCoVarCo cv' } } + -- This will be an out-of-scope variable, but keeping + -- this as a coercion hole led to #15787 + +zonk_tycomapper :: TyCoMapper ZonkEnv TcM +zonk_tycomapper = TyCoMapper + { tcm_tyvar = \ env tv -> runZonkT (zonkTyVarOcc tv) env + , tcm_covar = \ env cv -> runZonkT (zonkCoVarOcc cv) env + , tcm_hole = \ env co -> runZonkT (zonkCoHole co) env + , tcm_tycobinder = \ env tcv _vis k -> flip runZonkT env $ + runZonkBndrT (zonkTyBndrX tcv) $ + \ tcv' -> ZonkT $ \ env' -> (k env' tcv') + , tcm_tycon = \ tc -> zonkTcTyConToTyCon tc + } + +-- Zonk a TyCon by changing a TcTyCon to a regular TyCon +zonkTcTyConToTyCon :: TcTyCon -> TcM TyCon +zonkTcTyConToTyCon tc + | isTcTyCon tc = do { thing <- tcLookupGlobalOnly (getName tc) + ; case thing of + ATyCon real_tc -> return real_tc + _ -> pprPanic "zonkTcTyCon" (ppr tc $$ ppr thing) } + | otherwise = return tc -- it's already zonked + +-- | Confused by zonking? See Note [What is zonking?] in "GHC.Tc.Zonk.Type". +zonkTcTypeToType :: TcType -> TcM Type +zonkTcTypeToType ty = initZonkEnv DefaultFlexi $ zonkTcTypeToTypeX ty + +zonkScaledTcTypeToTypeX :: Scaled TcType -> ZonkTcM (Scaled TcType) +zonkScaledTcTypeToTypeX (Scaled m ty) = Scaled <$> zonkTcTypeToTypeX m + <*> zonkTcTypeToTypeX ty + +zonkTcTypeToTypeX :: TcType -> ZonkTcM Type +zonkTcTypesToTypesX :: [TcType] -> ZonkTcM [Type] +zonkCoToCo :: Coercion -> ZonkTcM Coercion +(zonkTcTypeToTypeX, zonkTcTypesToTypesX, zonkCoToCo) + = case mapTyCoX zonk_tycomapper of + (zty, ztys, zco, _) -> + (ZonkT . flip zty, ZonkT . flip ztys, ZonkT . flip zco) + +zonkScaledTcTypesToTypesX :: [Scaled TcType] -> ZonkTcM [Scaled Type] +zonkScaledTcTypesToTypesX scaled_tys = + mapM zonkScaledTcTypeToTypeX scaled_tys + + +zonkEnvIds :: ZonkEnv -> TypeEnv +zonkEnvIds (ZonkEnv { ze_id_env = id_env }) + = mkNameEnv [(getName id, AnId id) | id <- nonDetEltsUFM id_env] + -- It's OK to use nonDetEltsUFM here because we forget the ordering + -- immediately by creating a TypeEnv + +zonkLIdOcc :: LocatedN TcId -> ZonkTcM (LocatedN Id) +zonkLIdOcc = traverse zonkIdOcc + +zonkIdOcc :: TcId -> ZonkTcM Id +-- Ids defined in this module should be in the envt; +-- ignore others. (Actually, data constructors are also +-- not LocalVars, even when locally defined, but that is fine.) +-- (Also foreign-imported things aren't currently in the ZonkEnv; +-- that's ok because they don't need zonking.) +-- +-- Actually, Template Haskell works in 'chunks' of declarations, and +-- an earlier chunk won't be in the 'env' that the zonking phase +-- carries around. Instead it'll be in the tcg_gbl_env, already fully +-- zonked. There's no point in looking it up there (except for error +-- checking), and it's not conveniently to hand; hence the simple +-- 'orElse' case in the LocalVar branch. +-- +-- Even without template splices, in module Main, the checking of +-- 'main' is done as a separate chunk. +zonkIdOcc id + | isLocalVar id = + do { ZonkEnv { ze_id_env = id_env } <- getZonkEnv + ; return $ lookupVarEnv id_env id `orElse` id } + | otherwise + = return id + +zonkIdOccs :: [TcId] -> ZonkTcM [Id] +zonkIdOccs ids = traverse zonkIdOcc ids + +-- zonkIdBndr is used *after* typechecking to get the Id's type +-- to its final form. The TyVarEnv give +zonkIdBndrX :: TcId -> ZonkBndrTcM Id +zonkIdBndrX v + = do { id <- noBinders $ zonkIdBndr v + ; extendIdZonkEnv id + ; return id } +{-# INLINE zonkIdBndrX #-} -- See Note [Inlining ZonkBndrT computations] + +zonkIdBndr :: TcId -> ZonkTcM Id +zonkIdBndr v + = do { Scaled w' ty' <- zonkScaledTcTypeToTypeX (idScaledType v) + ; return $ setIdMult (setIdType v ty') w' } + +zonkIdBndrs :: [TcId] -> ZonkTcM [Id] +zonkIdBndrs ids = mapM zonkIdBndr ids + +zonkTopBndrs :: [TcId] -> TcM [Id] +zonkTopBndrs ids = initZonkEnv DefaultFlexi $ zonkIdBndrs ids + +zonkFieldOcc :: FieldOcc GhcTc -> ZonkTcM (FieldOcc GhcTc) +zonkFieldOcc (FieldOcc lbl (L l sel)) + = FieldOcc lbl . L l <$> zonkIdBndr sel + +zonkEvBndrsX :: [EvVar] -> ZonkBndrTcM [EvVar] +zonkEvBndrsX = traverse zonkEvBndrX +{-# INLINE zonkEvBndrsX #-} -- See Note [Inlining ZonkBndrT computations] + +zonkEvBndrX :: EvVar -> ZonkBndrTcM EvVar +-- Works for dictionaries and coercions +zonkEvBndrX var + = do { var' <- noBinders $ zonkEvBndr var + ; extendZonkEnv [var'] + ; return var' } +{-# INLINE zonkEvBndr #-} -- See Note [Inlining ZonkBndrT computations] + +zonkEvBndr :: EvVar -> ZonkTcM EvVar +-- Works for dictionaries and coercions +-- Does not extend the ZonkEnv +zonkEvBndr var + = updateIdTypeAndMultM ({-# SCC "zonkEvBndr_zonkTcTypeToType" #-} zonkTcTypeToTypeX) var + +{- +zonkEvVarOcc :: EvVar -> ZonkTcM EvTerm +zonkEvVarOcc env v + | isCoVar v + = EvCoercion <$> zonkCoVarOcc env v + | otherwise + = return (EvId $ zonkIdOcc env v) +-} + +zonkCoreBndrX :: Var -> ZonkBndrTcM Var +zonkCoreBndrX v + | isId v = zonkIdBndrX v + | otherwise = zonkTyBndrX v +{-# INLINE zonkCoreBndrX #-} -- See Note [Inlining ZonkBndrT computations] + +zonkCoreBndrsX :: [Var] -> ZonkBndrTcM [Var] +zonkCoreBndrsX = traverse zonkCoreBndrX +{-# INLINE zonkCoreBndrsX #-} -- See Note [Inlining ZonkBndrT computations] + +zonkTopExpr :: HsExpr GhcTc -> TcM (HsExpr GhcTc) +zonkTopExpr e = initZonkEnv DefaultFlexi $ zonkExpr e + +zonkTopLExpr :: LHsExpr GhcTc -> TcM (LHsExpr GhcTc) +zonkTopLExpr e = initZonkEnv DefaultFlexi $ zonkLExpr e + +zonkTopDecls :: Bag EvBind + -> LHsBinds GhcTc + -> [LRuleDecl GhcTc] -> [LTcSpecPrag] + -> [LForeignDecl GhcTc] + -> TcM (TypeEnv, + Bag EvBind, + LHsBinds GhcTc, + [LForeignDecl GhcTc], + [LTcSpecPrag], + [LRuleDecl GhcTc]) +zonkTopDecls ev_binds binds rules imp_specs fords + = initZonkEnv DefaultFlexi $ + runZonkBndrT (zonkEvBinds ev_binds) $ \ ev_binds' -> + runZonkBndrT (zonkRecMonoBinds binds) $ \ binds' -> + -- Top level is implicitly recursive + do { rules' <- zonkRules rules + ; specs' <- zonkLTcSpecPrags imp_specs + ; fords' <- zonkForeignExports fords + ; ty_env <- zonkEnvIds <$> getZonkEnv + ; return (ty_env, ev_binds', binds', fords', specs', rules') } + + +--------------------------------------------- +zonkLocalBinds :: HsLocalBinds GhcTc + -> ZonkBndrTcM (HsLocalBinds GhcTc) +zonkLocalBinds (EmptyLocalBinds x) + = return (EmptyLocalBinds x) + +zonkLocalBinds (HsValBinds _ (ValBinds {})) + = panic "zonkLocalBinds" -- Not in typechecker output + +zonkLocalBinds (HsValBinds x (XValBindsLR (NValBinds binds sigs))) + = do { new_binds <- traverse go binds + ; return (HsValBinds x (XValBindsLR (NValBinds new_binds sigs))) } + where + go (r,b) + = do { b' <- zonkRecMonoBinds b + ; return (r,b') } + +zonkLocalBinds (HsIPBinds x (IPBinds dict_binds binds )) = do + new_binds <- noBinders $ mapM (wrapLocZonkMA zonk_ip_bind) binds + extendIdZonkEnvRec [ n | (L _ (IPBind n _ _)) <- new_binds] + new_dict_binds <- zonkTcEvBinds dict_binds + return $ HsIPBinds x (IPBinds new_dict_binds new_binds) + where + zonk_ip_bind (IPBind dict_id n e) + = do dict_id' <- zonkIdBndr dict_id + e' <- zonkLExpr e + return (IPBind dict_id' n e') + +--------------------------------------------- +zonkRecMonoBinds :: LHsBinds GhcTc -> ZonkBndrTcM (LHsBinds GhcTc) +zonkRecMonoBinds binds + = mfix $ \ new_binds -> + do { extendIdZonkEnvRec (collectHsBindsBinders CollNoDictBinders new_binds) + ; noBinders $ zonkMonoBinds binds } + +--------------------------------------------- +zonkMonoBinds :: LHsBinds GhcTc -> ZonkTcM (LHsBinds GhcTc) +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 + , var_id = var, var_rhs = expr }) + = do { new_var <- zonkIdBndr var + ; new_expr <- zonkLExpr expr + ; return (VarBind { var_ext = x + , var_id = new_var + , var_rhs = new_expr }) } + +zonk_bind bind@(FunBind { fun_id = L loc var + , fun_matches = ms + , fun_ext = (co_fn, ticks) }) + = do { new_var <- zonkIdBndr var + ; runZonkBndrT (zonkCoFn co_fn) $ \ new_co_fn -> + do { new_ms <- zonkMatchGroup zonkLExpr ms + ; return (bind { fun_id = L loc new_var + , fun_matches = new_ms + , fun_ext = (new_co_fn, ticks) }) } } + +zonk_bind (XHsBindsLR (AbsBinds { abs_tvs = tyvars, abs_ev_vars = evs + , abs_ev_binds = ev_binds + , abs_exports = exports + , abs_binds = val_binds + , abs_sig = has_sig })) + = assert ( all isImmutableTyVar tyvars ) $ + 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, 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) + } + ; return $ XHsBindsLR $ + AbsBinds { abs_tvs = new_tyvars, abs_ev_vars = new_evs + , abs_ev_binds = new_ev_binds + , abs_exports = new_exports, abs_binds = new_val_bind + , abs_sig = has_sig } } + where + zonk_val_bind lbind + | has_sig + , (L loc bind@(FunBind { fun_id = (L mloc mono_id) + , fun_matches = ms + , fun_ext = (co_fn, ticks) })) <- lbind + = do { new_mono_id <- updateIdTypeAndMultM zonkTcTypeToTypeX mono_id + -- Specifically /not/ zonkIdBndr; we do not want to + -- complain about a representation-polymorphic binder + ; runZonkBndrT (zonkCoFn co_fn) $ \ new_co_fn -> + do { new_ms <- zonkMatchGroup zonkLExpr ms + ; return $ L loc $ + bind { fun_id = L mloc new_mono_id + , fun_matches = new_ms + , fun_ext = (new_co_fn, ticks) } } } + | otherwise + = zonk_lbind lbind -- The normal case + + zonk_export :: ABExport -> ZonkTcM ABExport + zonk_export (ABE{ abe_wrap = wrap + , abe_poly = poly_id + , abe_mono = mono_id + , abe_prags = prags }) + = do new_poly_id <- zonkIdBndr poly_id + new_wrap <- don'tBind $ zonkCoFn wrap + new_prags <- zonkSpecPrags prags + new_mono_id <- zonkIdOcc mono_id + return (ABE{ abe_wrap = new_wrap + , abe_poly = new_poly_id + , abe_mono = new_mono_id + , abe_prags = new_prags }) + +zonk_bind (PatSynBind x bind@(PSB { psb_id = L loc id + , psb_args = details + , psb_def = lpat + , psb_dir = dir })) + = do { id' <- zonkIdBndr id + ; runZonkBndrT (zonkPat lpat) $ \ lpat' -> + do { details' <- zonkPatSynDetails details + ; dir' <- zonkPatSynDir dir + ; return $ PatSynBind x $ + bind { psb_id = L loc id' + , psb_args = details' + , 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 <$> traverse zonkLIdOcc as +zonkPatSynDetails (InfixCon a1 a2) + = InfixCon <$> zonkLIdOcc a1 <*> zonkLIdOcc a2 +zonkPatSynDetails (RecCon flds) + = RecCon <$> mapM zonkPatSynField flds + +zonkPatSynField :: RecordPatSynField GhcTc -> ZonkTcM (RecordPatSynField GhcTc) +zonkPatSynField (RecordPatSynField x y) = + RecordPatSynField <$> zonkFieldOcc x <*> zonkLIdOcc y + +zonkPatSynDir :: HsPatSynDir GhcTc + -> ZonkTcM (HsPatSynDir GhcTc) +zonkPatSynDir Unidirectional = return Unidirectional +zonkPatSynDir ImplicitBidirectional = return ImplicitBidirectional +zonkPatSynDir (ExplicitBidirectional mg) = ExplicitBidirectional <$> zonkMatchGroup zonkLExpr mg + +zonkSpecPrags :: TcSpecPrags -> ZonkTcM TcSpecPrags +zonkSpecPrags IsDefaultMethod = return IsDefaultMethod +zonkSpecPrags (SpecPrags ps) = do { ps' <- zonkLTcSpecPrags ps + ; return (SpecPrags ps') } + +zonkLTcSpecPrags :: [LTcSpecPrag] -> ZonkTcM [LTcSpecPrag] +zonkLTcSpecPrags ps + = 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)) } + 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' + })) + }} + +{- +************************************************************************ +* * +\subsection[BackSubst-Match-GRHSs]{Match and GRHSs} +* * +************************************************************************ +-} + +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))) +zonkMatchGroup zBody (MG { mg_alts = L l ms + , mg_ext = MatchGroupTc arg_tys res_ty origin + }) + = do { ms' <- mapM (zonkMatch zBody) ms + ; arg_tys' <- zonkScaledTcTypesToTypesX arg_tys + ; res_ty' <- zonkTcTypeToTypeX res_ty + ; return (MG { mg_alts = L l ms' + , mg_ext = MatchGroupTc arg_tys' res_ty' origin + }) } + +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 = L l pats + , m_grhss = grhss })) + = runZonkBndrT (zonkPats pats) $ \ new_pats -> + do { new_grhss <- zonkGRHSs zBody grhss + ; return (L loc (match { m_pats = L l new_pats, m_grhss = new_grhss })) } + +------------------------------------------------------------------------- +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))) + +zonkGRHSs zBody (GRHSs x grhss binds) = + runZonkBndrT (zonkLocalBinds binds) $ \ new_binds -> + do { new_grhss <- mapM (wrapLocZonkMA zonk_grhs) grhss + ; return (GRHSs x new_grhss new_binds) } + where + zonk_grhs (GRHS xx guarded rhs) = + runZonkBndrT (zonkStmts zonkLExpr guarded) $ \ new_guarded -> + GRHS xx new_guarded <$> zBody rhs + +{- +************************************************************************ +* * +\subsection[BackSubst-HsExpr]{Running a zonkitution over a TypeCheckedExpr} +* * +************************************************************************ +-} + +zonkLExprs :: [LHsExpr GhcTc] -> ZonkTcM [LHsExpr GhcTc] +zonkLExpr :: LHsExpr GhcTc -> ZonkTcM (LHsExpr GhcTc) +zonkExpr :: HsExpr GhcTc -> ZonkTcM (HsExpr GhcTc) + +zonkLExprs exprs = mapM zonkLExpr exprs +zonkLExpr expr = wrapLocZonkMA zonkExpr expr + +zonkExpr (HsVar x (L l id)) + = assertPpr (isNothing (isDataConId_maybe id)) (ppr id) $ + do { id' <- zonkIdOcc id + ; return (HsVar x (L l id')) } + +zonkExpr (HsHole (h, her)) + = do her' <- zonk_her her + return (HsHole (h, her')) + where + zonk_her :: HoleExprRef -> ZonkTcM HoleExprRef + zonk_her (HER ref ty u) + = do updTcRefM ref zonkEvTerm + ty' <- zonkTcTypeToTypeX ty + return (HER ref ty' u) + +zonkExpr (HsIPVar x _) = dataConCantHappen x + +zonkExpr (HsOverLabel x _) = dataConCantHappen x + +zonkExpr (HsLit x (XLit (HsRat f ty))) + = do new_ty <- zonkTcTypeToTypeX ty + return (HsLit x (XLit $ HsRat f new_ty)) + +zonkExpr (HsLit x lit) + = return (HsLit x lit) + +zonkExpr (HsOverLit x lit) + = do { lit' <- zonkOverLit lit + ; return (HsOverLit x lit') } + +zonkExpr (HsLam x lam_variant matches) + = do new_matches <- zonkMatchGroup zonkLExpr 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 t) + = do new_e <- zonkLExpr e + new_ty <- zonkTcTypeToTypeX ty + return (HsAppType new_ty new_e t) + -- NB: the type is an HsType; can't zonk that! + +zonkExpr (HsTypedBracket hsb_tc body) + = (\x -> HsTypedBracket x body) <$> zonkBracket hsb_tc + +zonkExpr (HsUntypedBracket hsb_tc body) + = (\x -> HsUntypedBracket x body) <$> zonkBracket hsb_tc + +zonkExpr (HsTypedSplice s _) = ZonkT (\ _ -> runTopSplice s) >>= zonkExpr + +zonkExpr (HsUntypedSplice x _) = dataConCantHappen x + +zonkExpr (OpApp x _ _ _) = dataConCantHappen x + +zonkExpr (NegApp x expr op) + = runZonkBndrT (zonkSyntaxExpr op) $ \ new_op -> + do { new_expr <- zonkLExpr expr + ; return (NegApp x new_expr new_op) } + +zonkExpr (HsPar x e) + = do { new_e <- zonkLExpr e + ; return (HsPar x new_e) } + +zonkExpr (SectionL x _ _) = dataConCantHappen x +zonkExpr (SectionR x _ _) = dataConCantHappen x +zonkExpr (ExplicitTuple x tup_args boxed) + = do { new_tup_args <- mapM zonk_tup_arg tup_args + ; return (ExplicitTuple x new_tup_args boxed) } + where + zonk_tup_arg (Present x e) = do { e' <- zonkLExpr e + ; return (Present x e') } + zonk_tup_arg (Missing t) = do { t' <- zonkScaledTcTypeToTypeX t + ; return (Missing t') } + + +zonkExpr (ExplicitSum args alt arity expr) + = do new_args <- mapM zonkTcTypeToTypeX args + new_expr <- zonkLExpr expr + return (ExplicitSum new_args alt arity new_expr) + +zonkExpr (HsCase x expr ms) + = do new_expr <- zonkLExpr expr + new_ms <- zonkMatchGroup zonkLExpr ms + return (HsCase x new_expr new_ms) + +zonkExpr (HsIf x e1 e2 e3) + = do new_e1 <- zonkLExpr e1 + new_e2 <- zonkLExpr e2 + new_e3 <- zonkLExpr e3 + return (HsIf x new_e1 new_e2 new_e3) + +zonkExpr (HsMultiIf ty alts) + = do { alts' <- mapM (wrapLocZonkMA zonk_alt) alts + ; ty' <- zonkTcTypeToTypeX ty + ; return $ HsMultiIf ty' alts' } + where zonk_alt (GRHS x guard expr) + = runZonkBndrT (zonkStmts zonkLExpr guard) $ \ guard' -> + do { expr' <- zonkLExpr expr + ; return $ GRHS x guard' expr' } + +zonkExpr (HsLet x binds expr) + = runZonkBndrT (zonkLocalBinds binds) $ \ new_binds -> + do { new_expr <- zonkLExpr 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 + new_ty <- zonkTcTypeToTypeX ty + return (HsDo new_ty do_or_lc (L l new_stmts)) + +zonkExpr (ExplicitList ty exprs) + = do new_ty <- zonkTcTypeToTypeX ty + new_exprs <- zonkLExprs exprs + return (ExplicitList new_ty new_exprs) + +zonkExpr expr@(RecordCon { rcon_ext = con_expr, rcon_flds = rbinds }) + = do { new_con_expr <- zonkExpr con_expr + ; new_rbinds <- zonkRecFields rbinds + ; return (expr { rcon_ext = new_con_expr + , rcon_flds = new_rbinds }) } + +zonkExpr (ExprWithTySig _ e ty) + = do { e' <- zonkLExpr e + ; return (ExprWithTySig noExtField e' ty) } + +zonkExpr (ArithSeq expr wit info) + = do { new_expr <- zonkExpr expr + ; runZonkBndrT (zonkWit wit) $ \ new_wit -> + do { new_info <- zonkArithSeq info + ; return (ArithSeq new_expr new_wit new_info) } } + where zonkWit Nothing = return Nothing + zonkWit (Just fln) = Just <$> zonkSyntaxExpr fln + +zonkExpr (HsPragE x prag expr) + = do new_expr <- zonkLExpr expr + return (HsPragE x prag new_expr) + +-- arrow notation extensions +zonkExpr (HsProc x pat body) + = runZonkBndrT (zonkPat pat) $ \ new_pat -> + do { new_body <- zonkCmdTop body + ; return (HsProc x new_pat new_body) } + +-- StaticPointers extension +zonkExpr (HsStatic (fvs, ty) expr) + = do new_ty <- zonkTcTypeToTypeX ty + HsStatic (fvs, new_ty) <$> zonkLExpr expr + +zonkExpr (HsEmbTy x _) = dataConCantHappen x +zonkExpr (HsQual x _ _) = dataConCantHappen x +zonkExpr (HsForAll x _ _) = dataConCantHappen x +zonkExpr (HsFunArr x _ _ _) = dataConCantHappen x + +zonkExpr (XExpr (WrapExpr co_fn expr)) + = runZonkBndrT (zonkCoFn co_fn) $ \ new_co_fn -> + do new_expr <- zonkExpr expr + return (XExpr (WrapExpr new_co_fn new_expr)) + +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 + zonk_scale (Scaled m ty) = Scaled <$> zonkTcTypeToTypeX m <*> pure ty + -- Only the multiplicity can contain unification variables + -- The tvs come straight from the data-con, and so are strictly redundant + -- See Wrinkles of Note [Typechecking data constructors] in GHC.Tc.Gen.Head + +zonkExpr (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 +zonkExpr e@(XExpr (HsTick {})) = pprPanic "zonkExpr" (ppr e) +zonkExpr e@(XExpr (HsBinTick {})) = pprPanic "zonkExpr" (ppr e) + +------------------------------------------------------------------------- +{- +Note [Skolems in zonkSyntaxExpr] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider rebindable syntax with something like + + (>>=) :: (forall x. blah) -> (forall y. blah') -> blah'' + +The x and y become skolems that are in scope when type-checking the +arguments to the bind. This means that we must extend the ZonkEnv with +these skolems when zonking the arguments to the bind. But the skolems +are different between the two arguments, and so we should theoretically +carry around different environments to use for the different arguments. + +However, this becomes a logistical nightmare, especially in dealing with +the more exotic Stmt forms. So, we simplify by making the critical +assumption that the uniques of the skolems are different. (This assumption +is justified by the use of newUnique in GHC.Tc.Utils.TcMType.instSkolTyCoVarX.) +Now, we can safely just extend one environment. +-} + +-- See Note [Skolems in zonkSyntaxExpr] +zonkSyntaxExpr :: SyntaxExpr GhcTc + -> ZonkBndrTcM (SyntaxExpr GhcTc) +zonkSyntaxExpr (SyntaxExprTc { syn_expr = expr + , syn_arg_wraps = arg_wraps + , syn_res_wrap = res_wrap }) + = do { res_wrap' <- zonkCoFn res_wrap + ; expr' <- noBinders $ zonkExpr expr + ; arg_wraps' <- traverse zonkCoFn arg_wraps + ; return SyntaxExprTc { syn_expr = expr' + , syn_arg_wraps = arg_wraps' + , syn_res_wrap = res_wrap' } } +zonkSyntaxExpr NoSyntaxExprTc = return NoSyntaxExprTc + +------------------------------------------------------------------------- + +zonkLCmd :: LHsCmd GhcTc -> ZonkTcM (LHsCmd GhcTc) +zonkCmd :: HsCmd GhcTc -> ZonkTcM (HsCmd GhcTc) + +zonkLCmd cmd = wrapLocZonkMA zonkCmd cmd + +zonkCmd (XCmd (HsWrap w cmd)) + = runZonkBndrT (zonkCoFn w) $ \ w' -> + do { cmd' <- zonkCmd cmd + ; return (XCmd (HsWrap w' cmd')) } +zonkCmd (HsCmdArrApp ty e1 e2 ho rl) + = do new_e1 <- zonkLExpr e1 + new_e2 <- zonkLExpr e2 + new_ty <- zonkTcTypeToTypeX ty + return (HsCmdArrApp new_ty new_e1 new_e2 ho rl) + +zonkCmd (HsCmdArrForm x op fixity args) + = do new_op <- zonkLExpr op + new_args <- mapM zonkCmdTop 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 (HsCmdPar x c) + = do new_c <- zonkLCmd c + 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 (HsCmdLam x lam_variant ms) + = do new_ms <- zonkMatchGroup zonkLCmd ms + return (HsCmdLam x lam_variant new_ms) + +zonkCmd (HsCmdIf x eCond ePred cThen cElse) + = runZonkBndrT (zonkSyntaxExpr eCond) $ \ new_eCond -> + do { new_ePred <- zonkLExpr ePred + ; new_cThen <- zonkLCmd cThen + ; new_cElse <- zonkLCmd cElse + ; return (HsCmdIf x new_eCond new_ePred new_cThen new_cElse) } + +zonkCmd (HsCmdLet x binds cmd) + = runZonkBndrT (zonkLocalBinds binds) $ \ new_binds -> + do new_cmd <- zonkLCmd cmd + return (HsCmdLet x new_binds new_cmd) + +zonkCmd (HsCmdDo ty (L l stmts)) + = do new_stmts <- don'tBind $ zonkStmts zonkLCmd stmts + new_ty <- zonkTcTypeToTypeX ty + return (HsCmdDo new_ty (L l new_stmts)) + + + +zonkCmdTop :: LHsCmdTop GhcTc -> ZonkTcM (LHsCmdTop GhcTc) +zonkCmdTop cmd = wrapLocZonkMA (zonk_cmd_top) cmd + +zonk_cmd_top :: HsCmdTop GhcTc -> ZonkTcM (HsCmdTop GhcTc) +zonk_cmd_top (HsCmdTop (CmdTopTc stack_tys ty ids) cmd) + = do new_cmd <- zonkLCmd cmd + new_stack_tys <- zonkTcTypeToTypeX stack_tys + new_ty <- zonkTcTypeToTypeX ty + new_ids <- mapSndM zonkExpr ids + + 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 + + return (HsCmdTop (CmdTopTc new_stack_tys new_ty new_ids) new_cmd) + +------------------------------------------------------------------------- +zonkCoFn :: HsWrapper -> ZonkBndrTcM HsWrapper +zonkCoFn WpHole = return WpHole +zonkCoFn (WpCompose c1 c2) = do { c1' <- zonkCoFn c1 + ; c2' <- zonkCoFn c2 + ; return (WpCompose c1' c2') } +zonkCoFn (WpFun c1 c2 t1) = do { c1' <- zonkCoFn c1 + ; c2' <- zonkCoFn c2 + ; t1' <- noBinders $ zonkScaledTcTypeToTypeX t1 + ; return (WpFun c1' c2' t1') } +zonkCoFn (WpCast co) = WpCast <$> noBinders (zonkCoToCo co) +zonkCoFn (WpEvLam ev) = WpEvLam <$> zonkEvBndrX ev +zonkCoFn (WpEvApp arg) = WpEvApp <$> noBinders (zonkEvTerm arg) +zonkCoFn (WpTyLam tv) = assert (isImmutableTyVar tv) $ + WpTyLam <$> zonkTyBndrX tv +zonkCoFn (WpTyApp ty) = WpTyApp <$> noBinders (zonkTcTypeToTypeX ty) +zonkCoFn (WpLet bs) = WpLet <$> zonkTcEvBinds bs + +------------------------------------------------------------------------- +zonkOverLit :: HsOverLit GhcTc -> ZonkTcM (HsOverLit GhcTc) +zonkOverLit lit@(OverLit {ol_ext = x@OverLitTc { ol_witness = e, ol_type = ty } }) + = do { ty' <- zonkTcTypeToTypeX ty + ; e' <- zonkExpr e + ; return (lit { ol_ext = x { ol_witness = e' + , ol_type = ty' } }) } + +------------------------------------------------------------------------- +zonkBracket :: HsBracketTc -> ZonkTcM HsBracketTc +zonkBracket (HsBracketTc hsb_thing ty wrap bs) + = do wrap' <- traverse zonkQuoteWrap wrap + bs' <- mapM zonk_b bs + new_ty <- zonkTcTypeToTypeX ty + return (HsBracketTc hsb_thing new_ty wrap' bs') + where + zonkQuoteWrap (QuoteWrapper ev ty) = do + ev' <- zonkIdOcc ev + ty' <- zonkTcTypeToTypeX ty + return (QuoteWrapper ev' ty') + + zonk_b (PendingTcSplice n e) = do e' <- zonkLExpr e + return (PendingTcSplice n e') + +------------------------------------------------------------------------- +zonkArithSeq :: ArithSeqInfo GhcTc -> ZonkTcM (ArithSeqInfo GhcTc) + +zonkArithSeq (From e) + = do new_e <- zonkLExpr e + return (From new_e) + +zonkArithSeq (FromThen e1 e2) + = do new_e1 <- zonkLExpr e1 + new_e2 <- zonkLExpr e2 + return (FromThen new_e1 new_e2) + +zonkArithSeq (FromTo e1 e2) + = do new_e1 <- zonkLExpr e1 + new_e2 <- zonkLExpr e2 + return (FromTo new_e1 new_e2) + +zonkArithSeq (FromThenTo e1 e2 e3) + = do new_e1 <- zonkLExpr e1 + new_e2 <- zonkLExpr e2 + new_e3 <- zonkLExpr e3 + return (FromThenTo new_e1 new_e2 new_e3) + +------------------------------------------------------------------------- +zonkStmts :: Anno (StmtLR GhcTc GhcTc (LocatedA (body GhcTc))) ~ SrcSpanAnnA + => (LocatedA (body GhcTc) -> ZonkTcM (LocatedA (body GhcTc))) + -> [LStmt GhcTc (LocatedA (body GhcTc))] + -> ZonkBndrTcM [LStmt GhcTc (LocatedA (body GhcTc))] +zonkStmts _ [] = return [] +zonkStmts zBody (s:ss) = do { s' <- wrapLocZonkBndrMA (zonkStmt zBody) s + ; ss' <- zonkStmts zBody ss + ; return (s' : ss') } + +zonkStmt :: Anno (StmtLR GhcTc GhcTc (LocatedA (body GhcTc))) ~ SrcSpanAnnA + => (LocatedA (body GhcTc) -> ZonkTcM (LocatedA (body GhcTc))) + -> Stmt GhcTc (LocatedA (body GhcTc)) + -> ZonkBndrTcM (Stmt GhcTc (LocatedA (body GhcTc))) +zonkStmt _ (ParStmt bind_ty stmts_w_bndrs mzip_op bind_op) + = do { new_bind_op <- zonkSyntaxExpr bind_op + ; new_bind_ty <- noBinders $ zonkTcTypeToTypeX bind_ty + ; 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 _ <- toList new_stmts_w_bndrs + , b <- bs ] + ; extendIdZonkEnvRec new_binders + ; new_mzip <- noBinders $ zonkExpr mzip_op + ; return (ParStmt new_bind_ty new_stmts_w_bndrs new_mzip new_bind_op)} + where + zonk_branch :: ParStmtBlock GhcTc GhcTc + -> ZonkTcM (ParStmtBlock GhcTc GhcTc) + zonk_branch (ParStmtBlock x stmts bndrs return_op) + = runZonkBndrT (zonkStmts zonkLExpr stmts) $ \ new_stmts -> + runZonkBndrT (zonkSyntaxExpr return_op) $ \ new_return -> + do { new_bndrs <- zonkIdOccs bndrs + ; return (ParStmtBlock x new_stmts new_bndrs new_return) } + +zonkStmt zBody (RecStmt { recS_stmts = L _ segStmts, recS_later_ids = lvs + , recS_rec_ids = rvs + , recS_ret_fn = ret_id, recS_mfix_fn = mfix_id + , recS_bind_fn = bind_id + , recS_ext = + RecStmtTc { recS_bind_ty = bind_ty + , recS_later_rets = later_rets + , recS_rec_rets = rec_rets + , recS_ret_ty = ret_ty} }) + = do { new_bind_id <- zonkSyntaxExpr bind_id + ; new_mfix_id <- zonkSyntaxExpr mfix_id + ; new_ret_id <- zonkSyntaxExpr ret_id + ; new_bind_ty <- noBinders $ zonkTcTypeToTypeX bind_ty + ; new_rvs <- noBinders $ zonkIdBndrs rvs + ; new_lvs <- noBinders $ zonkIdBndrs lvs + ; new_ret_ty <- noBinders $ zonkTcTypeToTypeX ret_ty + + -- Zonk the ret-expressions in an environment that + -- has the polymorphic bindings + ; rec_stmt <- noBinders $ don'tBind $ + do { extendIdZonkEnvRec new_rvs + ; new_segStmts <- zonkStmts zBody segStmts + ; new_later_rets <- noBinders $ mapM zonkExpr later_rets + ; new_rec_rets <- noBinders $ mapM zonkExpr rec_rets + ; return $ + RecStmt { recS_stmts = noLocA new_segStmts + , recS_later_ids = new_lvs + , recS_rec_ids = new_rvs, recS_ret_fn = new_ret_id + , recS_mfix_fn = new_mfix_id, recS_bind_fn = new_bind_id + , recS_ext = RecStmtTc + { recS_bind_ty = new_bind_ty + , recS_later_rets = new_later_rets + , recS_rec_rets = new_rec_rets + , recS_ret_ty = new_ret_ty } } } + + -- Only the lvs are needed + ; extendIdZonkEnvRec new_lvs + ; return rec_stmt } + +zonkStmt zBody (BodyStmt ty body then_op guard_op) + = do { new_then_op <- zonkSyntaxExpr then_op + ; new_guard_op <- zonkSyntaxExpr guard_op + ; new_body <- noBinders $ zBody body + ; new_ty <- noBinders $ zonkTcTypeToTypeX ty + ; return $ BodyStmt new_ty new_body new_then_op new_guard_op } + +zonkStmt zBody (LastStmt x body noret ret_op) + = noBinders $ runZonkBndrT (zonkSyntaxExpr ret_op) $ \ new_ret -> + do { new_body <- zBody body + ; return $ LastStmt x new_body noret new_ret } + +zonkStmt _ (TransStmt { trS_stmts = stmts, trS_bndrs = binderMap + , trS_by = by, trS_form = form, trS_using = using + , trS_ret = return_op, trS_bind = bind_op + , trS_ext = bind_arg_ty + , trS_fmap = liftM_op }) + = do { bind_op' <- zonkSyntaxExpr bind_op + ; bind_arg_ty' <- noBinders $ zonkTcTypeToTypeX bind_arg_ty + ; stmts' <- zonkStmts zonkLExpr stmts + ; by' <- noBinders $ traverse zonkLExpr by + ; using' <- noBinders $ zonkLExpr using + ; return_op' <- zonkSyntaxExpr return_op + ; liftM_op' <- noBinders $ zonkExpr liftM_op + ; binderMap' <- mapM zonkBinderMapEntry binderMap + ; return (TransStmt { trS_stmts = stmts', trS_bndrs = binderMap' + , trS_by = by', trS_form = form, trS_using = using' + , trS_ret = return_op', trS_bind = bind_op' + , trS_ext = bind_arg_ty' + , trS_fmap = liftM_op' }) } + where + zonkBinderMapEntry (oldBinder, newBinder) = do + oldBinder' <- noBinders $ zonkIdOcc oldBinder + newBinder' <- zonkIdBndrX newBinder + return (oldBinder', newBinder') + +zonkStmt _ (LetStmt x binds) + = LetStmt x <$> zonkLocalBinds binds + +zonkStmt zBody (BindStmt xbs pat body) + = do { new_bind <- zonkSyntaxExpr (xbstc_bindOp xbs) + ; new_w <- noBinders $ zonkTcTypeToTypeX (xbstc_boundResultMult xbs) + ; new_bind_ty <- noBinders $ zonkTcTypeToTypeX (xbstc_boundResultType xbs) + ; new_body <- noBinders $ zBody body + ; new_fail <- case xbstc_failOp xbs of + Nothing -> return Nothing + Just fail_op -> fmap Just <$> noBinders $ don'tBind (zonkSyntaxExpr fail_op) + + ; new_pat <- zonkPat pat + ; return $ + BindStmt + (XBindStmtTc + { xbstc_bindOp = new_bind + , xbstc_boundResultType = new_bind_ty + , xbstc_boundResultMult = new_w + , xbstc_failOp = new_fail + }) + new_pat new_body } + +-- Scopes: join > ops (in reverse order) > pats (in forward order) +-- > rest of stmts +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 $ XStmtLR $ ApplicativeStmt new_body_ty new_args new_mb_join } + where + zonk_join Nothing = return Nothing + zonk_join (Just j) = Just <$> zonkSyntaxExpr j + + get_pat :: (SyntaxExpr GhcTc, ApplicativeArg GhcTc) -> LPat GhcTc + get_pat (_, ApplicativeArgOne _ pat _ _) = pat + get_pat (_, ApplicativeArgMany _ _ _ pat _) = pat + + replace_pat :: LPat GhcTc + -> (SyntaxExpr GhcTc, ApplicativeArg GhcTc) + -> (SyntaxExpr GhcTc, ApplicativeArg GhcTc) + replace_pat pat (op, ApplicativeArgOne fail_op _ a isBody) + = (op, ApplicativeArgOne fail_op pat a isBody) + replace_pat pat (op, ApplicativeArgMany x a b _ c) + = (op, ApplicativeArgMany x a b pat c) + + zonk_args args + = do { new_args_rev <- zonk_args_rev (reverse args) + ; new_pats <- zonkPats (map get_pat args) + ; return $ zipWithEqual replace_pat + new_pats (reverse new_args_rev) } + + -- these need to go backward, because if any operators are higher-rank, + -- later operators may introduce skolems that are in scope for earlier + -- arguments + zonk_args_rev ((op, arg) : args) + = do { new_op <- zonkSyntaxExpr op + ; new_arg <- noBinders $ zonk_arg arg + ; new_args <- zonk_args_rev args + ; return $ (new_op, new_arg) : new_args } + zonk_args_rev [] = return [] + + zonk_arg (ApplicativeArgOne fail_op pat expr isBody) + = do { new_expr <- zonkLExpr expr + ; new_fail <- forM fail_op $ don'tBind . zonkSyntaxExpr + ; return (ApplicativeArgOne new_fail pat new_expr isBody) } + zonk_arg (ApplicativeArgMany x stmts ret pat ctxt) + = runZonkBndrT (zonkStmts zonkLExpr stmts) $ \ new_stmts -> + do { new_ret <- zonkExpr ret + ; return (ApplicativeArgMany x new_stmts new_ret pat ctxt) } + +------------------------------------------------------------------------- +zonkRecFields :: HsRecordBinds GhcTc -> ZonkTcM (HsRecordBinds GhcTc) +zonkRecFields (HsRecFields x flds dd) + = do { flds' <- mapM zonk_rbind flds + ; return (HsRecFields x flds' dd) } + where + zonk_rbind (L l fld) + = do { new_id <- wrapLocZonkMA zonkFieldOcc (hfbLHS fld) + ; new_expr <- zonkLExpr (hfbRHS fld) + ; return (L l (fld { hfbLHS = new_id + , hfbRHS = new_expr })) } + +{- +************************************************************************ +* * +\subsection[BackSubst-Pats]{Patterns} +* * +************************************************************************ +-} + + +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 +-- to the right) +zonkPat pat = wrapLocZonkBndrMA zonk_pat pat + +zonk_pat :: Pat GhcTc -> ZonkBndrTcM (Pat GhcTc) +zonk_pat (ParPat x p) + = do { p' <- zonkPat p + ; return (ParPat x p') } + +zonk_pat (WildPat ty) + = do { ty' <- noBinders $ zonkTcTypeToTypeX ty + ; return (WildPat ty') } + +zonk_pat (VarPat x (L l v)) + = do { v' <- zonkIdBndrX v + ; return (VarPat x (L l v')) } + +zonk_pat (LazyPat x pat) + = do { pat' <- zonkPat pat + ; return (LazyPat x pat') } + +zonk_pat (BangPat x pat) + = do { pat' <- zonkPat pat + ; return (BangPat x pat') } + +zonk_pat (AsPat x (L loc v) pat) + = do { v' <- zonkIdBndrX v + ; pat' <- zonkPat pat + ; return (AsPat x (L loc v') pat') } + +zonk_pat (ViewPat ty expr pat) + = do { expr' <- noBinders $ zonkLExpr expr + ; pat' <- zonkPat pat + ; ty' <- noBinders $ zonkTcTypeToTypeX ty + ; return (ViewPat ty' expr' pat') } + +zonk_pat (ListPat ty pats) + = do { ty' <- noBinders $ zonkTcTypeToTypeX ty + ; pats' <- zonkPats pats + ; return (ListPat ty' pats') } + +zonk_pat (TuplePat tys pats boxed) + = do { tys' <- noBinders $ mapM zonkTcTypeToTypeX tys + ; 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 + ; return (SumPat tys' pat' alt arity) } + +zonk_pat p@(ConPat { pat_args = args + , pat_con_ext = p'@(ConPatTc + { cpt_tvs = tyvars + , cpt_dicts = evs + , cpt_binds = binds + , cpt_wrap = wrapper + , cpt_arg_tys = tys + }) + }) + = assert (all isImmutableTyVar tyvars) $ + do { new_tys <- noBinders $ mapM zonkTcTypeToTypeX tys + ; new_tyvars <- zonkTyBndrsX tyvars + -- Must zonk the existential variables, because their + -- /kind/ need potential zonking. + -- cf typecheck/should_compile/tc221.hs + ; new_evs <- zonkEvBndrsX evs + ; new_binds <- zonkTcEvBinds binds + ; new_wrapper <- zonkCoFn wrapper + ; new_args <- zonkConStuff args + ; pure $ p + { pat_args = new_args + , pat_con_ext = p' + { cpt_arg_tys = new_tys + , cpt_tvs = new_tyvars + , cpt_dicts = new_evs + , cpt_binds = new_binds + , cpt_wrap = new_wrapper + } + } + } + +zonk_pat (LitPat x lit) = return (LitPat x lit) + +zonk_pat (SigPat ty pat hs_ty) + = do { ty' <- noBinders $ zonkTcTypeToTypeX ty + ; pat' <- zonkPat pat + ; return (SigPat ty' pat' hs_ty) } + +zonk_pat (NPat ty (L l lit) mb_neg eq_expr) + = do { eq_expr' <- zonkSyntaxExpr eq_expr + ; mb_neg' <- case mb_neg of + Nothing -> return Nothing + Just n -> Just <$> zonkSyntaxExpr n + ; noBinders $ + do { lit' <- zonkOverLit lit + ; ty' <- zonkTcTypeToTypeX ty + ; return (NPat ty' (L l lit') mb_neg' eq_expr') } } + +zonk_pat (NPlusKPat ty (L loc n) (L l lit1) lit2 e1 e2) + = do { e1' <- zonkSyntaxExpr e1 + ; e2' <- zonkSyntaxExpr e2 + ; lit1' <- noBinders $ zonkOverLit lit1 + ; lit2' <- noBinders $ zonkOverLit lit2 + ; ty' <- noBinders $ zonkTcTypeToTypeX ty + ; 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 + ; return $ XPat $ ExpansionPat orig pat' } + ; CoPat co_fn pat ty -> + do { co_fn' <- zonkCoFn co_fn + ; pat' <- zonkPat (noLocA pat) + ; ty' <- noBinders $ zonkTcTypeToTypeX ty + ; return (XPat $ CoPat co_fn' (unLoc pat') ty') + } } + +zonk_pat pat = pprPanic "zonk_pat" (ppr pat) + +--------------------------- +zonkConStuff :: HsConPatDetails GhcTc + -> ZonkBndrTcM (HsConPatDetails GhcTc) +zonkConStuff (PrefixCon pats) + = do { pats' <- zonkPats pats + ; return (PrefixCon pats') } + +zonkConStuff (InfixCon p1 p2) + = do { p1' <- zonkPat p1 + ; p2' <- zonkPat p2 + ; return (InfixCon p1' p2') } + +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 x rpats' dd)) } + -- Field selectors have declared types; hence no zonking + +--------------------------- +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)) #-} + +{- +************************************************************************ +* * +\subsection[BackSubst-Foreign]{Foreign exports} +* * +************************************************************************ +-} + +zonkForeignExports :: [LForeignDecl GhcTc] + -> ZonkTcM [LForeignDecl GhcTc] +zonkForeignExports ls = mapM (wrapLocZonkMA zonkForeignExport) ls + +zonkForeignExport :: ForeignDecl GhcTc -> ZonkTcM (ForeignDecl GhcTc) +zonkForeignExport (ForeignExport { fd_name = i, fd_e_ext = co + , fd_fe = spec }) + = do { i' <- zonkLIdOcc i + ; return (ForeignExport { fd_name = i' + , fd_sig_ty = undefined, fd_e_ext = co + , fd_fe = spec }) } +zonkForeignExport for_imp + = return for_imp -- Foreign imports don't need zonking + +zonkRules :: [LRuleDecl GhcTc] -> ZonkTcM [LRuleDecl GhcTc] +zonkRules rs = mapM (wrapLocZonkMA zonkRule) rs + +zonkRule :: RuleDecl GhcTc -> ZonkTcM (RuleDecl GhcTc) +zonkRule rule@(HsRule { rd_bndrs = bndrs + , rd_lhs = lhs + , rd_rhs = 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_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! + +{- 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. +-} + +{- +************************************************************************ +* * + Constraints and evidence +* * +************************************************************************ +-} + +zonkEvTerm :: EvTerm -> ZonkTcM EvTerm +zonkEvTerm (EvExpr e) + = EvExpr <$> zonkCoreExpr e +zonkEvTerm (EvTypeable ty ev) + = EvTypeable <$> zonkTcTypeToTypeX ty <*> zonkEvTypeable ev +zonkEvTerm (EvFun { et_tvs = tvs, et_given = evs + , et_binds = ev_binds, et_body = body_id }) + = runZonkBndrT (zonkTyBndrsX tvs) $ \ new_tvs -> + runZonkBndrT (zonkEvBndrsX evs) $ \ new_evs -> + runZonkBndrT (zonkTcEvBinds ev_binds) $ \ new_ev_binds -> + do { new_body_id <- zonkIdOcc body_id + ; return (EvFun { et_tvs = new_tvs, et_given = new_evs + , et_binds = new_ev_binds, et_body = new_body_id }) } + +zonkCoreExpr :: CoreExpr -> ZonkTcM CoreExpr +zonkCoreExpr (Var v) + | isCoVar v + = Coercion <$> zonkCoVarOcc v + | otherwise + = Var <$> zonkIdOcc v +zonkCoreExpr (Lit l) + = return $ Lit l +zonkCoreExpr (Coercion co) + = Coercion <$> zonkCoToCo co +zonkCoreExpr (Type ty) + = Type <$> zonkTcTypeToTypeX ty + +zonkCoreExpr (Cast e co) + = Cast <$> zonkCoreExpr e <*> zonkCoToCo co +zonkCoreExpr (Tick t e) + = Tick t <$> zonkCoreExpr e -- Do we need to zonk in ticks? + +zonkCoreExpr (App e1 e2) + = App <$> zonkCoreExpr e1 <*> zonkCoreExpr e2 +zonkCoreExpr (Lam v e) + = runZonkBndrT (zonkCoreBndrX v) $ \ v' -> + Lam v' <$> zonkCoreExpr e +zonkCoreExpr (Let bind e) + = runZonkBndrT (zonkCoreBind bind) $ \ bind' -> + Let bind' <$> zonkCoreExpr e +zonkCoreExpr (Case scrut b ty alts) + = do { scrut' <- zonkCoreExpr scrut + ; ty' <- zonkTcTypeToTypeX ty + ; runZonkBndrT (zonkIdBndrX b) $ \ b' -> + do { alts' <- mapM zonkCoreAlt alts + ; return $ Case scrut' b' ty' alts' } } + +zonkCoreAlt :: CoreAlt -> ZonkTcM CoreAlt +zonkCoreAlt (Alt dc bndrs rhs) + = runZonkBndrT (zonkCoreBndrsX bndrs) $ \ bndrs' -> + do { rhs' <- zonkCoreExpr rhs + ; return $ Alt dc bndrs' rhs' } + +zonkCoreBind :: CoreBind -> ZonkBndrTcM CoreBind +zonkCoreBind (NonRec v e) + = do { (v',e') <- noBinders $ zonkCorePair (v,e) + ; extendIdZonkEnv v' + ; return (NonRec v' e') } +zonkCoreBind (Rec pairs) + = do pairs' <- mfix go + return $ Rec pairs' + where + go new_pairs = do + extendIdZonkEnvRec (map fst new_pairs) + noBinders $ mapM zonkCorePair pairs + +zonkCorePair :: (CoreBndr, CoreExpr) -> ZonkTcM (CoreBndr, CoreExpr) +zonkCorePair (v,e) = + do { v' <- zonkIdBndr v + ; e' <- zonkCoreExpr e + ; return (v',e') } + +zonkEvTypeable :: EvTypeable -> ZonkTcM EvTypeable +zonkEvTypeable (EvTypeableTyCon tycon e) + = do { e' <- mapM zonkEvTerm e + ; return $ EvTypeableTyCon tycon e' } +zonkEvTypeable (EvTypeableTyApp t1 t2) + = do { t1' <- zonkEvTerm t1 + ; t2' <- zonkEvTerm t2 + ; return (EvTypeableTyApp t1' t2') } +zonkEvTypeable (EvTypeableTrFun tm t1 t2) + = do { tm' <- zonkEvTerm tm + ; t1' <- zonkEvTerm t1 + ; t2' <- zonkEvTerm t2 + ; return (EvTypeableTrFun tm' t1' t2') } +zonkEvTypeable (EvTypeableTyLit t1) + = do { t1' <- zonkEvTerm t1 + ; return (EvTypeableTyLit t1') } + +zonkTcEvBinds_s :: [TcEvBinds] -> ZonkBndrTcM [TcEvBinds] +zonkTcEvBinds_s bs = do { bs' <- traverse zonk_tc_ev_binds bs + ; return ([EvBinds (unionManyBags bs')]) } + +zonkTcEvBinds :: TcEvBinds -> ZonkBndrTcM TcEvBinds +zonkTcEvBinds bs = do { bs' <- zonk_tc_ev_binds bs + ; return (EvBinds bs') } + +zonk_tc_ev_binds :: TcEvBinds -> ZonkBndrTcM (Bag EvBind) +zonk_tc_ev_binds (TcEvBinds var) = zonkEvBindsVar var +zonk_tc_ev_binds (EvBinds bs) = zonkEvBinds bs + +zonkEvBindsVar :: EvBindsVar -> ZonkBndrTcM (Bag EvBind) +zonkEvBindsVar (EvBindsVar { ebv_binds = ref }) + = do { bs <- readTcRef ref + ; zonkEvBinds (evBindMapBinds bs) } +zonkEvBindsVar (CoEvBindsVar {}) = return emptyBag + +zonkEvBinds :: Bag EvBind -> ZonkBndrTcM (Bag EvBind) +zonkEvBinds binds + = {-# SCC "zonkEvBinds" #-} + mfix $ \ new_binds -> + do { extendIdZonkEnvRec (collect_ev_bndrs new_binds) + ; noBinders $ mapBagM zonkEvBind binds } + where + collect_ev_bndrs :: Bag EvBind -> [EvVar] + collect_ev_bndrs = foldr add [] + add (EvBind { eb_lhs = var }) vars = var : vars + +zonkEvBind :: EvBind -> ZonkTcM EvBind +zonkEvBind bind@(EvBind { eb_lhs = var, eb_rhs = term }) + = do { var' <- {-# SCC "zonkEvBndr" #-} zonkEvBndr var + + -- Optimise the common case of Refl coercions + -- See Note [Optimise coercion zonking] + -- This has a very big effect on some programs (eg #5030) + + ; term' <- case getEqPredTys_maybe (idType var') of + Just (r, ty1, ty2) | ty1 `eqType` ty2 + -> return (evCoercion (mkReflCo r ty1)) + _other -> zonkEvTerm term + + ; return (bind { eb_lhs = var', eb_rhs = term' }) } + +{- Note [Optimise coercion zonking] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When optimising evidence binds we may come across situations where +a coercion looks like + cv = ReflCo ty +or cv1 = cv2 +where the type 'ty' is big. In such cases it is a waste of time to zonk both + * The variable on the LHS + * The coercion on the RHS +Rather, we can zonk the variable, and if its type is (ty ~ ty), we can just +use Refl on the right, ignoring the actual coercion on the RHS. + +This can have a very big effect, because the constraint solver sometimes does go +to a lot of effort to prove Refl! (Eg when solving 10+3 = 10+3; cf #5030) +-} + +zonkTcMethInfoToMethInfoX :: TcMethInfo -> ZonkTcM MethInfo +zonkTcMethInfoToMethInfoX (name, ty, gdm_spec) + = do { ty' <- zonkTcTypeToTypeX ty + ; gdm_spec' <- zonk_gdm gdm_spec + ; return (name, ty', gdm_spec') } + where + zonk_gdm :: Maybe (DefMethSpec (SrcSpan, TcType)) + -> ZonkTcM (Maybe (DefMethSpec (SrcSpan, Type))) + zonk_gdm Nothing = return Nothing + zonk_gdm (Just VanillaDM) = return (Just VanillaDM) + zonk_gdm (Just (GenericDM (loc, ty))) + = do { ty' <- zonkTcTypeToTypeX ty + ; return (Just (GenericDM (loc, ty'))) } + +--------------------------------------- +{- Note [Zonking the LHS of a RULE] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +See also GHC.HsToCore.Binds Note [Free tyvars on rule LHS] + +We need to gather the type variables mentioned on the LHS so we can +quantify over them. Example: + 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)) and we do +not want to zap the unbound meta-tyvar 'alpha' to Any, because that +limits the applicability of the rule. Instead, we want to quantify +over it! + +We do this in two stages. + +* During zonking, we skolemise the TcTyVar 'alpha' to TyVar 'a'. We + do this by using zonkTvSkolemising as the UnboundTyVarZonker in the + ZonkEnv. (This is in fact the whole reason that the ZonkEnv has a + UnboundTyVarZonker.) + +* In GHC.HsToCore.Binds, we quantify over it. See GHC.HsToCore.Binds + Note [Free tyvars on rule LHS] + +Quantifying here is awkward because (a) the data type is big and (b) +finding the free type vars of an expression is necessarily monadic +operation. (consider /\a -> f @ b, where b is side-effected to a) +-} + diff --git a/GHC/ThToHs.hs b/GHC/ThToHs.hs --- a/GHC/ThToHs.hs +++ b/GHC/ThToHs.hs @@ -1,12 +1,9 @@ -{-# LANGUAGE BangPatterns #-} {-# LANGUAGE ConstrainedClassMethods #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE MultiWayIf #-} -{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE DerivingVia #-} {-# OPTIONS_GHC -Wno-incomplete-record-updates #-} @@ -27,11 +24,11 @@ ) where -import GHC.Prelude hiding (head, init, last, tail) +import GHC.Prelude hiding (init, last, tail) import GHC.Hs as Hs -import GHC.Builtin.Names 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,54 +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 @@ -109,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 () @@ -131,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] @@ -211,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'] } @@ -222,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) @@ -230,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' } @@ -246,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 @@ -276,16 +304,16 @@ cvtDec (NewtypeD ctxt tc tvs ksig constr derivs) = do { (ctxt', tc', tvs') <- cvt_tycl_hdr ctxt tc tvs ; ksig' <- cvtKind `traverse` ksig - ; con' <- cvtConstr cNameN constr + ; 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 = NewTypeCon con' + , dd_cons = con' , dd_derivs = derivs' } ; returnJustLA $ TyClD noExtField $ - DataDecl { tcdDExt = noAnn + DataDecl { tcdDExt = noExtField , tcdLName = tc', tcdTyVars = tvs' , tcdFixity = Prefix , tcdDataDefn = defn } } @@ -300,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) @@ -318,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' @@ -327,10 +355,10 @@ where overlap pragma = case pragma of - TH.Overlaps -> Hs.Overlaps (SourceText "OVERLAPS") - TH.Overlappable -> Hs.Overlappable (SourceText "OVERLAPPABLE") - TH.Overlapping -> Hs.Overlapping (SourceText "OVERLAPPING") - TH.Incoherent -> Hs.Incoherent (SourceText "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") @@ -348,13 +376,13 @@ cvtDec (DataInstD ctxt bndrs tys ksig constrs derivs) = do { (ctxt', tc', bndrs', typats') <- cvt_datainst_hdr ctxt bndrs tys ; ksig' <- cvtKind `traverse` ksig - ; cons' <- mapM (cvtConstr cNameN) constrs + ; 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' - , dd_cons = DataTypeCons False cons' + , dd_cons = cons' , dd_derivs = derivs' } ; returnJustLA $ InstD noExtField $ DataFamInstD @@ -370,13 +398,14 @@ cvtDec (NewtypeInstD ctxt bndrs tys ksig constr derivs) = do { (ctxt', tc', bndrs', typats') <- cvt_datainst_hdr ctxt bndrs tys ; ksig' <- cvtKind `traverse` ksig - ; con' <- cvtConstr cNameN constr + ; 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 = NewTypeCon con', dd_derivs = derivs' } + , dd_cons = con' + , dd_derivs = derivs' } ; returnJustLA $ InstD noExtField $ DataFamInstD { dfid_ext = noExtField , dfid_inst = DataFamInstDecl { dfid_eqn = @@ -419,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 } } @@ -438,10 +467,11 @@ ; 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 { sels' <- mapM (fmap (\ (L li i) -> FieldOcc noExtField (L li i)) . vNameN) sels + = do { let mk_fld = fldNameN (nameBase nm) + ; sels' <- mapM (fmap (\ (L li i) -> FieldOcc noExtField (L li i)) . mk_fld) sels ; vars' <- mapM (vNameN . mkNameS . nameBase) sels ; return $ Hs.RecCon $ zipWith RecordPatSynField sels' vars' } @@ -449,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 } @@ -465,7 +495,7 @@ = failWith InvalidImplicitParamBinding -- Convert a @data@ declaration. -cvtDataDec :: TH.Cxt -> TH.Name -> [TH.TyVarBndr ()] +cvtDataDec :: TH.Cxt -> TH.Name -> [TH.TyVarBndr TH.BndrVis] -> Maybe TH.Kind -> [TH.Con] -> [TH.DerivClause] -> CvtM (Maybe (LHsDecl GhcPs)) cvtDataDec = cvtGenDataDec False @@ -473,17 +503,39 @@ -- Convert a @type data@ declaration. -- These have neither contexts nor derived clauses. -- See Note [Type data declarations] in GHC.Rename.Module. -cvtTypeDataDec :: TH.Name -> [TH.TyVarBndr ()] -> Maybe TH.Kind -> [TH.Con] +cvtTypeDataDec :: TH.Name -> [TH.TyVarBndr TH.BndrVis] -> Maybe TH.Kind -> [TH.Con] -> CvtM (Maybe (LHsDecl GhcPs)) cvtTypeDataDec tc tvs ksig constrs = cvtGenDataDec True [] tc tvs ksig constrs [] -- Convert a @data@ or @type data@ declaration (flagged by the Bool arg). -- See Note [Type data declarations] in GHC.Rename.Module. -cvtGenDataDec :: Bool -> TH.Cxt -> TH.Name -> [TH.TyVarBndr ()] +cvtGenDataDec :: Bool -> TH.Cxt -> TH.Name -> [TH.TyVarBndr TH.BndrVis] -> Maybe TH.Kind -> [TH.Con] -> [TH.DerivClause] -> CvtM (Maybe (LHsDecl GhcPs)) cvtGenDataDec type_data ctxt tc tvs ksig constrs derivs + = do { (ctxt', tc', tvs') <- cvt_tycl_hdr ctxt tc tvs + ; ksig' <- cvtKind `traverse` ksig + ; cons' <- cvtDataDefnCons type_data ksig $ + DataTypeCons type_data constrs + ; derivs' <- cvtDerivs derivs + ; 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 = noExtField + , tcdLName = tc', tcdTyVars = tvs' + , tcdFixity = Prefix + , tcdDataDefn = defn } } + +-- Convert a set of data constructors. +cvtDataDefnCons :: + Bool -> Maybe TH.Kind -> + DataDefnCons TH.Con -> CvtM (DataDefnCons (LConDecl GhcPs)) +cvtDataDefnCons type_data ksig constrs = do { let isGadtCon (GadtC _ _ _) = True isGadtCon (RecGadtC _ _ _) = True isGadtCon (ForallC _ _ c) = isGadtCon c @@ -501,22 +553,17 @@ (failWith CannotMixGADTConsWith98Cons) ; unless (isNothing ksig || isGadtDecl) (failWith KindSigsOnlyAllowedOnGADTs) - ; (ctxt', tc', tvs') <- cvt_tycl_hdr ctxt tc tvs - ; ksig' <- cvtKind `traverse` ksig - ; cons' <- mapM (cvtConstr con_name) constrs - ; derivs' <- cvtDerivs derivs - ; let defn = HsDataDefn { dd_ext = noExtField - , dd_cType = Nothing - , dd_ctxt = mkHsContextMaybe ctxt' - , dd_kindSig = ksig' - , dd_cons = DataTypeCons type_data cons' - , dd_derivs = derivs' } - ; returnJustLA $ TyClD noExtField $ - DataDecl { tcdDExt = noAnn - , tcdLName = tc', tcdTyVars = tvs' - , tcdFixity = Prefix - , tcdDataDefn = defn } } + ; let first_datacon = + case firstDataDefnCon constrs of + Nothing -> panic "cvtDataDefnCons: empty list of constructors" + Just con -> con + first_datacon_name = + case get_cons_names first_datacon of + [] -> panic "cvtDataDefnCons: data constructor with no names" + c:_ -> c + ; mapM (cvtConstr first_datacon_name con_name) constrs } + ---------------- cvtTySynEqn :: TySynEqn -> CvtM (LTyFamInstEqn GhcPs) cvtTySynEqn (TySynEqn mb_bndrs lhs rhs) @@ -542,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 @@ -566,10 +613,10 @@ ; 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 ()] +cvt_tycl_hdr :: TH.Cxt -> TH.Name -> [TH.TyVarBndr TH.BndrVis] -> CvtM ( LHsContext GhcPs , LocatedN RdrName , LHsQTyVars GhcPs) @@ -584,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 @@ -597,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 } ---------------- @@ -650,41 +697,47 @@ -- Data types --------------------------------------------------- -cvtConstr :: (TH.Name -> CvtM (LocatedN RdrName)) -- ^ convert constructor name - -> TH.Con -> CvtM (LConDecl GhcPs) +cvtConstr :: TH.Name -- ^ name of first constructor of parent type + -> (TH.Name -> CvtM (LocatedN RdrName)) -- ^ convert constructor name + -> TH.Con -> CvtM (LConDecl GhcPs) -cvtConstr con_name (NormalC c strtys) - = do { c' <- con_name c +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 con_name (RecC c varstrtys) - = do { c' <- con_name c - ; args' <- mapM cvt_id_arg varstrtys +cvtConstr parent_con do_con_name (RecC c varstrtys) + = do { c' <- do_con_name c + ; args' <- mapM (cvt_id_arg parent_con) varstrtys ; con_decl <- wrapParLA (mkConDeclH98 noAnn c' Nothing Nothing . RecCon) args' ; returnLA con_decl } -cvtConstr con_name (InfixC st1 c st2) - = do { c' <- con_name c +cvtConstr _ do_con_name (InfixC st1 c st2) + = do { c' <- do_con_name c ; st1' <- cvt_arg st1 ; st2' <- cvt_arg st2 ; returnLA $ mkConDeclH98 noAnn c' Nothing Nothing - (InfixCon (hsLinear st1') (hsLinear st2')) } + (InfixCon st1' st2') } -cvtConstr con_name (ForallC tvs ctxt con) +cvtConstr parent_con do_con_name (ForallC tvs ctxt con) = do { tvs' <- cvtTvs tvs ; ctxt' <- cvtContext funPrec ctxt - ; L _ con' <- cvtConstr con_name con + ; L _ con' <- cvtConstr parent_con do_con_name con ; returnLA $ add_forall tvs' ctxt' con' } where add_cxt lcxt Nothing = mkHsContextMaybe lcxt 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' @@ -702,32 +755,32 @@ where all_tvs = tvs' ++ ex_tvs -cvtConstr con_name (GadtC c strtys ty) = case nonEmpty c of +cvtConstr _ do_con_name (GadtC c strtys ty) = case nonEmpty c of Nothing -> failWith GadtNoCons Just c -> do - { c' <- mapM con_name c + { 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 con_name (RecGadtC c varstrtys ty) = case nonEmpty c of +cvtConstr parent_con do_con_name (RecGadtC c varstrtys ty) = case nonEmpty c of Nothing -> failWith RecGadtNoCons Just c -> do - { c' <- mapM con_name c + { c' <- mapM do_con_name c ; ty' <- cvtType ty - ; rec_flds <- mapM cvt_id_arg varstrtys + ; 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 @@ -743,24 +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, TH.Bang, TH.Type) -> CvtM (LConDeclField GhcPs) -cvt_id_arg (i, str, ty) - = do { L li i' <- vNameN i +cvt_id_arg :: TH.Name -- ^ parent constructor name + -> (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 } @@ -777,21 +830,23 @@ 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 -> mk_imp (CImport (L l $ quotedSourceText from) (L l (cvt_conv callconv)) (L l safety') Nothing - (CFunction (StaticTarget (SourceText from) - (mkFastString from) Nothing + (CFunction (StaticTarget (SourceText fromtxt) + fromtxt Nothing 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 } where + fromtxt = mkFastString from mk_imp impspec = do { nm' <- vNameN nm ; ty' <- cvtSigType ty @@ -808,9 +863,11 @@ cvtForD (ExportF callconv as nm ty) = do { nm' <- vNameN nm ; ty' <- cvtSigType ty - ; l <- getL - ; let e = CExport (L l (SourceText as)) (L l (CExportStatic (SourceText as) - (mkFastString as) + ; ls <- getL + ; let l = l2l ls + ; let astxt = mkFastString as + ; let e = CExport (L l (SourceText astxt)) (L l (CExportStatic (SourceText astxt) + astxt (cvt_conv callconv))) ; return $ ForeignExport { fd_e_ext = noAnn , fd_name = nm' @@ -830,11 +887,14 @@ cvtPragmaD :: Pragma -> CvtM (Maybe (LHsDecl GhcPs)) cvtPragmaD (InlineP nm inline rm phases) - = do { nm' <- vNameN nm + = do { -- NB: Use vcNameN here, which works for both the variable namespace + -- (e.g., `INLINE`d functions) and the constructor namespace + -- (e.g., `INLINE`d pattern synonyms, cf. #23203) + nm' <- vcNameN nm ; let dflt = dfltActivation inline - ; let src TH.NoInline = "{-# NOINLINE" - src TH.Inline = "{-# INLINE" - src TH.Inlinable = "{-# INLINABLE" + ; let src TH.NoInline = fsLit "{-# NOINLINE" + src TH.Inline = fsLit "{-# INLINE" + src TH.Inlinable = fsLit "{-# INLINABLE" ; let ip = InlinePragma { inl_src = toSrcTxt inline , inl_inline = cvtInline inline (toSrcTxt inline) , inl_rule = cvtRuleMatch rm @@ -852,34 +912,24 @@ , inl_act = NeverActive , inl_sat = Nothing } where - srcTxt = SourceText "{-# OPAQUE" + 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 = "{-# SPECIALISE NOINLINE" - src TH.Inline = "{-# SPECIALISE INLINE" - src TH.Inlinable = "{-# SPECIALISE INLINE" - ; let (inline', dflt, srcText) = case inline of - Just inline1 -> (cvtInline inline1 (toSrcTxt inline1), dfltActivation inline1, - toSrcTxt inline1) - Nothing -> (NoUserInlinePrag, AlwaysActive, - SourceText "{-# 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 "{-# SPECIALISE")) ty' } + 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' @@ -892,12 +942,11 @@ 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 - $ HsRules { rds_ext = (noAnn, SourceText "{-# RULES") + $ HsRules { rds_ext = (noAnn, SourceText $ fsLit "{-# RULES") , rds_rules = [rule] } } @@ -913,7 +962,7 @@ n' <- vcName n wrapParLA ValueAnnProvenance n' ; returnJustLA $ Hs.AnnD noExtField - $ HsAnnotation (noAnn, (SourceText "{-# ANN")) target' exp' + $ HsAnnotation (noAnn, (SourceText $ fsLit "{-# ANN")) target' exp' } -- NB: This is the only place in GHC.ThToHs that makes use of the `setL` @@ -923,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 @@ -955,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 --------------------------------------------------- @@ -969,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 @@ -998,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)) @@ -1016,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 @@ -1028,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 @@ -1047,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' } @@ -1063,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' @@ -1077,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 @@ -1085,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 @@ -1111,25 +1182,49 @@ ; 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' (Left flds') } + ; return $ RecordUpd noAnn e' $ + RegularRecUpdFields + { xRecUpdFields = noExtField + , recUpdFields = flds' } } cvt (StaticE e) = fmap (HsStatic noAnn) $ cvtl e cvt (UnboundVarE s) = do -- Use of 'vcName' here instead of 'vName' is -- 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 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: @@ -1164,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' @@ -1182,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 @@ -1251,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 @@ -1282,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) } @@ -1291,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 @@ -1300,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 @@ -1374,10 +1473,12 @@ -- "GHC.ThToHs", hence panic quotedSourceText :: String -> SourceText -quotedSourceText s = SourceText $ "\"" ++ s ++ "\"" +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) @@ -1400,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 @@ -1430,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 @@ -1446,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 @@ -1490,6 +1598,10 @@ cvtFlag TH.SpecifiedSpec = Hs.SpecifiedSpec cvtFlag TH.InferredSpec = Hs.InferredSpec +instance CvtFlag TH.BndrVis (HsBndrVis GhcPs) where + 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 @@ -1497,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 @@ -1564,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 @@ -1601,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' } @@ -1616,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' } @@ -1667,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 @@ -1677,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 @@ -1693,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 @@ -1716,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' } @@ -1725,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)) @@ -1747,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. @@ -1758,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 @@ -1795,10 +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 l ki -> do p_ki <- add_parens ki - mk_apps (HsAppKindTy l phead_ty p_ki) args + HsTypeArg at ki -> + do p_ki <- add_parens ki + mk_apps (HsAppKindTy at phead_ty p_ki) args HsArgPar _ -> mk_apps (HsParTy noAnn phead_ty) args go type_args @@ -1809,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 @@ -1829,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. @@ -1841,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 noSrcSpan 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) @@ -1929,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 @@ -2028,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) @@ -2041,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 @@ -2053,6 +2177,13 @@ tconNameN n = wrapLN (tconName n) tconName n = cvtName OccName.tcClsName n +-- Field names +fldName :: String -> TH.Name -> CvtM RdrName +fldName con n = cvtName (OccName.fieldName $ fsLit con) n + +fldNameN :: String -> TH.Name -> CvtM (LocatedN RdrName) +fldNameN con n = wrapLN (fldName con n) + ipName :: String -> CvtM HsIPName ipName n = do { unless (okVarOcc n) (failWith (IllegalOccName OccName.varName n)) @@ -2063,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 @@ -2083,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; @@ -2099,51 +2231,124 @@ -- 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 guessed_nss - | isLexCon (mkFastString occ_str) = [OccName.tcName, OccName.dataName] - | otherwise = [OccName.varName, OccName.tvName] + | isLexCon occ_txt = [OccName.tcName, OccName.dataName] + | isLexVarSym occ_txt = [OccName.tcName, OccName.varName] -- #23525 + | otherwise = [OccName.varName, OccName.tvName] occ_str = TH.occString occ + occ_txt = mkFastString occ_str -- The packing and unpacking is rather turgid :-( mk_occ :: OccName.NameSpace -> String -> OccName.OccName mk_occ ns occ = OccName.mkOccName ns occ mk_ghc_ns :: TH.NameSpace -> OccName.NameSpace -mk_ghc_ns TH.DataName = OccName.dataName -mk_ghc_ns TH.TcClsName = OccName.tcClsName -mk_ghc_ns TH.VarName = OccName.varName +mk_ghc_ns TH.DataName = OccName.dataName +mk_ghc_ns TH.TcClsName = OccName.tcClsName +mk_ghc_ns TH.VarName = OccName.varName +mk_ghc_ns (TH.FldName con) = OccName.fieldName (fsLit con) mk_mod :: TH.ModName -> ModuleName mk_mod mod = mkModuleName (TH.modString mod) 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 -- @@ -7,33 +9,21 @@ module GHC.Types.Avail ( Avails, AvailInfo(..), - avail, - availField, - availTC, availsToNameSet, - availsToNameSetWithSelectors, availsToNameEnv, availExportsDecl, - availName, availGreName, - availNames, availNonFldNames, - availNamesWithSelectors, - availFlds, - availGreNames, - availSubordinateGreNames, + availName, + availNames, + availSubordinateNames, stableAvailCmp, plusAvail, trimAvail, filterAvail, filterAvails, nubAvails, - - GreName(..), - greNameMangledName, - greNamePrintableName, - greNameSrcSpan, - greNameFieldLabel, - partitionGreNames, - stableGreNameCmp, + sortAvails, + DetOrdAvails(DetOrdAvails, getDetOrdAvails, DefinitelyDeterministicAvails), + emptyDetOrdAvails ) where import GHC.Prelude @@ -41,9 +31,7 @@ import GHC.Types.Name import GHC.Types.Name.Env import GHC.Types.Name.Set -import GHC.Types.SrcLoc -import GHC.Types.FieldLabel import GHC.Utils.Binary import GHC.Data.List.SetOps import GHC.Utils.Outputable @@ -52,10 +40,8 @@ import Control.DeepSeq import Data.Data ( Data ) -import Data.Either ( partitionEithers ) import Data.Functor.Classes ( liftCompare ) -import Data.List ( find ) -import Data.Maybe +import Data.List ( find, sortBy ) import qualified Data.Semigroup as S -- ----------------------------------------------------------------------------- @@ -66,7 +52,7 @@ -- | An ordinary identifier in scope, or a field label without a parent type -- (see Note [Representing pattern synonym fields in AvailInfo]). - = Avail GreName + = Avail Name -- | A type or class in scope -- @@ -75,74 +61,49 @@ -- -- > AvailTC Eq [Eq, ==, \/=] | AvailTC - Name -- ^ The name of the type or class - [GreName] -- ^ The available pieces of type or class - -- (see Note [Representing fields in AvailInfo]). + Name -- ^ The name of the type or class + [Name] -- ^ The available pieces of type or class - deriving ( Eq -- ^ Used when deciding if the interface has changed - , Data ) + deriving Data -- | A collection of 'AvailInfo' - several things that are \"available\" type Avails = [AvailInfo] -{- -Note [Representing fields in AvailInfo] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -See also Note [FieldLabel] in GHC.Types.FieldLabel. - -When -XDuplicateRecordFields is disabled (the normal case), a -datatype like - - data T = MkT { foo :: Int } - -gives rise to the AvailInfo - - AvailTC T [T, MkT, FieldLabel "foo" NoDuplicateRecordFields FieldSelectors foo] - -whereas if -XDuplicateRecordFields is enabled it gives - - AvailTC T [T, MkT, FieldLabel "foo" DuplicateRecordFields FieldSelectors $sel:foo:MkT] - -where the label foo does not match the selector name $sel:foo:MkT. - -The labels in a field list are not necessarily unique: -data families allow the same parent (the family tycon) to have -multiple distinct fields with the same label. For example, - - data family F a - data instance F Int = MkFInt { foo :: Int } - data instance F Bool = MkFBool { foo :: Bool} - -gives rise to - - AvailTC F [ F, MkFInt, MkFBool - , FieldLabel "foo" DuplicateRecordFields FieldSelectors $sel:foo:MkFInt - , FieldLabel "foo" DuplicateRecordFields FieldSelectors $sel:foo:MkFBool ] - -Moreover, note that the flHasDuplicateRecordFields or flFieldSelectors flags -need not be the same for all the elements of the list. In the example above, -this occurs if the two data instances are defined in different modules, with -different states of the `-XDuplicateRecordFields` or `-XNoFieldSelectors` -extensions. Thus it is possible to have - - AvailTC F [ F, MkFInt, MkFBool - , FieldLabel "foo" DuplicateRecordFields FieldSelectors $sel:foo:MkFInt - , FieldLabel "foo" NoDuplicateRecordFields FieldSelectors foo ] +-- | 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) -If the two data instances are defined in different modules, both without -`-XDuplicateRecordFields` or `-XNoFieldSelectors`, it will be impossible to -export them from the same module (even with `-XDuplicateRecordfields` enabled), -because they would be represented identically. The workaround here is to enable -`-XDuplicateRecordFields` or `-XNoFieldSelectors` on the defining modules. See -also #13352. +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] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +{- Note [Representing pattern synonym fields in AvailInfo] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Record pattern synonym fields cannot be represented using AvailTC like fields of -normal record types (see Note [Representing fields in AvailInfo]), because they -do not always have a parent type constructor. So we represent them using the -Avail constructor, with a NormalGreName that carries the underlying FieldLabel. +normal record types, because they do not always have a parent type constructor. +So we represent them using the Avail constructor. Thus under -XDuplicateRecordFields -XPatternSynoynms, the declaration @@ -150,43 +111,22 @@ gives rise to the AvailInfo - Avail (NormalGreName MkFoo) - Avail (FieldGreName (FieldLabel "f" True $sel:f:MkFoo)) + Avail MkFoo, Avail f However, if `f` is bundled with a type constructor `T` by using `T(MkFoo,f)` in an export list, then whenever `f` is imported the parent will be `T`, represented as - AvailTC T [ NormalGreName T - , NormalGreName MkFoo - , FieldGreName (FieldLabel "f" True $sel:f:MkFoo) ] - -See also Note [GreNames] in GHC.Types.Name.Reader. + AvailTC T [ T, MkFoo, f ] -} -- | Compare lexicographically stableAvailCmp :: AvailInfo -> AvailInfo -> Ordering -stableAvailCmp (Avail c1) (Avail c2) = c1 `stableGreNameCmp` c2 +stableAvailCmp (Avail c1) (Avail c2) = c1 `stableNameCmp` c2 stableAvailCmp (Avail {}) (AvailTC {}) = LT -stableAvailCmp (AvailTC n ns) (AvailTC m ms) = stableNameCmp n m S.<> liftCompare stableGreNameCmp ns ms +stableAvailCmp (AvailTC n ns) (AvailTC m ms) = stableNameCmp n m S.<> liftCompare stableNameCmp ns ms stableAvailCmp (AvailTC {}) (Avail {}) = GT -stableGreNameCmp :: GreName -> GreName -> Ordering -stableGreNameCmp (NormalGreName n1) (NormalGreName n2) = n1 `stableNameCmp` n2 -stableGreNameCmp (NormalGreName {}) (FieldGreName {}) = LT -stableGreNameCmp (FieldGreName f1) (FieldGreName f2) = flSelector f1 `stableNameCmp` flSelector f2 -stableGreNameCmp (FieldGreName {}) (NormalGreName {}) = GT - -avail :: Name -> AvailInfo -avail n = Avail (NormalGreName n) - -availField :: FieldLabel -> AvailInfo -availField fl = Avail (FieldGreName fl) - -availTC :: Name -> [Name] -> [FieldLabel] -> AvailInfo -availTC n ns fls = AvailTC n (map NormalGreName ns ++ map FieldGreName fls) - - -- ----------------------------------------------------------------------------- -- Operations on AvailInfo @@ -194,10 +134,6 @@ availsToNameSet avails = foldr add emptyNameSet avails where add avail set = extendNameSetList set (availNames avail) -availsToNameSetWithSelectors :: [AvailInfo] -> NameSet -availsToNameSetWithSelectors avails = foldr add emptyNameSet avails - where add avail set = extendNameSetList set (availNamesWithSelectors avail) - availsToNameEnv :: [AvailInfo] -> NameEnv AvailInfo availsToNameEnv avails = foldr add emptyNameEnv avails where add avail env = extendNameEnvList env @@ -207,109 +143,42 @@ -- invariant that the parent is first if it appears at all. availExportsDecl :: AvailInfo -> Bool availExportsDecl (AvailTC ty_name names) - | n : _ <- names = NormalGreName ty_name == n + | n : _ <- names = ty_name == n | otherwise = False availExportsDecl _ = True -- | Just the main name made available, i.e. not the available pieces -- of type or class brought into scope by the 'AvailInfo' availName :: AvailInfo -> Name -availName (Avail n) = greNameMangledName n +availName (Avail n) = n availName (AvailTC n _) = n -availGreName :: AvailInfo -> GreName -availGreName (Avail c) = c -availGreName (AvailTC n _) = NormalGreName n - --- | All names made available by the availability information (excluding overloaded selectors) -availNames :: AvailInfo -> [Name] -availNames (Avail c) = childNonOverloadedNames c -availNames (AvailTC _ cs) = concatMap childNonOverloadedNames cs - -childNonOverloadedNames :: GreName -> [Name] -childNonOverloadedNames (NormalGreName n) = [n] -childNonOverloadedNames (FieldGreName fl) = [ flSelector fl | not (flIsOverloaded fl) ] - --- | All names made available by the availability information (including overloaded selectors) -availNamesWithSelectors :: AvailInfo -> [Name] -availNamesWithSelectors (Avail c) = [greNameMangledName c] -availNamesWithSelectors (AvailTC _ cs) = map greNameMangledName cs - --- | Names for non-fields made available by the availability information -availNonFldNames :: AvailInfo -> [Name] -availNonFldNames (Avail (NormalGreName n)) = [n] -availNonFldNames (Avail (FieldGreName {})) = [] -availNonFldNames (AvailTC _ ns) = mapMaybe f ns - where - f (NormalGreName n) = Just n - f (FieldGreName {}) = Nothing - --- | Fields made available by the availability information -availFlds :: AvailInfo -> [FieldLabel] -availFlds (Avail c) = maybeToList (greNameFieldLabel c) -availFlds (AvailTC _ cs) = mapMaybe greNameFieldLabel cs - -- | Names and fields made available by the availability information. -availGreNames :: AvailInfo -> [GreName] -availGreNames (Avail c) = [c] -availGreNames (AvailTC _ cs) = cs +availNames :: AvailInfo -> [Name] +availNames (Avail c) = [c] +availNames (AvailTC _ cs) = cs -- | Names and fields made available by the availability information, other than -- the main decl itself. -availSubordinateGreNames :: AvailInfo -> [GreName] -availSubordinateGreNames (Avail {}) = [] -availSubordinateGreNames avail@(AvailTC _ ns) +availSubordinateNames :: AvailInfo -> [Name] +availSubordinateNames (Avail {}) = [] +availSubordinateNames avail@(AvailTC _ ns) | availExportsDecl avail = tail ns | otherwise = ns - --- | Used where we may have an ordinary name or a record field label. --- See Note [GreNames] in GHC.Types.Name.Reader. -data GreName = NormalGreName Name - | FieldGreName FieldLabel - deriving (Data, Eq) - -instance Outputable GreName where - ppr (NormalGreName n) = ppr n - ppr (FieldGreName fl) = ppr fl - -instance NFData GreName where - rnf (NormalGreName n) = rnf n - rnf (FieldGreName f) = rnf f - -instance HasOccName GreName where - occName (NormalGreName n) = occName n - occName (FieldGreName fl) = occName fl - -instance Ord GreName where - compare = stableGreNameCmp - --- | A 'Name' for internal use, but not for output to the user. For fields, the --- 'OccName' will be the selector. See Note [GreNames] in GHC.Types.Name.Reader. -greNameMangledName :: GreName -> Name -greNameMangledName (NormalGreName n) = n -greNameMangledName (FieldGreName fl) = flSelector fl - --- | A 'Name' suitable for output to the user. For fields, the 'OccName' will --- be the field label. See Note [GreNames] in GHC.Types.Name.Reader. -greNamePrintableName :: GreName -> Name -greNamePrintableName (NormalGreName n) = n -greNamePrintableName (FieldGreName fl) = fieldLabelPrintableName fl - -greNameSrcSpan :: GreName -> SrcSpan -greNameSrcSpan (NormalGreName n) = nameSrcSpan n -greNameSrcSpan (FieldGreName fl) = nameSrcSpan (flSelector fl) - -greNameFieldLabel :: GreName -> Maybe FieldLabel -greNameFieldLabel (NormalGreName {}) = Nothing -greNameFieldLabel (FieldGreName fl) = Just fl - -partitionGreNames :: [GreName] -> ([Name], [FieldLabel]) -partitionGreNames = partitionEithers . map to_either +-- | Sort 'Avails'/'AvailInfo's +sortAvails :: Avails -> DetOrdAvails +sortAvails = DefinitelyDeterministicAvails . sortBy stableAvailCmp . map sort_subs where - to_either (NormalGreName n) = Left n - to_either (FieldGreName fl) = Right fl - + 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 @@ -322,7 +191,7 @@ plusAvail (AvailTC _ []) a2@(AvailTC {}) = a2 plusAvail a1@(AvailTC {}) (AvailTC _ []) = a1 plusAvail (AvailTC n1 (s1:ss1)) (AvailTC n2 (s2:ss2)) - = case (NormalGreName n1==s1, NormalGreName n2==s2) of -- Maintain invariant the parent is first + = case (n1 == s1, n2 == s2) of -- Maintain invariant the parent is first (True,True) -> AvailTC n1 (s1 : (ss1 `unionListsOrd` ss2)) (True,False) -> AvailTC n1 (s1 : (ss1 `unionListsOrd` (s2:ss2))) (False,True) -> AvailTC n1 (s2 : ((s1:ss1) `unionListsOrd` ss2)) @@ -332,7 +201,7 @@ -- | trims an 'AvailInfo' to keep only a single name trimAvail :: AvailInfo -> Name -> AvailInfo trimAvail avail@(Avail {}) _ = avail -trimAvail avail@(AvailTC n ns) m = case find ((== m) . greNameMangledName) ns of +trimAvail avail@(AvailTC n ns) m = case find (== m) ns of Just c -> AvailTC n [c] Nothing -> pprPanic "trimAvail" (hsep [ppr avail, ppr m]) @@ -344,10 +213,10 @@ filterAvail :: (Name -> Bool) -> AvailInfo -> [AvailInfo] -> [AvailInfo] filterAvail keep ie rest = case ie of - Avail c | keep (greNameMangledName c) -> ie : rest + Avail c | keep c -> ie : rest | otherwise -> rest AvailTC tc cs -> - let cs' = filter (keep . greNameMangledName) cs + let cs' = filter keep cs in if null cs' then rest else AvailTC tc cs' : rest @@ -355,7 +224,7 @@ -- 'avails' may have several items with the same availName -- E.g import Ix( Ix(..), index ) -- will give Ix(Ix,index,range) and Ix(index) --- We want to combine these; addAvail does that +-- We want to combine these; plusAvail does that nubAvails :: [AvailInfo] -> [AvailInfo] nubAvails avails = eltsDNameEnv (foldl' add emptyDNameEnv avails) where @@ -394,18 +263,6 @@ rnf (Avail n) = rnf n rnf (AvailTC a b) = rnf a `seq` rnf b -instance Binary GreName where - put_ bh (NormalGreName aa) = do - putByte bh 0 - put_ bh aa - put_ bh (FieldGreName ab) = do - putByte bh 1 - put_ bh ab - get bh = do - h <- getByte bh - case h of - 0 -> do aa <- get bh - return (NormalGreName aa) - _ -> do ab <- get bh - return (FieldGreName ab) - +-- | 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 @@ -16,9 +16,13 @@ {-# OPTIONS_GHC -Wno-orphans #-} -- Outputable PromotionFlag, Binary PromotionFlag, Outputable Boxity, Binay Boxity {-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE StandaloneDeriving #-} module GHC.Types.Basic ( LeftOrRight(..), @@ -26,7 +30,8 @@ ConTag, ConTagZ, fIRST_TAG, - Arity, RepArity, JoinArity, FullArgCount, + Arity, VisArity, RepArity, JoinArity, FullArgCount, + JoinPointHood(..), isJoinPoint, Alignment, mkAlignment, alignmentOf, alignmentBytes, @@ -34,14 +39,16 @@ FunctionOrData(..), RecFlag(..), isRec, isNonRec, boolToRecFlag, - Origin(..), isGenerated, + Origin(..), isGenerated, DoPmc(..), requiresPMC, + GenReason(..), isDoExpansionGenerated, doExpansionFlavour, + doExpansionOrigin, RuleName, pprRuleName, TopLevelFlag(..), isTopLevel, isNotTopLevel, OverlapFlag(..), OverlapMode(..), setOverlapModeMaybe, - hasOverlappingFlag, hasOverlappableFlag, hasIncoherentFlag, + hasOverlappingFlag, hasOverlappableFlag, hasIncoherentFlag, hasNonCanonicalFlag, Boxity(..), isBoxed, @@ -75,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, @@ -109,10 +116,14 @@ Levity(..), mightBeLifted, mightBeUnlifted, TypeOrConstraint(..), + TyConFlavour(..), TypeOrData(..), NewOrData(..), tyConFlavourAssoc_maybe, + NonStandardDefaultingStrategy(..), DefaultingStrategy(..), defaultNonStandardTyVars, - ForeignSrcLang (..) + ForeignSrcLang (..), + + ImportLevel(..), convImportLevel, convImportLevelSpec, allImportLevels ) where import GHC.Prelude @@ -124,19 +135,24 @@ import GHC.Utils.Binary import GHC.Types.SourceText import qualified GHC.LanguageExtensions as LangExt -import Data.Data -import qualified Data.Semigroup as Semi 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 +{- +************************************************************************ * * Binary choice * * ********************************************************************* -} data LeftOrRight = CLeft | CRight - deriving( Eq, Data ) + deriving( Eq, Data, Ord ) pickLR :: LeftOrRight -> (a,a) -> a pickLR CLeft (l,_) = l @@ -155,7 +171,12 @@ 0 -> return CLeft _ -> return CRight } +instance NFData LeftOrRight where + rnf CLeft = () + rnf CRight = () + + {- ************************************************************************ * * @@ -171,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 @@ -191,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. +-} + {- ************************************************************************ * * @@ -375,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" @@ -388,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 @@ -439,6 +538,10 @@ 1 -> return IsData _ -> panic "Binary FunctionOrData" +instance NFData FunctionOrData where + rnf IsFunction = () + rnf IsData = () + {- ************************************************************************ * * @@ -522,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 @@ -575,18 +683,90 @@ ************************************************************************ -} +-- | Was this piece of code user-written or generated by the compiler? +-- +-- See Note [Generated code and pattern-match checking]. data Origin = FromSource - | Generated + | Generated GenReason DoPmc deriving( Eq, Data ) isGenerated :: Origin -> Bool -isGenerated Generated = True -isGenerated FromSource = False +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 = text "Generated" + ppr FromSource = text "FromSource" + ppr (Generated reason pmc) = text "Generated" <+> ppr reason <+> ppr pmc +-- | Whether to run pattern-match checks in generated code. +-- +-- See Note [Generated code and pattern-match checking]. +data DoPmc = SkipPmc + | DoPmc + deriving( Eq, Data ) + +instance Outputable DoPmc where + ppr SkipPmc = text "SkipPmc" + ppr DoPmc = text "DoPmc" + +-- | Does this 'Origin' require us to run pattern-match checking, +-- or should we skip these checks? +-- +-- See Note [Generated code and pattern-match checking]. +requiresPMC :: Origin -> Bool +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 XXExprGhcRn mechanism described in Note [Rebindable syntax and XXExprGhcRn] + in GHC.Hs.Expr, + - the deriving mechanism. + +It is usually the case that we want to avoid generating error messages that +refer to generated code. The way this is handled is that we mark certain +parts of the AST as being generated (using the Origin datatype); this is then +used to set the tcl_in_gen_code flag in TcLclEnv, as explained in +Note [Error contexts in generated code] in GHC.Tc.Utils.Monad. + +Being in generated code is usually taken to mean we should also skip doing +pattern-match checking, but not always. For example, when desugaring a record +update (as described in Note [Record Updates] in GHC.Tc.Gen.Expr), we still want +to do pattern-match checking, in order to report incomplete record updates +(failing to do so lead to #23250). So, for a 'Generated' 'Origin', we keep track +of whether we should do pattern-match checks; see the calls of the requiresPMC +function (e.g. isMatchContextPmChecked and needToRunPmCheck in GHC.HsToCore.Pmc.Utils). +-} + {- ************************************************************************ * * @@ -599,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 @@ -620,6 +793,7 @@ hasIncoherentFlag mode = case mode of Incoherent _ -> True + NonCanonical _ -> True _ -> False hasOverlappableFlag :: OverlapMode -> Bool @@ -628,6 +802,7 @@ Overlappable _ -> True Overlaps _ -> True Incoherent _ -> True + NonCanonical _ -> True _ -> False hasOverlappingFlag :: OverlapMode -> Bool @@ -636,8 +811,14 @@ Overlapping _ -> True Overlaps _ -> True Incoherent _ -> True + NonCanonical _ -> True _ -> False +hasNonCanonicalFlag :: OverlapMode -> Bool +hasNonCanonicalFlag = \case + NonCanonical{} -> True + _ -> False + data OverlapMode -- See Note [Rules for instance lookup] in GHC.Core.InstEnv = NoOverlap SourceText -- See Note [Pragma source text] @@ -692,25 +873,48 @@ -- instantiating 'b' would change which instance -- was chosen. See also Note [Incoherent instances] in "GHC.Core.InstEnv" + | NonCanonical SourceText + -- ^ Behave like Incoherent, but the instance choice is observable + -- by the program behaviour. See Note [Coherence and specialisation: overview]. + -- + -- We don't have surface syntax for the distinction between + -- Incoherent and NonCanonical instances; instead, the flag + -- `-f{no-}specialise-incoherents` (on by default) controls + -- whether `INCOHERENT` instances are regarded as Incoherent or + -- NonCanonical. + deriving (Eq, Data) 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]" ppr (Overlapping _) = text "[overlapping]" ppr (Overlaps _) = text "[overlap ok]" 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 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 + put_ bh (NonCanonical s) = putByte bh 5 >> put_ bh s get bh = do h <- getByte bh case h of @@ -719,6 +923,7 @@ 2 -> (get bh) >>= \s -> return $ Incoherent s 3 -> (get bh) >>= \s -> return $ Overlapping s 4 -> (get bh) >>= \s -> return $ Overlappable s + 5 -> (get bh) >>= \s -> return $ NonCanonical s _ -> panic ("get OverlapMode" ++ show h) @@ -836,7 +1041,7 @@ = BoxedTuple | UnboxedTuple | ConstraintTuple - deriving( Eq, Data ) + deriving( Eq, Data, Ord ) instance Outputable TupleSort where ppr ts = text $ @@ -856,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 @@ -955,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 @@ -1060,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 @@ -1142,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. @@ -1387,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 @@ -1553,7 +1773,7 @@ defaultInlinePragma, alwaysInlinePragma, neverInlinePragma, dfunInlinePragma :: InlinePragma -defaultInlinePragma = InlinePragma { inl_src = SourceText "{-# INLINE" +defaultInlinePragma = InlinePragma { inl_src = SourceText $ fsLit "{-# INLINE" , inl_act = AlwaysActive , inl_rule = FunLike , inl_inline = NoUserInlinePrag @@ -1569,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 @@ -1674,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" @@ -1686,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 @@ -1720,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 @@ -1739,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. @@ -1831,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" @@ -1949,12 +2195,20 @@ data Levity = Lifted | Unlifted - deriving Eq + deriving (Data,Eq,Ord,Show) instance Outputable Levity where ppr Lifted = text "Lifted" ppr Unlifted = text "Unlifted" +instance Binary Levity where + put_ bh = \case + Lifted -> putByte bh 0 + Unlifted -> putByte bh 1 + get bh = getByte bh >>= \case + 0 -> pure Lifted + _ -> pure Unlifted + mightBeLifted :: Maybe Levity -> Bool mightBeLifted (Just Unlifted) = False mightBeLifted _ = True @@ -1967,9 +2221,98 @@ = 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 +* * +********************************************************************* -} + +-- | Paints a picture of what a 'TyCon' represents, in broad strokes. +-- This is used towards more informative error messages. +data TyConFlavour tc + = ClassFlavour + | TupleFlavour Boxity + | SumFlavour + | DataTypeFlavour + | NewtypeFlavour + | AbstractTypeFlavour + | OpenFamilyFlavour TypeOrData (Maybe tc) -- Just tc <=> (tc == associated class) + | ClosedTypeFamilyFlavour + | TypeSynonymFlavour + | BuiltInTypeFlavour -- ^ e.g., the @(->)@ 'TyCon'. + | PromotedDataConFlavour + deriving (Eq, Data, Functor) + +instance Outputable (TyConFlavour tc) where + ppr = text . go + where + go ClassFlavour = "class" + go (TupleFlavour boxed) | isBoxed boxed = "tuple" + | otherwise = "unboxed tuple" + go SumFlavour = "unboxed sum" + go DataTypeFlavour = "data type" + go NewtypeFlavour = "newtype" + go AbstractTypeFlavour = "abstract type" + go (OpenFamilyFlavour type_or_data mb_par) + = 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 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" + + +-- | Get the enclosing class TyCon (if there is one) for the given TyConFlavour +tyConFlavourAssoc_maybe :: TyConFlavour tc -> Maybe tc +tyConFlavourAssoc_maybe (OpenFamilyFlavour _ mb_parent) = mb_parent +tyConFlavourAssoc_maybe _ = Nothing + +-- | Whether something is a type or a data declaration, +-- e.g. a type family or a data family. +data TypeOrData + = 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 newOrData) = ppr newOrData + ppr IAmType = text "type" + +instance Outputable NewOrData where + ppr = \case + NewType -> text "newtype" + DataType -> text "data" + +{- ********************************************************************* +* * Defaulting options * * ********************************************************************* -} @@ -2047,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. -} @@ -2096,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 @@ -281,10 +283,8 @@ ppr = pprCostCentre pprCostCentre :: IsLine doc => CostCentre -> doc -pprCostCentre cc = docWithContext $ \ sty -> - if codeStyle (sdocStyle sty) - then ppCostCentreLbl cc - else ftext (costCentreUserNameFS cc) +pprCostCentre cc = docWithStyle (ppCostCentreLbl cc) + (\_ -> ftext (costCentreUserNameFS cc)) {-# SPECIALISE pprCostCentre :: CostCentre -> SDoc #-} {-# SPECIALISE pprCostCentre :: CostCentre -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable @@ -395,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, @@ -88,8 +91,7 @@ import GHC.Types.Basic import GHC.Data.Maybe ( orElse ) -import GHC.Core.Type ( Type ) -import GHC.Core.TyCon ( isNewTyCon, isClassTyCon ) +import GHC.Core.Type ( Type, isTerminatingType ) import GHC.Core.DataCon ( splitDataProductType_maybe, StrictnessMark, isMarkedStrict ) import GHC.Core.Multiplicity ( scaledThing ) @@ -97,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 @@ -542,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 @@ -552,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 @@ -605,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 @@ -929,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. @@ -964,15 +951,15 @@ strictManyApply1Dmd :: Demand strictManyApply1Dmd = C_1N :* mkCall C_1N topSubDmd --- | First argument of catch#: @MC(M,L)@. +-- | First argument of catch#: @MC(1,L)@. -- Evaluates its arg lazily, but then applies it exactly once to one argument. lazyApply1Dmd :: Demand -lazyApply1Dmd = C_01 :* mkCall C_01 topSubDmd +lazyApply1Dmd = C_01 :* mkCall C_11 topSubDmd --- | Second argument of catch#: @MC(M,C(1,L))@. --- Calls its arg lazily, but then applies it exactly once to an additional argument. +-- | Second argument of catch#: @MC(1,C(1,L))@. +-- Evaluates its arg lazily, but then applies it exactly once to two arguments. lazyApply2Dmd :: Demand -lazyApply2Dmd = C_01 :* mkCall C_01 (mkCall C_11 topSubDmd) +lazyApply2Dmd = C_01 :* mkCall C_11 (mkCall C_11 topSubDmd) -- | Make a 'Demand' evaluated at-most-once. oneifyDmd :: Demand -> Demand @@ -984,33 +971,31 @@ strictifyDmd :: Demand -> Demand strictifyDmd = plusDmd seqDmd --- | If the argument is a used non-newtype dictionary, give it strict demand. +-- | If the argument is a guaranteed-terminating type +-- (i.e. a non-newtype dictionary) give it strict demand. +-- This is sound because terminating types can't be bottom: +-- See GHC.Core Note [NON-BOTTOM-DICTS invariant] -- Also split the product type & demand and recur in order to similarly -- strictify the argument's contained used non-newtype superclass dictionaries. -- We use the demand as our recursive measure to guarantee termination. 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 - | Just (tycon, _arg_tys, _data_con, map scaledThing -> inst_con_arg_tys) - <- splitDataProductType_maybe ty - , not (isNewTyCon tycon) - , isClassTyCon tycon - = Just inst_con_arg_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 @@ -7,6 +7,8 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE TypeApplications #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE PatternSynonyms #-} module GHC.Types.Error ( -- * Messages @@ -19,6 +21,7 @@ , addMessage , unionMessages , unionManyMessages + , filterMessages , MsgEnvelope (..) -- * Classifying Messages @@ -27,14 +30,22 @@ , Severity (..) , Diagnostic (..) , UnknownDiagnostic (..) + , UnknownDiagnosticFor + , mkSimpleUnknownDiagnostic + , mkUnknownDiagnostic + , embedUnknownDiagnostic , DiagnosticMessage (..) - , DiagnosticReason (..) - , DiagnosticHint (..) + , DiagnosticReason (WarningWithFlag, ..) + , ResolvedDiagnosticReason(..) , mkPlainDiagnostic , mkPlainError , mkDecoratedDiagnostic , mkDecoratedError + , pprDiagnostic + + , HasDefaultDiagnosticOpts(..) + , defaultDiagnosticOpts , NoDiagnosticOpts(..) -- * Hints and refactoring actions @@ -89,21 +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.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 @@ -150,8 +166,14 @@ ppr msgs = braces (vcat (map ppr_one (bagToList (getMessages msgs)))) where ppr_one :: MsgEnvelope e -> SDoc - ppr_one envelope = pprDiagnostic (errMsgDiagnostic envelope) + ppr_one envelope = + vcat [ text "Resolved:" <+> ppr (errMsgReason envelope), + pprDiagnostic (errMsgDiagnostic envelope) + ] +instance (Diagnostic e) => ToJson (Messages e) where + json msgs = JSArray . toList $ json <$> getMessages msgs + {- Note [Discarding Messages] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -179,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 @@ -206,6 +232,16 @@ mapDecoratedSDoc f (Decorated s1) = Decorated (map f s1) +class HasDefaultDiagnosticOpts opts where + defaultOpts :: opts + + +defaultDiagnosticOpts :: forall opts . HasDefaultDiagnosticOpts (DiagnosticOpts opts) => DiagnosticOpts opts +defaultDiagnosticOpts = defaultOpts @(DiagnosticOpts opts) + + + + -- | A class identifying a diagnostic. -- Dictionary.com defines a diagnostic as: -- @@ -215,12 +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 Diagnostic a where +class (Outputable (DiagnosticHint a), HasDefaultDiagnosticOpts (DiagnosticOpts a)) => Diagnostic a where -- | Type of configuration options for the diagnostic. type DiagnosticOpts a - defaultDiagnosticOpts :: 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 @@ -230,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: @@ -247,36 +287,57 @@ diagnosticCode :: a -> Maybe DiagnosticCode -- | An existential wrapper around an unknown diagnostic. -data UnknownDiagnostic where - UnknownDiagnostic :: (DiagnosticOpts a ~ NoDiagnosticOpts, Diagnostic a, Typeable a) - => a -> UnknownDiagnostic +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 hint -instance Diagnostic UnknownDiagnostic where - type DiagnosticOpts UnknownDiagnostic = NoDiagnosticOpts - defaultDiagnosticOpts = NoDiagnosticOpts - diagnosticMessage _ (UnknownDiagnostic diag) = diagnosticMessage NoDiagnosticOpts 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 +-- 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 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 (DiagnosticHint a) +embedUnknownDiagnostic f = UnknownDiagnostic f id + +-------------------------------------------------------------------------------- + pprDiagnostic :: forall e . Diagnostic e => e -> SDoc pprDiagnostic e = vcat [ ppr (diagnosticReason e) , 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 @@ -287,7 +348,6 @@ instance Diagnostic DiagnosticMessage where type DiagnosticOpts DiagnosticMessage = NoDiagnosticOpts - defaultDiagnosticOpts = NoDiagnosticOpts diagnosticMessage _ = diagMessage diagnosticReason = diagReason diagnosticHints = diagHints @@ -328,18 +388,73 @@ data DiagnosticReason = WarningWithoutFlag -- ^ Born as a warning. - | WarningWithFlag !WarningFlag + | WarningWithFlags !(NE.NonEmpty WarningFlag) -- ^ Warning was enabled with the flag. + | WarningWithCategory !WarningCategory + -- ^ Warning was enabled with a custom category. | ErrorWithoutFlag -- ^ Born as an error. deriving (Eq, Show) +-- | Like a 'DiagnosticReason', but resolved against a specific set of `DynFlags` to +-- work out which warning flag actually enabled this warning. +newtype ResolvedDiagnosticReason + = ResolvedDiagnosticReason { resolvedDiagnosticReason :: DiagnosticReason } + +-- | The single warning case 'DiagnosticReason' is very common. +pattern WarningWithFlag :: WarningFlag -> DiagnosticReason +pattern WarningWithFlag w = WarningWithFlags (w :| []) + +{- 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 +apply. Where there are more than one, they are listed highest-priority first. + +For example, the same exported binding may give rise to a warning if either +`-Wmissing-signatures` or `-Wmissing-exported-signatures` is enabled. Here +`-Wmissing-signatures` has higher priority, because we want to mention it if +before are enabled. See `missingSignatureWarningFlags` for the specific logic +in this case. + +When reporting such a warning to the user, it is important to mention the +correct flag (e.g. `-Wmissing-signatures` if it is enabled, or +`-Wmissing-exported-signatures` if only the latter is enabled). Thus +`diag_reason_severity` filters the `DiagnosticReason` based on the currently +active `DiagOpts`. For a `WarningWithFlags` it returns only the flags that are +enabled; it leaves other `DiagnosticReason`s unchanged. This is then wrapped +in a `ResolvedDiagnosticReason` newtype which records that this filtering has +taken place. + +If we have `-Wmissing-signatures -Werror=missing-exported-signatures` we want +the error to mention `-Werror=missing-exported-signatures` (even though +`-Wmissing-signatures` would normally take precedence). Thus if there are any +fatal warnings, `diag_reason_severity` returns those alone. + +The `MsgEnvelope` stores the filtered `ResolvedDiagnosticReason` listing only the +relevant flags for subsequent display. + + +Side note: we do not treat `-Wmissing-signatures` as a warning group that +includes `-Wmissing-exported-signatures`, because + + (a) this would require us to provide a flag for the complement, and + + (b) currently, in `-Wmissing-exported-signatures -Wno-missing-signatures`, the + latter option does not switch off the former. +-} + instance Outputable DiagnosticReason where ppr = \case WarningWithoutFlag -> text "WarningWithoutFlag" - WarningWithFlag wf -> text ("WarningWithFlag " ++ show wf) + WarningWithFlags wf -> text ("WarningWithFlags " ++ show wf) + WarningWithCategory cat -> text "WarningWithCategory" <+> ppr cat ErrorWithoutFlag -> text "ErrorWithoutFlag" +instance Outputable ResolvedDiagnosticReason where + ppr = ppr . resolvedDiagnosticReason + -- | An envelope for GHC's facts about a running program, parameterised over the -- /domain-specific/ (i.e. parsing, typecheck-renaming, etc) diagnostics. -- @@ -354,6 +469,10 @@ , errMsgContext :: NamePprCtx , errMsgDiagnostic :: e , errMsgSeverity :: Severity + , errMsgReason :: ResolvedDiagnosticReason + -- ^ The actual reason caused this message + -- + -- See Note [Warnings controlled by multiple flags] } deriving (Functor, Foldable, Traversable) -- | The class for a diagnostic message. The main purpose is to classify a @@ -372,7 +491,7 @@ -- ^ Log messages intended for end users. -- No file\/line\/column stuff. - | MCDiagnostic Severity DiagnosticReason (Maybe DiagnosticCode) + | MCDiagnostic Severity ResolvedDiagnosticReason (Maybe DiagnosticCode) -- ^ Diagnostics from the compiler. This constructor is very powerful as -- it allows the construction of a 'MessageClass' with a completely -- arbitrary permutation of 'Severity' and 'DiagnosticReason'. As such, @@ -426,7 +545,7 @@ -- don't want to see. See Note [Suppressing Messages] | SevWarning | SevError - deriving (Eq, Show) + deriving (Eq, Ord, Show) instance Outputable Severity where ppr = \case @@ -435,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" @@ -446,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 @@ -494,12 +676,22 @@ warning_flag_doc = case msg_class of MCDiagnostic sev reason _code - | Just msg <- flag_msg sev reason -> brackets msg - _ -> empty + | Just msg <- flag_msg sev (resolvedDiagnosticReason reason) + -> 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 @@ -508,26 +700,32 @@ -- in a log file, e.g. with -ddump-tc-trace. It should not -- happen otherwise, though. flag_msg SevError WarningWithoutFlag = Just (col "-Werror") - flag_msg SevError (WarningWithFlag wflag) = + flag_msg SevError (WarningWithFlags (wflag :| _)) = let name = NE.head (warnFlagNames wflag) in - Just $ col ("-W" ++ name) <+> warn_flag_grp wflag + Just $ col ("-W" ++ name) <+> warn_flag_grp (smallestWarningGroups wflag) <> comma <+> col ("Werror=" ++ name) + flag_msg SevError (WarningWithCategory cat) = + Just $ coloured msg_colour (text "-W" <> ppr cat) + <+> warn_flag_grp smallestWarningGroupsForCategory + <> comma + <+> coloured msg_colour (text "-Werror=" <> ppr cat) flag_msg SevError ErrorWithoutFlag = Nothing flag_msg SevWarning WarningWithoutFlag = Nothing - flag_msg SevWarning (WarningWithFlag wflag) = + flag_msg SevWarning (WarningWithFlags (wflag :| _)) = let name = NE.head (warnFlagNames wflag) in - Just (col ("-W" ++ name) <+> warn_flag_grp wflag) + Just (col ("-W" ++ name) <+> warn_flag_grp (smallestWarningGroups wflag)) + flag_msg SevWarning (WarningWithCategory cat) = + Just (coloured msg_colour (text "-W" <> ppr cat) + <+> warn_flag_grp smallestWarningGroupsForCategory) flag_msg SevWarning ErrorWithoutFlag = pprPanic "SevWarning with ErrorWithoutFlag" $ vcat [ text "locn:" <+> ppr locn , text "msg:" <+> ppr msg ] - warn_flag_grp flag - | show_warn_groups = - case smallestWarningGroups flag of - [] -> empty - groups -> text $ "(in " ++ intercalate ", " (map ("-W"++) groups) ++ ")" + warn_flag_grp groups + | show_warn_groups, not (null groups) + = text $ "(in " ++ intercalate ", " (map (("-W"++) . warningGroupName) groups) ++ ")" | otherwise = empty -- Add prefixes, like Foo.hs:34: warning: @@ -645,7 +843,7 @@ -- | Returns 'True' if this is, intrinsically, a failure. See -- Note [Intrinsic And Extrinsic Failures]. isIntrinsicErrorMessage :: Diagnostic e => MsgEnvelope e -> Bool -isIntrinsicErrorMessage = (==) ErrorWithoutFlag . diagnosticReason . errMsgDiagnostic +isIntrinsicErrorMessage = (==) ErrorWithoutFlag . resolvedDiagnosticReason . errMsgReason isWarningMessage :: Diagnostic e => MsgEnvelope e -> Bool isWarningMessage = not . isIntrinsicErrorMessage @@ -695,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,28 +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 ) -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.Iface.Errors.Types 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.Tc.Utils.TcType ( IllegalForeignTypeReason, TypeCannotBeMarshaledReason ) 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, @@ -51,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, @@ -65,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. @@ -93,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. @@ -129,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 @@ -146,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 @@ -165,6 +260,7 @@ GhcDiagnosticCode "PsWarnUnrecognisedPragma" = 42044 GhcDiagnosticCode "PsWarnMisplacedPragma" = 28007 GhcDiagnosticCode "PsWarnImportPreQualified" = 07924 + GhcDiagnosticCode "PsWarnViewPatternSignatures" = 00834 GhcDiagnosticCode "PsErrLexer" = 21231 GhcDiagnosticCode "PsErrCmmLexer" = 75725 GhcDiagnosticCode "PsErrCmmParser" = 09848 @@ -199,6 +295,7 @@ GhcDiagnosticCode "PsErrUnallowedPragma" = 85314 GhcDiagnosticCode "PsErrImportPostQualified" = 87491 GhcDiagnosticCode "PsErrImportQualifiedTwice" = 05661 + GhcDiagnosticCode "PsErrSpliceOrQuoteTwice" = 26105 GhcDiagnosticCode "PsErrIllegalImportBundleForm" = 81284 GhcDiagnosticCode "PsErrInvalidRuleActivationMarker" = 50396 GhcDiagnosticCode "PsErrMissingBlock" = 16849 @@ -220,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 @@ -238,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 @@ -253,7 +351,6 @@ GhcDiagnosticCode "PsErrAtInPatPos" = 08382 GhcDiagnosticCode "PsErrParseErrorOnInput" = 66418 GhcDiagnosticCode "PsErrMalformedDecl" = 85316 - GhcDiagnosticCode "PsErrUnexpectedTypeAppInDecl" = 45054 GhcDiagnosticCode "PsErrNotADataCon" = 25742 GhcDiagnosticCode "PsErrInferredTypeVarNotAllowed" = 57342 GhcDiagnosticCode "PsErrIllegalTraditionalRecordSyntax" = 65719 @@ -268,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 @@ -294,24 +397,30 @@ GhcDiagnosticCode "DriverCannotImportFromUntrustedPackage" = 75165 GhcDiagnosticCode "DriverRedirectedNoMain" = 95379 GhcDiagnosticCode "DriverHomePackagesNotClosed" = 03271 + GhcDiagnosticCode "DriverInconsistentDynFlags" = 74335 + GhcDiagnosticCode "DriverSafeHaskellIgnoredExtension" = 98887 + 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 GhcDiagnosticCode "UserTypeError" = 64725 + GhcDiagnosticCode "UnsatisfiableError" = 22250 GhcDiagnosticCode "ReportHoleError" = 88464 - GhcDiagnosticCode "UntouchableVariable" = 34699 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 @@ -323,12 +432,13 @@ GhcDiagnosticCode "RepresentationalEq" = 10283 -- Typechecker/renamer diagnostic codes + GhcDiagnosticCode "TcRnSolverDepthError" = 40404 GhcDiagnosticCode "TcRnRedundantConstraints" = 30606 GhcDiagnosticCode "TcRnInaccessibleCode" = 40564 + GhcDiagnosticCode "TcRnInaccessibleCoAxBranch" = 28129 GhcDiagnosticCode "TcRnTypeDoesNotHaveFixedRuntimeRep" = 18478 GhcDiagnosticCode "TcRnImplicitLift" = 00846 GhcDiagnosticCode "TcRnUnusedPatternBinds" = 61367 - GhcDiagnosticCode "TcRnDodgyImports" = 99623 GhcDiagnosticCode "TcRnDodgyExports" = 75356 GhcDiagnosticCode "TcRnMissingImportList" = 77037 GhcDiagnosticCode "TcRnUnsafeDueToPlugin" = 01687 @@ -336,6 +446,7 @@ GhcDiagnosticCode "TcRnIdNotExportedFromModuleSig" = 44188 GhcDiagnosticCode "TcRnIdNotExportedFromLocalSig" = 50058 GhcDiagnosticCode "TcRnShadowedName" = 63397 + GhcDiagnosticCode "TcRnInvalidWarningCategory" = 53573 GhcDiagnosticCode "TcRnDuplicateWarningDecls" = 00711 GhcDiagnosticCode "TcRnSimplifierTooManyIterations" = 95822 GhcDiagnosticCode "TcRnIllegalPatSynDecl" = 82077 @@ -344,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 @@ -356,7 +470,7 @@ GhcDiagnosticCode "TcRnTagToEnumResTyNotAnEnum" = 49356 GhcDiagnosticCode "TcRnTagToEnumResTyTypeData" = 96189 GhcDiagnosticCode "TcRnArrowIfThenElsePredDependsOnResultTy" = 55868 - GhcDiagnosticCode "TcRnIllegalHsBootFileDecl" = 58195 + GhcDiagnosticCode "TcRnIllegalHsBootOrSigDecl" = 58195 GhcDiagnosticCode "TcRnRecursivePatternSynonym" = 72489 GhcDiagnosticCode "TcRnPartialTypeSigTyVarMismatch" = 88793 GhcDiagnosticCode "TcRnPartialTypeSigBadQuantifier" = 94185 @@ -364,8 +478,6 @@ GhcDiagnosticCode "TcRnPolymorphicBinderMissingSig" = 64414 GhcDiagnosticCode "TcRnOverloadedSig" = 16675 GhcDiagnosticCode "TcRnTupleConstraintInst" = 69012 - GhcDiagnosticCode "TcRnAbstractClassInst" = 51758 - GhcDiagnosticCode "TcRnNoClassInstHead" = 56538 GhcDiagnosticCode "TcRnUserTypeError" = 47403 GhcDiagnosticCode "TcRnConstraintInKind" = 01259 GhcDiagnosticCode "TcRnUnboxedTupleOrSumTypeFuncArg" = 19590 @@ -377,9 +489,7 @@ GhcDiagnosticCode "TcRnNonTypeVarArgInConstraint" = 80003 GhcDiagnosticCode "TcRnIllegalImplicitParam" = 75863 GhcDiagnosticCode "TcRnIllegalConstraintSynonymOfKind" = 75844 - GhcDiagnosticCode "TcRnIllegalClassInst" = 53946 GhcDiagnosticCode "TcRnOversaturatedVisibleKindArg" = 45474 - GhcDiagnosticCode "TcRnBadAssociatedType" = 38351 GhcDiagnosticCode "TcRnForAllRankErr" = 91510 GhcDiagnosticCode "TcRnMonomorphicBindings" = 55524 GhcDiagnosticCode "TcRnOrphanInstance" = 90177 @@ -389,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 @@ -398,26 +506,25 @@ 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 "TcRnAmbiguousField" = 02256 + GhcDiagnosticCode "TcRnDuplicateFieldExport" = 97219 + GhcDiagnosticCode "TcRnAmbiguousFieldInUpdate" = 56428 + GhcDiagnosticCode "TcRnAmbiguousRecordUpdate" = 02256 GhcDiagnosticCode "TcRnMissingFields" = 20125 GhcDiagnosticCode "TcRnFieldUpdateInvalidType" = 63055 - GhcDiagnosticCode "TcRnNoConstructorHasAllFields" = 14392 - GhcDiagnosticCode "TcRnMixedSelectors" = 40887 GhcDiagnosticCode "TcRnMissingStrictFields" = 95909 - GhcDiagnosticCode "TcRnNoPossibleParentForFields" = 33238 - GhcDiagnosticCode "TcRnBadOverloadedRecordUpdate" = 99339 GhcDiagnosticCode "TcRnStaticFormNotClosed" = 88431 + GhcDiagnosticCode "TcRnIllegalStaticExpression" = 23800 GhcDiagnosticCode "TcRnUselessTypeable" = 90584 GhcDiagnosticCode "TcRnDerivingDefaults" = 20042 GhcDiagnosticCode "TcRnNonUnaryTypeclassConstraint" = 73993 GhcDiagnosticCode "TcRnPartialTypeSignatures" = 60661 GhcDiagnosticCode "TcRnLazyGADTPattern" = 87005 GhcDiagnosticCode "TcRnArrowProcGADTPattern" = 64525 - GhcDiagnosticCode "TcRnSpecialClassInst" = 97044 - GhcDiagnosticCode "TcRnForallIdentifier" = 64088 GhcDiagnosticCode "TcRnTypeEqualityOutOfScope" = 12003 GhcDiagnosticCode "TcRnTypeEqualityRequiresOperators" = 58520 GhcDiagnosticCode "TcRnIllegalTypeOperator" = 62547 @@ -425,18 +532,20 @@ GhcDiagnosticCode "TcRnIncorrectNameSpace" = 31891 GhcDiagnosticCode "TcRnNoRebindableSyntaxRecordDot" = 65945 GhcDiagnosticCode "TcRnNoFieldPunsRecordDot" = 57365 - GhcDiagnosticCode "TcRnIllegalStaticExpression" = 23800 - GhcDiagnosticCode "TcRnIllegalStaticFormInSplice" = 12219 GhcDiagnosticCode "TcRnListComprehensionDuplicateBinding" = 81232 GhcDiagnosticCode "TcRnLastStmtNotExpr" = 55814 GhcDiagnosticCode "TcRnUnexpectedStatementInContext" = 42026 GhcDiagnosticCode "TcRnSectionWithoutParentheses" = 95880 GhcDiagnosticCode "TcRnIllegalImplicitParameterBindings" = 50730 GhcDiagnosticCode "TcRnIllegalTupleSection" = 59155 + GhcDiagnosticCode "TcRnTermNameInType" = 37479 + GhcDiagnosticCode "TcRnUnexpectedKindVar" = 12875 + GhcDiagnosticCode "TcRnNegativeNumTypeLiteral" = 93632 + GhcDiagnosticCode "TcRnUnusedQuantifiedTypeVar" = 54180 + GhcDiagnosticCode "TcRnMissingRoleAnnotation" = 65490 GhcDiagnosticCode "TcRnUntickedPromotedThing" = 49957 GhcDiagnosticCode "TcRnIllegalBuiltinSyntax" = 39716 - GhcDiagnosticCode "TcRnWarnDefaulting" = 18042 GhcDiagnosticCode "TcRnForeignImportPrimExtNotSet" = 49692 GhcDiagnosticCode "TcRnForeignImportPrimSafeAnn" = 26133 GhcDiagnosticCode "TcRnForeignFunctionImportAsValue" = 76251 @@ -445,65 +554,192 @@ GhcDiagnosticCode "TcRnUnsupportedCallConv" = 01245 GhcDiagnosticCode "TcRnInvalidCIdentifier" = 95774 GhcDiagnosticCode "TcRnExpectedValueId" = 01570 - GhcDiagnosticCode "TcRnNotARecordSelector" = 47535 GhcDiagnosticCode "TcRnRecSelectorEscapedTyVar" = 55876 GhcDiagnosticCode "TcRnPatSynNotBidirectional" = 16444 - GhcDiagnosticCode "TcRnSplicePolymorphicLocalVar" = 06568 GhcDiagnosticCode "TcRnIllegalDerivingItem" = 11913 GhcDiagnosticCode "TcRnUnexpectedAnnotation" = 18932 GhcDiagnosticCode "TcRnIllegalRecordSyntax" = 89246 - GhcDiagnosticCode "TcRnUnexpectedTypeSplice" = 39180 GhcDiagnosticCode "TcRnInvalidVisibleKindArgument" = 20967 GhcDiagnosticCode "TcRnTooManyBinders" = 05989 GhcDiagnosticCode "TcRnDifferentNamesForTyVar" = 17370 GhcDiagnosticCode "TcRnDisconnectedTyVar" = 59738 GhcDiagnosticCode "TcRnInvalidReturnKind" = 55233 GhcDiagnosticCode "TcRnClassKindNotConstraint" = 80768 - GhcDiagnosticCode "TcRnUnpromotableThing" = 88634 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 GhcDiagnosticCode "TcRnSpecialiseNotVisible" = 85337 + GhcDiagnosticCode "TcRnDifferentExportWarnings" = 92878 + GhcDiagnosticCode "TcRnIncompleteExportWarnings" = 94721 GhcDiagnosticCode "TcRnIllegalTypeOperatorDecl" = 50649 - GhcDiagnosticCode "TcRnNameByTemplateHaskellQuote" = 40027 - GhcDiagnosticCode "TcRnIllegalBindingOfBuiltIn" = 69639 + GhcDiagnosticCode "TcRnOrPatBindsVariables" = 81303 + GhcDiagnosticCode "TcRnIllegalKind" = 64861 + GhcDiagnosticCode "TcRnUnexpectedPatSigType" = 74097 + GhcDiagnosticCode "TcRnIllegalKindSignature" = 91382 + GhcDiagnosticCode "TcRnDataKindsError" = 68567 GhcDiagnosticCode "TcRnIllegalHsigDefaultMethods" = 93006 + GhcDiagnosticCode "TcRnHsigFixityMismatch" = 93007 + GhcDiagnosticCode "TcRnHsigMissingModuleExport" = 93011 GhcDiagnosticCode "TcRnBadGenericMethod" = 59794 GhcDiagnosticCode "TcRnWarningMinimalDefIncomplete" = 13511 GhcDiagnosticCode "TcRnDefaultMethodForPragmaLacksBinding" = 28587 GhcDiagnosticCode "TcRnIgnoreSpecialisePragmaOnDefMethod" = 72520 GhcDiagnosticCode "TcRnBadMethodErr" = 46284 - GhcDiagnosticCode "TcRnNoExplicitAssocTypeOrDefaultDeclaration" = 08585 GhcDiagnosticCode "TcRnIllegalTypeData" = 15013 GhcDiagnosticCode "TcRnTypeDataForbids" = 67297 - GhcDiagnosticCode "TcRnTypedTHWithPolyType" = 94642 - GhcDiagnosticCode "TcRnSpliceThrewException" = 87897 - GhcDiagnosticCode "TcRnInvalidTopDecl" = 52886 - GhcDiagnosticCode "TcRnNonExactName" = 77923 - GhcDiagnosticCode "TcRnAddInvalidCorePlugin" = 86463 - GhcDiagnosticCode "TcRnAddDocToNonLocalDefn" = 67760 - GhcDiagnosticCode "TcRnFailedToLookupThInstName" = 49530 - GhcDiagnosticCode "TcRnCannotReifyInstance" = 30384 - GhcDiagnosticCode "TcRnCannotReifyOutOfScopeThing" = 24922 - GhcDiagnosticCode "TcRnCannotReifyThingNotInTypeEnv" = 79890 - GhcDiagnosticCode "TcRnNoRolesAssociatedWithThing" = 65923 - GhcDiagnosticCode "TcRnCannotRepresentType" = 75721 - GhcDiagnosticCode "TcRnReportCustomQuasiError" = 39584 - GhcDiagnosticCode "TcRnInterfaceLookupError" = 52243 GhcDiagnosticCode "TcRnUnsatisfiedMinimalDef" = 06201 GhcDiagnosticCode "TcRnMisplacedInstSig" = 06202 - GhcDiagnosticCode "TcRnBadBootFamInstDecl" = 06203 - GhcDiagnosticCode "TcRnIllegalFamilyInstance" = 06204 - GhcDiagnosticCode "TcRnMissingClassAssoc" = 06205 - GhcDiagnosticCode "TcRnBadFamInstDecl" = 06206 - GhcDiagnosticCode "TcRnNotOpenFamily" = 06207 - GhcDiagnosticCode "TcRnLoopySuperclassSolve" = 36038 + GhcDiagnosticCode "TcRnCapturedTermName" = 54201 + GhcDiagnosticCode "TcRnBindingOfExistingName" = 58805 + GhcDiagnosticCode "TcRnMultipleFixityDecls" = 50419 + GhcDiagnosticCode "TcRnIllegalPatternSynonymDecl" = 41507 + GhcDiagnosticCode "TcRnIllegalClassBinding" = 69248 + GhcDiagnosticCode "TcRnOrphanCompletePragma" = 93961 + GhcDiagnosticCode "TcRnEmptyCase" = 48010 + GhcDiagnosticCode "TcRnNonStdGuards" = 59119 + GhcDiagnosticCode "TcRnDuplicateSigDecl" = 31744 + GhcDiagnosticCode "TcRnMisplacedSigDecl" = 87866 + GhcDiagnosticCode "TcRnUnexpectedDefaultSig" = 40700 + GhcDiagnosticCode "TcRnDuplicateMinimalSig" = 85346 + 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 + GhcDiagnosticCode "TcRnIllegalMultipleDerivClauses" = 30281 + GhcDiagnosticCode "TcRnNoDerivStratSpecified" = 55631 + GhcDiagnosticCode "TcRnStupidThetaInGadt" = 18403 + GhcDiagnosticCode "TcRnShadowedTyVarNameInFamResult" = 99412 + GhcDiagnosticCode "TcRnIncorrectTyVarOnLhsOfInjCond" = 88333 + GhcDiagnosticCode "TcRnUnknownTyVarsOnRhsOfInjCond" = 48254 + GhcDiagnosticCode "TcRnBadlyLevelled" = 28914 + GhcDiagnosticCode "TcRnBadlyLevelledType" = 86357 + GhcDiagnosticCode "TcRnStageRestriction" = Outdated 18157 + GhcDiagnosticCode "TcRnTyThingUsedWrong" = 10969 + GhcDiagnosticCode "TcRnCannotDefaultKindVar" = 79924 + GhcDiagnosticCode "TcRnUninferrableTyVar" = 16220 + GhcDiagnosticCode "TcRnSkolemEscape" = 71451 + GhcDiagnosticCode "TcRnPatSynEscapedCoercion" = 88986 + GhcDiagnosticCode "TcRnPatSynExistentialInResult" = 33973 + GhcDiagnosticCode "TcRnPatSynArityMismatch" = 18365 + GhcDiagnosticCode "TcRnTyFamDepsDisabled" = 43991 + GhcDiagnosticCode "TcRnAbstractClosedTyFamDecl" = 60012 + GhcDiagnosticCode "TcRnPartialFieldSelector" = 82712 + GhcDiagnosticCode "TcRnHasFieldResolvedIncomplete" = 86894 + GhcDiagnosticCode "TcRnSuperclassCycle" = 29210 + GhcDiagnosticCode "TcRnDefaultSigMismatch" = 72771 + GhcDiagnosticCode "TcRnTyFamResultDisabled" = 44012 + GhcDiagnosticCode "TcRnCommonFieldResultTypeMismatch" = 31004 + GhcDiagnosticCode "TcRnCommonFieldTypeMismatch" = 91827 + GhcDiagnosticCode "TcRnDataConParentTypeMismatch" = 45219 + GhcDiagnosticCode "TcRnGADTsDisabled" = 23894 + GhcDiagnosticCode "TcRnExistentialQuantificationDisabled" = 25709 + GhcDiagnosticCode "TcRnGADTDataContext" = 61072 + GhcDiagnosticCode "TcRnMultipleConForNewtype" = 16409 + GhcDiagnosticCode "TcRnKindSignaturesDisabled" = 49378 + GhcDiagnosticCode "TcRnEmptyDataDeclsDisabled" = 32478 + GhcDiagnosticCode "TcRnRoleMismatch" = 29178 + GhcDiagnosticCode "TcRnRoleCountMismatch" = 54298 + GhcDiagnosticCode "TcRnIllegalRoleAnnotation" = 77192 + GhcDiagnosticCode "TcRnRoleAnnotationsDisabled" = 17779 + GhcDiagnosticCode "TcRnIncoherentRoles" = 18273 + GhcDiagnosticCode "TcRnTypeSynonymCycle" = 97522 + GhcDiagnosticCode "TcRnSelfImport" = 43281 + GhcDiagnosticCode "TcRnNoExplicitImportList" = 16029 + GhcDiagnosticCode "TcRnSafeImportsDisabled" = 26971 + GhcDiagnosticCode "TcRnDeprecatedModule" = 15328 + GhcDiagnosticCode "TcRnCompatUnqualifiedImport" = Outdated 82347 + GhcDiagnosticCode "TcRnRedundantSourceImport" = 54478 + GhcDiagnosticCode "TcRnDuplicateDecls" = 29916 + GhcDiagnosticCode "TcRnPackageImportsDisabled" = 10032 + GhcDiagnosticCode "TcRnIllegalDataCon" = 78448 + GhcDiagnosticCode "TcRnNestedForallsContexts" = 71492 + GhcDiagnosticCode "TcRnRedundantRecordWildcard" = 15932 + GhcDiagnosticCode "TcRnUnusedRecordWildcard" = 83475 + GhcDiagnosticCode "TcRnUnusedName" = 40910 + GhcDiagnosticCode "TcRnQualifiedBinder" = 28329 + GhcDiagnosticCode "TcRnInvalidRecordField" = 53822 + GhcDiagnosticCode "TcRnTupleTooLarge" = 94803 + GhcDiagnosticCode "TcRnCTupleTooLarge" = 89347 + GhcDiagnosticCode "TcRnIllegalInferredTyVars" = 54832 + GhcDiagnosticCode "TcRnAmbiguousName" = 87543 + GhcDiagnosticCode "TcRnBindingNameConflict" = 10498 + GhcDiagnosticCode "NonCanonicalMonoid" = 50928 + GhcDiagnosticCode "NonCanonicalMonad" = 22705 + GhcDiagnosticCode "TcRnDefaultedExceptionContext" = 46235 + GhcDiagnosticCode "TcRnImplicitImportOfPrelude" = 20540 + GhcDiagnosticCode "TcRnMissingMain" = 67120 + GhcDiagnosticCode "TcRnGhciUnliftedBind" = 17999 + GhcDiagnosticCode "TcRnGhciMonadLookupFail" = 44990 + GhcDiagnosticCode "TcRnArityMismatch" = 27346 + GhcDiagnosticCode "TcRnSimplifiableConstraint" = 62412 + GhcDiagnosticCode "TcRnIllegalQuasiQuotes" = 77343 + GhcDiagnosticCode "TcRnImplicitRhsQuantification" = 16382 + GhcDiagnosticCode "TcRnBadTyConTelescope" = 87279 + GhcDiagnosticCode "TcRnPatersonCondFailure" = 22979 + 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 + -- TcRnIllegalInvisibleTypePattern + GhcDiagnosticCode "InvisPatWithoutFlag" = 78249 + GhcDiagnosticCode "InvisPatNoForall" = 14964 + GhcDiagnosticCode "InvisPatMisplaced" = 11983 + + -- PatSynInvalidRhsReason + GhcDiagnosticCode "PatSynNotInvertible" = 69317 + GhcDiagnosticCode "PatSynUnboundVar" = 28572 + + -- TcRnBadFieldAnnotation/BadFieldAnnotationReason + GhcDiagnosticCode "LazyFieldsDisabled" = 81601 + GhcDiagnosticCode "UnpackWithoutStrictness" = 10107 + GhcDiagnosticCode "UnusableUnpackPragma" = 40091 + + -- TcRnRoleValidationFailed/RoleInferenceFailedReason + GhcDiagnosticCode "TyVarRoleMismatch" = 22221 + GhcDiagnosticCode "TyVarMissingInEnv" = 99991 + GhcDiagnosticCode "BadCoercionRole" = 92834 + + -- TcRnClassExtensionDisabled/DisabledClassExtension + GhcDiagnosticCode "MultiParamDisabled" = 28349 + GhcDiagnosticCode "FunDepsDisabled" = 15708 + GhcDiagnosticCode "ConstrainedClassMethodsDisabled" = 25079 + + -- TcRnTyFamsDisabled/TyFamsDisabledReason + GhcDiagnosticCode "TyFamsDisabledFamily" = 39191 + GhcDiagnosticCode "TyFamsDisabledInstance" = 06206 + GhcDiagnosticCode "TcRnPrecedenceParsingError" = 88747 + GhcDiagnosticCode "TcRnSectionPrecedenceError" = 46878 + + -- HsigShapeMismatchReason + GhcDiagnosticCode "HsigShapeSortMismatch" = 93008 + GhcDiagnosticCode "HsigShapeNotUnifiable" = 93009 + + -- Invisible binders + GhcDiagnosticCode "TcRnIllegalInvisTyVarBndr" = 58589 + GhcDiagnosticCode "TcRnIllegalWildcardTyVarBndr" = 12211 + GhcDiagnosticCode "TcRnInvalidInvisTyVarBndr" = 57916 + GhcDiagnosticCode "TcRnInvisBndrWithoutSig" = 92337 + -- IllegalNewtypeReason GhcDiagnosticCode "DoesNotHaveSingleField" = 23517 GhcDiagnosticCode "IsNonLinear" = 38291 @@ -512,6 +748,20 @@ GhcDiagnosticCode "HasExistentialTyVar" = 07525 GhcDiagnosticCode "HasStrictnessAnnotation" = 04049 + -- TcRnBadRecordUpdate + GhcDiagnosticCode "NoConstructorHasAllFields" = 14392 + GhcDiagnosticCode "MultiplePossibleParents" = 99339 + GhcDiagnosticCode "InvalidTyConParent" = 33238 + + -- BadImport + GhcDiagnosticCode "BadImportNotExported" = 61689 + GhcDiagnosticCode "BadImportAvailDataCon" = 35373 + GhcDiagnosticCode "BadImportNotExportedSubordinates" = 10237 + GhcDiagnosticCode "BadImportNonTypeSubordinates" = 51433 + GhcDiagnosticCode "BadImportNonDataSubordinates" = 46557 + GhcDiagnosticCode "BadImportAvailTyCon" = 56449 + GhcDiagnosticCode "BadImportAvailVar" = 12112 + -- TcRnPragmaWarning GhcDiagnosticCode "WarningTxt" = 63394 GhcDiagnosticCode "DeprecatedTxt" = 68441 @@ -539,7 +789,65 @@ GhcDiagnosticCode "InvalidImplicitParamBinding" = 51603 GhcDiagnosticCode "DefaultDataInstDecl" = 39639 GhcDiagnosticCode "FunBindLacksEquations" = 52078 + GhcDiagnosticCode "EmptyGuard" = 45149 + GhcDiagnosticCode "EmptyParStmt" = 95595 + -- TcRnDodgyImports/DodgyImportsReason + GhcDiagnosticCode "DodgyImportsEmptyParent" = 99623 + + -- TcRnImportLookup/ImportLookupReason + GhcDiagnosticCode "ImportLookupQualified" = 48795 + GhcDiagnosticCode "ImportLookupIllegal" = 14752 + GhcDiagnosticCode "ImportLookupAmbiguous" = 92057 + + -- TcRnUnusedImport/UnusedImportReason + GhcDiagnosticCode "UnusedImportNone" = 66111 + GhcDiagnosticCode "UnusedImportSome" = 38856 + + -- TcRnIllegalInstance + GhcDiagnosticCode "IllegalFamilyApplicationInInstance" = 73138 + + -- TcRnIllegalClassInstance/IllegalClassInstanceReason + GhcDiagnosticCode "IllegalSpecialClassInstance" = 97044 + GhcDiagnosticCode "IllegalInstanceFailsCoverageCondition" = 21572 + + -- IllegalInstanceHead + GhcDiagnosticCode "InstHeadAbstractClass" = 51758 + GhcDiagnosticCode "InstHeadNonClassHead" = 53946 + GhcDiagnosticCode "InstHeadTySynArgs" = 93557 + GhcDiagnosticCode "InstHeadNonTyVarArgs" = 48406 + GhcDiagnosticCode "InstHeadMultiParam" = 91901 + + -- IllegalHasFieldInstance + GhcDiagnosticCode "IllegalHasFieldInstanceNotATyCon" = 88994 + GhcDiagnosticCode "IllegalHasFieldInstanceFamilyTyCon" = 70743 + GhcDiagnosticCode "IllegalHasFieldInstanceTyConHasFields" = 43406 + GhcDiagnosticCode "IllegalHasFieldInstanceTyConHasField" = 30836 + + -- TcRnIllegalFamilyInstance/IllegalFamilyInstanceReason + GhcDiagnosticCode "NotAFamilyTyCon" = 06204 + GhcDiagnosticCode "NotAnOpenFamilyTyCon" = 06207 + GhcDiagnosticCode "FamilyCategoryMismatch" = 52347 + GhcDiagnosticCode "FamilyArityMismatch" = 12985 + GhcDiagnosticCode "TyFamNameMismatch" = 88221 + GhcDiagnosticCode "FamInstRHSOutOfScopeTyVars" = 53634 + GhcDiagnosticCode "FamInstLHSUnusedBoundTyVars" = 30337 + + -- InvalidAssocInstance + GhcDiagnosticCode "AssocInstanceMissing" = 08585 + GhcDiagnosticCode "AssocInstanceNotInAClass" = 06205 + GhcDiagnosticCode "AssocNotInThisClass" = 38351 + GhcDiagnosticCode "AssocNoClassTyVar" = 55912 + GhcDiagnosticCode "AssocTyVarsDontMatch" = 95424 + + -- InvalidAssocDefault + GhcDiagnosticCode "AssocDefaultNotAssoc" = 78822 + GhcDiagnosticCode "AssocMultipleDefaults" = 59128 + + -- AssocDefaultBadArgs + GhcDiagnosticCode "AssocDefaultNonTyVarArg" = 41522 + GhcDiagnosticCode "AssocDefaultDuplicateTyVars" = 48178 + -- Diagnostic codes for the foreign function interface GhcDiagnosticCode "NotADataType" = 31136 GhcDiagnosticCode "NewtypeDataConNotInScope" = 72317 @@ -556,13 +864,32 @@ GhcDiagnosticCode "OneArgExpected" = 91490 GhcDiagnosticCode "AtLeastOneArgExpected" = 07641 + -- Interface errors + GhcDiagnosticCode "BadSourceImport" = 64852 + GhcDiagnosticCode "HomeModError" = 58427 + GhcDiagnosticCode "DynamicHashMismatchError" = 54709 + GhcDiagnosticCode "CouldntFindInFiles" = 94559 + GhcDiagnosticCode "GenericMissing" = 87110 + GhcDiagnosticCode "MissingPackageFiles" = 22211 + GhcDiagnosticCode "MissingPackageWayFiles" = 88719 + GhcDiagnosticCode "ModuleSuggestion" = 61948 + GhcDiagnosticCode "MultiplePackages" = 45102 + GhcDiagnosticCode "NoUnitIdMatching" = 51294 + GhcDiagnosticCode "NotAModule" = 35235 + GhcDiagnosticCode "Can'tFindNameInInterface" = 83249 + GhcDiagnosticCode "CircularImport" = 75429 + GhcDiagnosticCode "HiModuleNameMismatchWarn" = 53693 + GhcDiagnosticCode "ExceptionOccurred" = 47808 + -- Out of scope errors GhcDiagnosticCode "NotInScope" = 76037 + GhcDiagnosticCode "NotARecordField" = 22385 GhcDiagnosticCode "NoExactName" = 97784 GhcDiagnosticCode "SameName" = 81573 GhcDiagnosticCode "MissingBinding" = 44432 GhcDiagnosticCode "NoTopLevelBinding" = 10173 GhcDiagnosticCode "UnknownSubordinate" = 54721 + GhcDiagnosticCode "NotInScopeTc" = 76329 -- Diagnostic codes for deriving GhcDiagnosticCode "DerivErrNotWellKinded" = 62016 @@ -593,24 +920,100 @@ GhcDiagnosticCode "DerivErrGenerics" = 30367 GhcDiagnosticCode "DerivErrEnumOrProduct" = 58291 + -- Diagnostic codes for instance lookup + GhcDiagnosticCode "LookupInstErrNotExact" = 10372 + 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 GhcDiagnosticCode "EmptyStmtsGroupInDoNotation" = 82311 GhcDiagnosticCode "EmptyStmtsGroupInArrowNotation" = 19442 - GhcDiagnosticCode "TcRnCannotDefaultConcrete" = 52083 + -- HsBoot and Hsig errors + GhcDiagnosticCode "MissingBootDefinition" = 63610 + GhcDiagnosticCode "MissingBootExport" = 91999 + GhcDiagnosticCode "MissingBootInstance" = 79857 + GhcDiagnosticCode "BadReexportedBootThing" = 12424 + GhcDiagnosticCode "BootMismatchedIdTypes" = 11890 + GhcDiagnosticCode "BootMismatchedTyCons" = 15843 + -- TH errors + GhcDiagnosticCode "TypedTHWithPolyType" = 94642 + GhcDiagnosticCode "SplicePolymorphicLocalVar" = 06568 + GhcDiagnosticCode "SpliceThrewException" = 87897 + GhcDiagnosticCode "InvalidTopDecl" = 52886 + GhcDiagnosticCode "NonExactName" = 77923 + GhcDiagnosticCode "AddInvalidCorePlugin" = 86463 + GhcDiagnosticCode "AddDocToNonLocalDefn" = 67760 + GhcDiagnosticCode "FailedToLookupThInstName" = 49530 + GhcDiagnosticCode "CannotReifyInstance" = 30384 + GhcDiagnosticCode "CannotReifyOutOfScopeThing" = 24922 + GhcDiagnosticCode "CannotReifyThingNotInTypeEnv" = 79890 + GhcDiagnosticCode "NoRolesAssociatedWithThing" = 65923 + GhcDiagnosticCode "CannotRepresentType" = 75721 + GhcDiagnosticCode "ReportCustomQuasiError" = 39584 + GhcDiagnosticCode "MismatchedSpliceType" = 45108 + GhcDiagnosticCode "IllegalTHQuotes" = 62558 + GhcDiagnosticCode "IllegalTHSplice" = 26759 + GhcDiagnosticCode "NestedTHBrackets" = 59185 + GhcDiagnosticCode "AddTopDeclsUnexpectedDeclarationSplice" = 17599 + GhcDiagnosticCode "BadImplicitSplice" = 25277 + GhcDiagnosticCode "QuotedNameWrongStage" = Outdated 57695 + GhcDiagnosticCode "IllegalStaticFormInSplice" = 12219 + + -- Zonker messages + GhcDiagnosticCode "ZonkerCannotDefaultConcrete" = 52083 + + -- Promotion errors + GhcDiagnosticCode "ClassPE" = 86934 + GhcDiagnosticCode "TyConPE" = 85413 + GhcDiagnosticCode "PatSynPE" = 70349 + GhcDiagnosticCode "FamDataConPE" = 64578 + GhcDiagnosticCode "ConstrainedDataConPE" = 28374 + GhcDiagnosticCode "RecDataConPE" = 56753 + GhcDiagnosticCode "TermVariablePE" = 45510 + GhcDiagnosticCode "TypeVariablePE" = 47557 + -- To generate new random numbers: -- https://www.random.org/integers/?num=10&min=1&max=99999&col=1&base=10&format=plain -- -- 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 "Example outdated error" = 00000 + GhcDiagnosticCode "TcRnIllegalInstanceHeadDecl" = Outdated 12222 + GhcDiagnosticCode "TcRnNoClassInstHead" = Outdated 56538 + -- The above two are subsumed by InstHeadNonClassHead [GHC-53946] + 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 + {- ********************************************************************* * * Recurring into an argument @@ -636,24 +1039,38 @@ ConRecursInto "GhcPsMessage" = 'Just PsMessage ConRecursInto "GhcTcRnMessage" = 'Just TcRnMessage ConRecursInto "GhcDsMessage" = 'Just DsMessage - ConRecursInto "GhcUnknownMessage" = 'Just UnknownDiagnostic + ConRecursInto "GhcUnknownMessage" = 'Just (UnknownDiagnosticFor GhcMessage) ---------------------------------- -- Constructors of DriverMessage - ConRecursInto "DriverUnknownMessage" = 'Just UnknownDiagnostic + ConRecursInto "DriverUnknownMessage" = 'Just (UnknownDiagnosticFor DriverMessage) ConRecursInto "DriverPsHeaderMessage" = 'Just PsMessage + ConRecursInto "DriverInterfaceError" = 'Just IfaceMessage + ConRecursInto "CantFindErr" = 'Just CantFindInstalled + ConRecursInto "CantFindInstalledErr" = 'Just CantFindInstalled + + ConRecursInto "CantFindInstalled" = 'Just CantFindInstalledReason + + ConRecursInto "BadIfaceFile" = 'Just ReadInterfaceError + ConRecursInto "FailedToLoadDynamicInterface" = 'Just ReadInterfaceError + ---------------------------------- -- Constructors of PsMessage - ConRecursInto "PsUnknownMessage" = 'Just UnknownDiagnostic + ConRecursInto "PsUnknownMessage" = 'Just (UnknownDiagnosticFor PsMessage) ConRecursInto "PsHeaderMessage" = 'Just PsHeaderMessage ---------------------------------- + -- Constructors of DsMessage + + ConRecursInto "DsUselessSpecialisePragma" = 'Just UselessSpecialisePragmaReason + + ---------------------------------- -- Constructors of TcRnMessage - ConRecursInto "TcRnUnknownMessage" = 'Just UnknownDiagnostic + ConRecursInto "TcRnUnknownMessage" = 'Just (UnknownDiagnosticFor TcRnMessage) -- Recur into TcRnMessageWithInfo to get the underlying TcRnMessage ConRecursInto "TcRnMessageWithInfo" = 'Just TcRnMessageDetailed @@ -661,16 +1078,67 @@ ConRecursInto "TcRnWithHsDocContext" = 'Just TcRnMessage ConRecursInto "TcRnCannotDeriveInstance" = 'Just DeriveInstanceErrReason + ConRecursInto "TcRnLookupInstance" = 'Just LookupInstanceErrReason ConRecursInto "TcRnPragmaWarning" = 'Just (WarningTxt GhcRn) ConRecursInto "TcRnNotInScope" = 'Just NotInScopeError ConRecursInto "TcRnIllegalNewtype" = 'Just IllegalNewtypeReason + ConRecursInto "TcRnHsigShapeMismatch" = 'Just HsigShapeMismatchReason + ConRecursInto "TcRnPatSynInvalidRhs" = 'Just PatSynInvalidRhsReason + ConRecursInto "TcRnBadRecordUpdate" = 'Just BadRecordUpdateReason + ConRecursInto "TcRnBadFieldAnnotation" = 'Just BadFieldAnnotationReason + ConRecursInto "TcRnRoleValidationFailed" = 'Just RoleValidationFailedReason + ConRecursInto "TcRnClassExtensionDisabled" = 'Just DisabledClassExtension + ConRecursInto "TcRnTyFamsDisabled" = 'Just TyFamsDisabledReason + ConRecursInto "TcRnDodgyImports" = 'Just DodgyImportsReason + ConRecursInto "DodgyImportsHiding" = 'Just ImportLookupReason + ConRecursInto "TcRnImportLookup" = 'Just ImportLookupReason + ConRecursInto "TcRnUnusedImport" = 'Just UnusedImportReason + ConRecursInto "TcRnNonCanonicalDefinition" = 'Just NonCanonicalDefinition + ConRecursInto "TcRnIllegalInstance" = 'Just IllegalInstanceReason + ConRecursInto "TcRnIllegalInvisibleTypePattern" = 'Just BadInvisPatReason + -- Illegal instance reasons + ConRecursInto "IllegalClassInstance" = 'Just IllegalClassInstanceReason + ConRecursInto "IllegalFamilyInstance" = 'Just IllegalFamilyInstanceReason + + -- Illegal class instance reasons + + ConRecursInto "IllegalInstanceHead" = 'Just IllegalInstanceHeadReason + ConRecursInto "IllegalHasFieldInstance" = 'Just IllegalHasFieldInstance + + -- Illegal family instance reasons + + ConRecursInto "InvalidAssoc" = 'Just InvalidAssoc + ConRecursInto "InvalidAssocInstance" = 'Just InvalidAssocInstance + ConRecursInto "InvalidAssocDefault" = 'Just InvalidAssocDefault + ConRecursInto "AssocDefaultBadArgs" = 'Just AssocDefaultBadArgs + -- -- TH errors + ConRecursInto "TcRnTHError" = 'Just THError + ConRecursInto "THSyntaxError" = 'Just THSyntaxError + ConRecursInto "THNameError" = 'Just THNameError + ConRecursInto "THReifyError" = 'Just THReifyError + ConRecursInto "TypedTHError" = 'Just TypedTHError + ConRecursInto "THSpliceFailed" = 'Just SpliceFailReason + ConRecursInto "RunSpliceFailure" = 'Just RunSpliceFailReason + ConRecursInto "ConversionFail" = 'Just ConversionFailReason + ConRecursInto "AddTopDeclsError" = 'Just AddTopDeclsError + ConRecursInto "AddTopDeclsRunSpliceFailure" = 'Just RunSpliceFailReason - ConRecursInto "TcRnRunSpliceFailure" = 'Just RunSpliceFailReason - ConRecursInto "ConversionFail" = 'Just ConversionFailReason + -- Interface file errors + ConRecursInto "TcRnInterfaceError" = 'Just IfaceMessage + ConRecursInto "Can'tFindInterface" = 'Just MissingInterfaceError + + -- HsBoot and Hsig errors + ConRecursInto "TcRnBootMismatch" = 'Just BootMismatch + ConRecursInto "MissingBootThing" = 'Just MissingBootThing + ConRecursInto "BootMismatch" = 'Just BootMismatchWhat + + -- Zonker errors + ConRecursInto "TcRnZonkerMessage" = 'Just ZonkerMessage + ------------------ -- FFI errors @@ -697,9 +1165,14 @@ ---------------------------------- -- Constructors of DsMessage - ConRecursInto "DsUnknownMessage" = 'Just UnknownDiagnostic + ConRecursInto "DsUnknownMessage" = 'Just (UnknownDiagnosticFor DsMessage) ---------------------------------- + -- Constructors of ImportLookupBad + ConRecursInto "ImportLookupBad" = 'Just BadImportKind + + ConRecursInto "TcRnUnpromotableThing" = 'Just PromotionErr + ---------------------------------- -- Any other constructors: don't recur, instead directly -- use the constructor name for the error code. @@ -713,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). @@ -750,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 @@ -758,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 - , HasType UnknownDiagnostic con f ) - => ConstructorCode con f ('Just UnknownDiagnostic) where - gconstructorCode diag = case getType @UnknownDiagnostic @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. @@ -837,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 @@ -875,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 @@ -10,7 +10,6 @@ Note [FieldLabel] ~~~~~~~~~~~~~~~~~ - This module defines the representation of FieldLabels as stored in TyCons. As well as a selector name, these have some extra structure to support the DuplicateRecordFields and NoFieldSelectors extensions. @@ -22,60 +21,25 @@ has - FieldLabel { flLabel = "foo" - , flHasDuplicateRecordFields = NoDuplicateRecordFields + FieldLabel { flHasDuplicateRecordFields = NoDuplicateRecordFields , flHasFieldSelector = FieldSelectors , flSelector = foo }. -In particular, the Name of the selector has the same string -representation as the label. If DuplicateRecordFields -is enabled, however, the same declaration instead gives +If DuplicateRecordFields is enabled, however, the same declaration instead gives - FieldLabel { flLabel = "foo" - , flHasDuplicateRecordFields = DuplicateRecordFields + FieldLabel { flHasDuplicateRecordFields = DuplicateRecordFields , flHasFieldSelector = FieldSelectors - , flSelector = $sel:foo:MkT }. - -Similarly, the selector name will be mangled if NoFieldSelectors is used -(whether or not DuplicateRecordFields is enabled). See Note [NoFieldSelectors] -in GHC.Rename.Env. - -Now the name of the selector ($sel:foo:MkT) does not match the label of -the field (foo). We must be careful not to show the selector name to -the user! The point of mangling the selector name is to allow a -module to define the same field label in different datatypes: - - data T = MkT { foo :: Int } - data U = MkU { foo :: Bool } - -Now there will be two FieldLabel values for 'foo', one in T and one in -U. They share the same label (FieldLabelString), but the selector -functions differ. - -See also Note [Representing fields in AvailInfo] in GHC.Types.Avail. - -Note [Why selector names include data constructors] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -As explained above, a selector name includes the name of the first -data constructor in the type, so that the same label can appear -multiple times in the same module. (This is irrespective of whether -the first constructor has that field, for simplicity.) - -We use a data constructor name, rather than the type constructor name, -because data family instances do not have a representation type -constructor name generated until relatively late in the typechecking -process. - -Of course, datatypes with no constructors cannot have any fields. + , flSelector = foo }. +We need to keep track of whether FieldSelectors or DuplicateRecordFields were +enabled when a record field was defined, as they affect name resolution and +shadowing of record fields, as explained in Note [NoFieldSelectors] in GHC.Types.Name.Reader +and Note [Reporting duplicate local declarations] in GHC.Rename.Names. -} module GHC.Types.FieldLabel ( FieldLabelEnv - , FieldLabel(..) - , fieldSelectorOccName - , fieldLabelPrintableName + , FieldLabel(..), flLabel , DuplicateRecordFields(..) , FieldSelectors(..) , flIsOverloaded @@ -84,10 +48,8 @@ import GHC.Prelude -import {-# SOURCE #-} GHC.Types.Name.Occurrence import {-# SOURCE #-} GHC.Types.Name -import GHC.Data.FastString import GHC.Data.FastString.Env import GHC.Types.Unique (Uniquable(..)) import GHC.Utils.Outputable @@ -104,20 +66,23 @@ -- | Fields in an algebraic record type; see Note [FieldLabel]. data FieldLabel = FieldLabel { - flLabel :: FieldLabelString, - -- ^ User-visible label of the field flHasDuplicateRecordFields :: DuplicateRecordFields, -- ^ Was @DuplicateRecordFields@ on in the defining module for this datatype? flHasFieldSelector :: FieldSelectors, -- ^ Was @FieldSelectors@ enabled in the defining module for this datatype? -- See Note [NoFieldSelectors] in GHC.Rename.Env flSelector :: Name - -- ^ Record selector function + -- ^ The 'Name' of the selector function, which uniquely identifies + -- the field label. } deriving (Data, Eq) +-- | User-visible label of a field. +flLabel :: FieldLabel -> FieldLabelString +flLabel = FieldLabelString . occNameFS . nameOccName . flSelector + instance HasOccName FieldLabel where - occName = mkVarOccFS . field_label . flLabel + occName = nameOccName . flSelector instance Outputable FieldLabel where ppr fl = ppr (flLabel fl) <> whenPprDebug (braces (ppr (flSelector fl)) @@ -130,14 +95,11 @@ instance Uniquable FieldLabelString where getUnique (FieldLabelString fs) = getUnique fs -instance NFData FieldLabel where - rnf (FieldLabel a b c d) = rnf a `seq` rnf b `seq` rnf c `seq` rnf d - -- | Flag to indicate whether the DuplicateRecordFields extension is enabled. 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) @@ -148,13 +110,15 @@ ppr NoDuplicateRecordFields = text "-dup" instance NFData DuplicateRecordFields where - rnf x = x `seq` () + rnf DuplicateRecordFields = () + rnf NoDuplicateRecordFields = () + -- | Flag to indicate whether the FieldSelectors extension is enabled. 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) @@ -165,55 +129,25 @@ ppr NoFieldSelectors = text "-sel" instance NFData FieldSelectors where - rnf x = x `seq` () + rnf FieldSelectors = () + rnf NoFieldSelectors = () -- | We need the @Binary Name@ constraint here even though there is an instance -- defined in "GHC.Types.Name", because the we have a SOURCE import, so the -- instance is not in scope. And the instance cannot be added to Name.hs-boot -- because "GHC.Utils.Binary" itself depends on "GHC.Types.Name". instance Binary Name => Binary FieldLabel where - put_ bh (FieldLabel aa ab ac ad) = do - put_ bh (field_label aa) + put_ bh (FieldLabel aa ab ac) = do + put_ bh aa put_ bh ab put_ bh ac - put_ bh ad get bh = do aa <- get bh ab <- get bh ac <- get bh - ad <- get bh - return (FieldLabel (FieldLabelString aa) ab ac ad) - - --- | Record selector OccNames are built from the underlying field name --- and the name of the first data constructor of the type, to support --- duplicate record field names. --- See Note [Why selector names include data constructors]. -fieldSelectorOccName :: FieldLabelString -> OccName -> DuplicateRecordFields -> FieldSelectors -> OccName -fieldSelectorOccName lbl dc dup_fields_ok has_sel - | shouldMangleSelectorNames dup_fields_ok has_sel = mkRecFldSelOcc str - | otherwise = mkVarOccFS fl - where - fl = field_label lbl - str = concatFS [fsLit ":", fl, fsLit ":", occNameFS dc] - --- | Undo the name mangling described in Note [FieldLabel] to produce a Name --- that has the user-visible OccName (but the selector's unique). This should --- be used only when generating output, when we want to show the label, but may --- need to qualify it with a module prefix. -fieldLabelPrintableName :: FieldLabel -> Name -fieldLabelPrintableName fl - | flIsOverloaded fl = tidyNameOcc (flSelector fl) (mkVarOccFS (field_label $ flLabel fl)) - | otherwise = flSelector fl - --- | Selector name mangling should be used if either DuplicateRecordFields or --- NoFieldSelectors is enabled, so that the OccName of the field can be used for --- something else. See Note [FieldLabel], and Note [NoFieldSelectors] in --- GHC.Rename.Env. -shouldMangleSelectorNames :: DuplicateRecordFields -> FieldSelectors -> Bool -shouldMangleSelectorNames dup_fields_ok has_sel - = dup_fields_ok == DuplicateRecordFields || has_sel == NoFieldSelectors + return (FieldLabel aa ab ac) flIsOverloaded :: FieldLabel -> Bool flIsOverloaded fl = - shouldMangleSelectorNames (flHasDuplicateRecordFields fl) (flHasFieldSelector fl) + flHasDuplicateRecordFields fl == DuplicateRecordFields + || flHasFieldSelector fl == NoFieldSelectors 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] - 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(..)) + {- ************************************************************************ * * @@ -99,7 +101,7 @@ data CExportSpec = CExportStatic -- foreign export ccall foo :: ty SourceText -- of the CLabelString. - -- See Note [Pragma source text] in GHC.Types.SourceText + -- See Note [Pragma source text] in "GHC.Types.SourceText" CLabelString -- C Name of exported function CCallConv deriving Data @@ -117,7 +119,7 @@ -- An "unboxed" ccall# to named function in a particular package. = StaticTarget SourceText -- of the CLabelString. - -- See Note [Pragma source text] in GHC.Types.SourceText + -- See Note [Pragma source text] in "GHC.Types.SourceText" CLabelString -- C-land name of label. (Maybe Unit) -- What package the function is in. @@ -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 new file mode 100644 --- /dev/null +++ b/GHC/Types/GREInfo.hs @@ -0,0 +1,346 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DerivingStrategies #-} + +-- | Renamer-level information about 'Name's. +-- +-- Renamer equivalent of 'TyThing'. +module GHC.Types.GREInfo where + +import GHC.Prelude + +import GHC.Types.Basic +import GHC.Types.FieldLabel +import GHC.Types.Name +import GHC.Types.Unique +import GHC.Types.Unique.Set +import GHC.Utils.Outputable +import GHC.Utils.Panic + +import Control.DeepSeq ( NFData(..), deepseq ) + +import Data.Data ( Data ) +import Data.List.NonEmpty ( NonEmpty ) +import qualified Data.List.NonEmpty as NonEmpty + +{-********************************************************************** +* * + GREInfo +* * +************************************************************************ + +Note [GREInfo] +~~~~~~~~~~~~~~ +In the renamer, we sometimes need a bit more information about a 'Name', e.g. +whether it is a type constructor, class, data constructor, record field, etc. + +For example, when typechecking record construction, the renamer needs to look +up the fields of the data constructor being used (see e.g. GHC.Rename.Pat.rnHsRecFields). +Extra information also allows us to provide better error messages when a fatal +error occurs in the renamer, as it allows us to distinguish classes, type families, +type synonyms, etc. + +For imported Names, we have access to the full type information in the form of +a TyThing (although see Note [Retrieving the GREInfo from interfaces]). +However, for Names in the module currently being renamed, we don't +yet have full information. Instead of using TyThing, we use the GREInfo type, +and this information gets affixed to each element in the GlobalRdrEnv. + +This allows us to treat imported and local Names in a consistent manner: +always look at the GREInfo. + +Note [Retrieving the GREInfo from interfaces] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If we have a TyThing, we can easily compute the corresponding GREInfo: this is +done in GHC.Types.TyThing.tyThingGREInfo. + +However, one often needs to produce GlobalRdrElts (and thus their GREInfos) +directly after loading interface files, before they are typechecked. For example: + + - GHC.Tc.Module.tcRnModuleTcRnM first calls tcRnImports, which starts off + calling rnImports which transitively calls filterImports. That function + is responsible for coughing up GlobalRdrElts (and their GREInfos) obtained + from interfaces, but we will only typecheck the interfaces after we have + finished processing the imports (see e.g. the logic at the start of tcRnImports + which sets eps_is_boot, which decides whether we should look in the boot + or non-boot interface for any particular module). + - GHC.Tc.Utils.Backpack.mergeSignatures first loads the relevant signature + interfaces to merge them, but only later on does it typecheck them. + +In both of these examples, what's important is that we **lazily** produce the +GREInfo: it should only be consulted once the interfaces have been typechecked, +which will add the necessary information to the type-level environment. +In particular, the respective functions 'filterImports' and 'mergeSignatures' +should NOT force the gre_info field. + +We delay the loading of interfaces by making the gre_info field of 'GlobalRdrElt' +a thunk which, when forced, loads the interface, looks up the 'Name' in the type +environment to get its associated TyThing, and computes the GREInfo from that. +See 'GHC.Rename.Env.lookupGREInfo'. + +A possible alternative design would be to change the AvailInfo datatype to also +store GREInfo. We currently don't do that, as this would mean that every time +an interface re-exports something it has to also provide its GREInfo, which +could lead to bloat. + +Note [Forcing GREInfo] +~~~~~~~~~~~~~~~~~~~~~~ +The GREInfo field of a GlobalRdrElt needs to be lazy, as explained in +Note [Retrieving the GREInfo from interfaces]. For imported things, this field +is usually a thunk which looks up the GREInfo in a type environment +(see GHC.Rename.Env.lookupGREInfo). + +We thus need to be careful not to introduce space leaks: such thunks could end +up retaining old type environments, which would violate invariant (5) of +Note [GHC Heap Invariants] in GHC.Driver.Make. This can happen, for example, +when reloading in GHCi (see e.g. test T15369, which can trigger the ghci leak check +if we're not careful). + +A naive approach is to simply deeply force the whole GlobalRdrEnv. However, +forcing the GREInfo thunks can force the loading of interface files which we +otherwise might not need to load, so it leads to wasted work. + +Instead, whenever we are about to store the GlobalRdrEnv somewhere (such as +in ModDetails), we dehydrate it by stripping away the GREInfo field, turning it +into (). See 'forceGlobalRdrEnv' and its cousin 'hydrateGlobalRdrEnv', +as well as Note [IfGlobalRdrEnv] in GHC.Types.Name.Reader. + +Search for references to this note in the code for illustration. +-} + +-- | Information about a 'Name' that is pertinent to the renamer. +-- +-- See Note [GREInfo] +data GREInfo + -- | A variable (an 'Id' or a 'TyVar') + = Vanilla + -- | An unbound GRE... could be anything + | UnboundGRE + -- | 'TyCon' + | IAmTyCon !(TyConFlavour Name) + -- | 'ConLike' + | IAmConLike !ConInfo + -- ^ The constructor fields. + -- See Note [Local constructor info in the renamer]. + -- | Record field + | IAmRecField !RecFieldInfo + + deriving Data + + +plusGREInfo :: GREInfo -> GREInfo -> GREInfo +plusGREInfo Vanilla Vanilla = Vanilla +plusGREInfo UnboundGRE UnboundGRE = UnboundGRE +plusGREInfo (IAmTyCon {}) info2@(IAmTyCon {}) = info2 +plusGREInfo (IAmConLike {}) info2@(IAmConLike {}) = info2 +plusGREInfo (IAmRecField {}) info2@(IAmRecField {}) = info2 +plusGREInfo info1 info2 = pprPanic "plusInfo" $ + vcat [ text "info1:" <+> ppr info1 + , text "info2:" <+> ppr info2 ] + +instance Outputable GREInfo where + ppr Vanilla = text "Vanilla" + ppr UnboundGRE = text "UnboundGRE" + ppr (IAmTyCon flav) + = text "TyCon" <+> ppr flav + ppr (IAmConLike info) + = text "ConLike" <+> ppr info + ppr (IAmRecField info) + = text "RecField" <+> ppr info + +{-********************************************************************** +* * + Constructor info +* * +************************************************************************ + +Note [Local constructor info in the renamer] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +As explained in Note [GREInfo], information pertinent to the renamer is +stored using the GREInfo datatype. What information do we need about constructors? + +Consider the following example: + + data T = T1 { x, y :: Int } + | T2 { x :: Int } + | T3 + | T4 Int Bool + +We need to know: +* The fields of the data constructor, so that + - We can complain if you say `T1 { v = 3 }`, where `v` is not a field of `T1` + See the following call stack + * GHC.Rename.Expr.rnExpr (RecordCon case) + * GHC.Rename.Pat.rnHsRecFields + * GHC.Rename.Env.lookupRecFieldOcc + - Ditto if you pattern match on `T1 { v = x }`. + See the following call stack + * GHC.Rename.Pat.rnHsRecPatsAndThen + * GHC.Rename.Pat.rnHsRecFields + * GHC.Rename.Env.lookupRecFieldOcc + - We can fill in the dots if you say `T1 {..}` in construction or pattern matching + See GHC.Rename.Pat.rnHsRecFields.rn_dotdot + + 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. +For example, both `data T = MkT` and `data T = MkT {}` are nullary. + +For consistency and TH convenience, it was agreed that a `{..}` +match or usage on nullary constructors would be accepted. +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 ConFieldInfo + = ConHasRecordFields (NonEmpty FieldLabel) + | ConHasPositionalArgs + | ConIsNullary + deriving stock Eq + deriving Data + +instance NFData ConFieldInfo where + rnf ConIsNullary = () + rnf ConHasPositionalArgs = () + rnf (ConHasRecordFields flds) = rnf flds + +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 = 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) = + text "ConHasRecordFields" <+> braces (ppr fieldLabels) + +-- | The 'Name' of a 'ConLike'. +-- +-- Useful when we are in the renamer and don't yet have a full 'DataCon' or +-- 'PatSyn' to hand. +data ConLikeName + = DataConName { conLikeName_Name :: !Name } + | 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 + +instance NFData ConLikeName where + rnf = rnf . conLikeName_Name + +{-********************************************************************** +* * + Record field info +* * +**********************************************************************-} + +data RecFieldInfo + = RecFieldInfo + { recFieldLabel :: !FieldLabel + , recFieldCons :: !(UniqSet ConLikeName) + -- ^ The constructors which have this field label. + -- Always non-empty. + -- + -- NB: these constructors will always share a single parent, + -- as the field label disambiguates between parents in the presence + -- of duplicate record fields. + } + deriving (Eq, Data) + +instance NFData RecFieldInfo where + rnf (RecFieldInfo lbl cons) + = rnf lbl `seq` nonDetStrictFoldUniqSet deepseq () cons + +instance Outputable RecFieldInfo where + ppr (RecFieldInfo { recFieldLabel = fl, recFieldCons = cons }) + = text "RecFieldInfo" <+> braces + (text "recFieldLabel:" <+> ppr fl <> comma + <+> text "recFieldCons:" <+> pprWithCommas ppr (nonDetEltsUniqSet cons)) 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 @@ -21,30 +24,34 @@ , noStarIsTypeHints ) where +import Language.Haskell.Syntax.Expr (LHsExpr) +import Language.Haskell.Syntax (LPat, LIdP, LHsSigType, LHsSigWcType, Sig) + import GHC.Prelude import qualified Data.List.NonEmpty as NE -import GHC.Utils.Outputable import qualified GHC.LanguageExtensions as LangExt -import Data.Typeable import GHC.Unit.Module (ModuleName, Module) -import GHC.Hs.Extension (GhcTc) +import GHC.Unit.Module.Imported (ImportedModsVal) +import GHC.Hs.Extension (GhcTc, GhcRn, GhcPs) +import GHC.Core.Class (Class) import GHC.Core.Coercion -import GHC.Core.Type (PredType) +import GHC.Core.FamInstEnv (FamFlavor) +import GHC.Core.TyCon (TyCon) +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 {-# SOURCE #-} Language.Haskell.Syntax.Expr -import GHC.Unit.Module.Imported (ImportedModsVal) -import GHC.Data.FastString (fsLit) - -- This {-# SOURCE #-} import should be removable once - -- 'Language.Haskell.Syntax.Bind' no longer depends on 'GHC.Tc.Types.Evidence'. +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. data AvailableBindings @@ -52,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 @@ -247,7 +255,6 @@ -} | SuggestAddToHSigExportList !Name !(Maybe Module) {-| Suggests increasing the limit for the number of iterations in the simplifier. - -} | SuggestIncreaseSimplifierIterations {-| Suggests to explicitly import 'Type' from the 'Data.Kind' module, because @@ -296,21 +303,26 @@ -} | 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 or to newtype-wrap it. + {-| Suggests to move an orphan instance (for a typeclass or a type or data + family), or to newtype-wrap it. Triggered by: 'GHC.Tc.Errors.Types.TcRnOrphanInstance' Test cases(s): warnings/should_compile/T9178 typecheck/should_compile/T4912 + indexed-types/should_compile/T22717_fam_orph -} - | SuggestFixOrphanInstance + | SuggestFixOrphanInst + { isFamilyInstance :: Maybe FamFlavor } + -- ^ Whether this is a family instance (of the given 'FamFlavor'), + -- or a class instance ('Nothing'). {-| Suggests to use a standalone deriving declaration when GHC can't derive a typeclass instance in a trivial way. @@ -320,6 +332,14 @@ -} | SuggestAddStandaloneDerivation + {-| Suggests to add a standalone kind signature when GHC + can't perform kind inference. + + Triggered by: 'GHC.Tc.Errors.Types.TcRnInvisBndrWithoutSig' + Test case(s): typecheck/should_fail/T22560_fail_d + -} + | SuggestAddStandaloneKindSignature Name + {-| Suggests the user to fill in the wildcard constraint to disambiguate which constraint that is. @@ -331,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'. @@ -369,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, @@ -395,16 +409,9 @@ Test cases: mod28, mod36, mod87, mod114, ... -} - | ImportSuggestion ImportSuggestion - - {-| Suggest importing a data constructor to bring it into scope - Triggered by: 'GHC.Tc.Errors.Types.TcRnTypeCannotBeMarshaled' + | ImportSuggestion OccName ImportSuggestion - Test cases: ccfail004 - -} - | SuggestImportingDataCon - {- Found a pragma in the body of a module, suggest - placing it in the header + {-| Found a pragma in the body of a module, suggest placing it in the header. -} | SuggestPlacePragmaInHeader {-| Suggest using pattern matching syntax for a non-bidirectional pattern synonym @@ -420,11 +427,107 @@ -} | SuggestSpecialiseVisibilityHints Name - | LoopySuperclassSolveHint PredType ClsInstOrQC + {-| Suggest renaming implicitly quantified type variable in case it + captures a term's name. + -} + | SuggestRenameTypeVariable + | SuggestExplicitBidiPatSyn Name (LPat GhcRn) [LIdP GhcRn] + + {-| Suggest enabling one of the SafeHaskell modes Safe, Unsafe or + Trustworthy. + -} + | SuggestSafeHaskell + + {-| Suggest removing a record wildcard from a pattern when it doesn't + bind anything useful. + -} + | SuggestRemoveRecordWildcard + {-| Suggest moving a method implementation to a different instance to its + superclass that defines the canonical version of the method. + -} + | SuggestMoveNonCanonicalDefinition + Name -- ^ move the implementation from this method + Name -- ^ ... to this method + String -- ^ Documentation URL + + {-| Suggest to increase the solver maximum reduction depth -} + | SuggestIncreaseReductionDepth + + {-| Suggest removing a method implementation when a superclass defines the + canonical version of that method. + -} + | SuggestRemoveNonCanonicalDefinition + Name -- ^ method with non-canonical implementation + Name -- ^ possible other method to use as the RHS instead + String -- ^ Documentation URL + {-| Suggest eta-reducing a type synonym used in the implementation + of abstract data. -} + | SuggestEtaReduceAbsDataTySyn TyCon + {-| Remind the user that there is no field of a type and name in the record, + constructors are in the usual order $x$, $r$, $a$ -} + | RemindRecordMissingField FastString Type Type + {-| Suggest binding the type variable on the LHS of the type declaration + -} + | 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 @@ -438,12 +541,34 @@ -- 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)) OccName + = CouldImportFrom (NE.NonEmpty (Module, ImportedModsVal)) -- | Some module exports what we want, but we are explicitly hiding it. - | CouldUnhideFrom (NE.NonEmpty (Module, ImportedModsVal)) OccName + | CouldUnhideFrom (NE.NonEmpty (Module, ImportedModsVal)) + -- | 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. + { 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 } -- | Explain how something is in scope. data HowInScope @@ -454,7 +579,16 @@ data SimilarName = SimilarName Name - | SimilarRdrName RdrName HowInScope + | 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 @@ -12,19 +13,26 @@ import GHC.Parser.Errors.Basic import GHC.Types.Hint +import GHC.Core.FamInstEnv (FamFlavor(..)) +import GHC.Core.TyCon +import GHC.Core.TyCo.Rep ( mkVisFunTyMany ) import GHC.Hs.Expr () -- instance Outputable -import {-# SOURCE #-} GHC.Tc.Types.Origin ( ClsInstOrQC(..) ) import GHC.Types.Id -import GHC.Types.Name (NameSpace, pprDefinedAt, occNameSpace, pprNameSpace, isValNameSpace, nameModule) +import GHC.Types.Name import GHC.Types.Name.Reader (RdrName,ImpDeclSpec (..), rdrNameOcc, rdrNameSpace) import GHC.Types.SrcLoc (SrcSpan(..), srcSpanStartLine) import GHC.Unit.Module.Imported (ImportedModsVal(..)) 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 @@ -32,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 @@ -125,26 +138,28 @@ -> 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 Nothing -> header <+> text "the hsig file." Just mod -> header <+> ppr (moduleName mod) <> text "'s hsig file." - SuggestFixOrphanInstance - -> vcat [ text "Move the instance declaration to the module of the class or of the type, or" + SuggestFixOrphanInst { isFamilyInstance = mbFamFlavor } + -> vcat [ text "Move the instance declaration to the module of the" <+> what <+> text "or of the type, or" , text "wrap the type with a newtype and declare the instance on the new type." ] + where + what = case mbFamFlavor of + Nothing -> text "class" + Just SynFamilyInst -> text "type family" + Just (DataFamilyInst {}) -> text "data family" SuggestAddStandaloneDerivation -> text "Use a standalone deriving declaration instead" + SuggestAddStandaloneKindSignature name + -> 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 @@ -173,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 @@ -193,10 +208,8 @@ whose | null parents = empty | otherwise = text "belonging to the type" <> plural parents <+> pprQuotedList parents - ImportSuggestion import_suggestion - -> pprImportSuggestion import_suggestion - SuggestImportingDataCon - -> text "Import the data constructor to bring it into scope" + ImportSuggestion occ_name import_suggestion + -> pprImportSuggestion occ_name import_suggestion SuggestPlacePragmaInHeader -> text "Perhaps you meant to place it in the module header?" $$ text "The module header is the section at the top of the file, before the" <+> quotes (text "module") <+> text "keyword" @@ -207,85 +220,232 @@ <+> quotes (ppr name) <+> text "has an INLINABLE pragma" where mod = nameModule name - 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" + SuggestRenameTypeVariable + -> text "Consider renaming the type variable." + SuggestExplicitBidiPatSyn name pat args + -> hang (text "Instead use an explicitly bidirectional" + <+> text "pattern synonym, e.g.") + 2 (hang (text "pattern" <+> pp_name <+> pp_args <+> larrow + <+> ppr pat <+> text "where") + 2 (pp_name <+> pp_args <+> equals <+> text "...")) + where + pp_name = ppr name + pp_args = hsep (map ppr args) + SuggestSafeHaskell + -> text "Enable Safe Haskell through either Safe, Trustworthy or Unsafe." + SuggestRemoveRecordWildcard + -> text "Omit the" <+> quotes (text "..") + SuggestIncreaseReductionDepth -> + vcat + [ text "Use -freduction-depth=0 to disable this check" + , text "(any upper bound you could choose might fail unpredictably with" + , text " minor updates to GHC, so disabling the check is recommended if" + , text " you're sure that type checking should terminate)" ] + SuggestMoveNonCanonicalDefinition lhs rhs refURL -> + text "Move definition from" <+> + quotes (pprPrefixUnqual rhs) <+> + text "to" <+> quotes (pprPrefixUnqual lhs) $$ + text "See also:" <+> text refURL + SuggestRemoveNonCanonicalDefinition lhs rhs refURL -> + text "Either remove definition for" <+> + quotes (pprPrefixUnqual lhs) <+> text "(recommended)" <+> + text "or define as" <+> + quotes (pprPrefixUnqual lhs <+> text "=" <+> pprPrefixUnqual rhs) $$ + text "See also:" <+> text refURL + SuggestEtaReduceAbsDataTySyn tc + -> text "If possible, eta-reduce the type synonym" <+> ppr_tc <+> text "so that it is nullary." + where ppr_tc = quotes (ppr $ tyConName tc) + RemindRecordMissingField x r a -> + text "NB: There is no field selector" <+> ppr_sel + <+> text "in scope for record type" <+> ppr_r + where ppr_sel = quotes (ftext x <+> dcolon <+> ppr_arr_r_a) + ppr_arr_r_a = ppr $ mkVisFunTyMany r a + 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" -- | Pretty-print an 'ImportSuggestion'. -pprImportSuggestion :: ImportSuggestion -> SDoc -pprImportSuggestion (CouldImportFrom mods occ_name) +pprImportSuggestion :: OccName -> ImportSuggestion -> SDoc +pprImportSuggestion occ_name (CouldImportFrom mods) | (mod, imv) NE.:| [] <- mods = fsep - [ text "Perhaps you want to add" + [ text "Add" , quotes (ppr occ_name) , text "to the import list" , text "in the import of" , quotes (ppr mod) - , parens (ppr (imv_span imv)) <> dot + , parens (text "at" <+> ppr (imv_span imv)) <> dot ] | otherwise = fsep - [ text "Perhaps you want to add" + [ text "Add" , quotes (ppr occ_name) , text "to one of these import lists:" ] $$ nest 2 (vcat - [ quotes (ppr mod) <+> parens (ppr (imv_span imv)) + [ quotes (ppr mod) <+> parens (text "at" <+> ppr (imv_span imv)) | (mod,imv) <- NE.toList mods ]) -pprImportSuggestion (CouldUnhideFrom mods occ_name) +pprImportSuggestion occ_name (CouldUnhideFrom mods) | (mod, imv) NE.:| [] <- mods = fsep - [ text "Perhaps you want to remove" + [ text "Remove" , quotes (ppr occ_name) , text "from the explicit hiding list" , text "in the import of" , quotes (ppr mod) - , parens (ppr (imv_span imv)) <> dot + , parens (text "at" <+> ppr (imv_span imv)) <> dot ] | otherwise = fsep - [ text "Perhaps you want to remove" + [ text "Remove" , quotes (ppr occ_name) , text "from the hiding clauses" , text "in one of these imports:" ] $$ nest 2 (vcat - [ quotes (ppr mod) <+> parens (ppr (imv_span imv)) + [ quotes (ppr mod) <+> parens (text "at" <+> ppr (imv_span imv)) | (mod,imv) <- NE.toList mods ]) +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) + 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 { 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'. pprSimilarName :: NameSpace -> SimilarName -> SDoc pprSimilarName _ (SimilarName name) = quotes (ppr name) <+> parens (pprDefinedAt name) pprSimilarName tried_ns (SimilarRdrName rdr_name how_in_scope) - = case how_in_scope of - LocallyBoundAt loc -> - pp_ns rdr_name <+> quotes (ppr rdr_name) <+> loc' - where - loc' = case loc of - UnhelpfulSpan l -> parens (ppr l) - RealSrcSpan l _ -> parens (text "line" <+> int (srcSpanStartLine l)) - ImportedBy is -> - pp_ns rdr_name <+> quotes (ppr rdr_name) <+> - parens (text "imported from" <+> ppr (is_mod is)) - + = pp_ns rdr_name <+> quotes (ppr rdr_name) <+> loc where + loc = case how_in_scope of + Nothing -> empty + Just scope -> case scope of + LocallyBoundAt loc -> + case loc of + UnhelpfulSpan l -> parens (ppr l) + RealSrcSpan l _ -> parens (text "line" <+> int (srcSpanStartLine l)) + ImportedBy is -> + parens (text "imported from" <+> ppr (moduleName $ is_mod is)) pp_ns :: RdrName -> SDoc pp_ns rdr | ns /= tried_ns = pprNameSpace ns | 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 @@ -9,10 +9,11 @@ import GHC.Prelude import GHC.Types.Name +import GHC.Data.FastString 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) @@ -20,12 +21,12 @@ -- | Position and information about an info table. -- For return frames these are the contents of a 'CoreSyn.SourceNote'. -type IpeSourceLocation = (RealSrcSpan, String) +type IpeSourceLocation = (RealSrcSpan, LexicalFastString) -- | 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) @@ -37,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) @@ -48,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 @@ -296,26 +297,28 @@ mkGlobalId = Var.mkGlobalVar -- | Make a global 'Id' without any extra information at all -mkVanillaGlobal :: Name -> Type -> Id +mkVanillaGlobal :: HasDebugCallStack => Name -> Type -> Id mkVanillaGlobal name ty = mkVanillaGlobalWithInfo name ty vanillaIdInfo -- | Make a global 'Id' with no global information but some generic 'IdInfo' -mkVanillaGlobalWithInfo :: Name -> Type -> IdInfo -> Id -mkVanillaGlobalWithInfo = mkGlobalId VanillaId - +mkVanillaGlobalWithInfo :: HasDebugCallStack => Name -> Type -> IdInfo -> Id +mkVanillaGlobalWithInfo nm = + assertPpr (not $ isFieldNameSpace $ nameNameSpace nm) + (text "mkVanillaGlobalWithInfo called on record field:" <+> ppr nm) $ + mkGlobalId VanillaId nm -- | For an explanation of global vs. local 'Id's, see "GHC.Types.Var#globalvslocal" mkLocalId :: HasDebugCallStack => Name -> Mult -> Type -> Id mkLocalId name w ty = mkLocalIdWithInfo name w (assert (not (isCoVarType ty)) ty) vanillaIdInfo -- | Make a local CoVar -mkLocalCoVar :: Name -> Type -> CoVar +mkLocalCoVar :: HasDebugCallStack => Name -> Type -> CoVar mkLocalCoVar name ty = assert (isCoVarType ty) $ Var.mkLocalVar CoVarId name ManyTy ty vanillaIdInfo -- | Like 'mkLocalId', but checks the type to see if it should make a covar -mkLocalIdOrCoVar :: Name -> Mult -> Type -> Id +mkLocalIdOrCoVar :: HasDebugCallStack => Name -> Mult -> Type -> Id mkLocalIdOrCoVar name w ty -- We should assert (eqType w Many) in the isCoVarType case. -- However, currently this assertion does not hold. @@ -339,7 +342,10 @@ -- Note [Free type variables] mkExportedVanillaId :: Name -> Type -> Id -mkExportedVanillaId name ty = Var.mkExportedLocalVar VanillaId name ty vanillaIdInfo +mkExportedVanillaId name ty = + assertPpr (not $ isFieldNameSpace $ nameNameSpace name) + (text "mkExportedVanillaId called on record field:" <+> ppr name) $ + Var.mkExportedLocalVar VanillaId name ty vanillaIdInfo -- Note [Free type variables] @@ -480,23 +486,23 @@ isDataConRecordSelector id = case Var.idDetails id of RecSelId {sel_tycon = RecSelData _} -> True - _ -> False + _ -> False isPatSynRecordSelector id = case Var.idDetails id of RecSelId {sel_tycon = RecSelPatSyn _} -> True - _ -> False + _ -> False isNaughtyRecordSelector id = case Var.idDetails id of RecSelId { sel_naughty = n } -> n - _ -> False + _ -> False isClassOpId id = case Var.idDetails id of - ClassOpId _ -> True - _other -> False + ClassOpId {} -> True + _other -> False isClassOpId_maybe id = case Var.idDetails id of - ClassOpId cls -> Just cls - _other -> Nothing + ClassOpId cls _ -> Just cls + _other -> Nothing isPrimOpId id = case Var.idDetails id of PrimOpId {} -> True @@ -527,19 +533,33 @@ _ -> Nothing isDataConWrapId id = case Var.idDetails id of - DataConWrapId _ -> True - _ -> False + DataConWrapId _ -> True + _ -> False isDataConWrapId_maybe id = case Var.idDetails id of 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] @@ -560,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. @@ -590,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 @@ -639,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)) @@ -671,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 {- ************************************************************************ @@ -834,15 +859,15 @@ asNonWorkerLikeId id = let details = case idDetails id of WorkerLikeId{} -> Just $ VanillaId - JoinId arity Just{} -> Just $ JoinId arity Nothing - _ -> Nothing + JoinId arity Just{} -> Just $ JoinId arity Nothing + _ -> Nothing in maybeModifyIdDetails details id -- | Turn this id into a WorkerLikeId if possible. asWorkerLikeId :: Id -> Id asWorkerLikeId id = let details = case idDetails id of - WorkerLikeId{} -> Nothing + WorkerLikeId{} -> Nothing JoinId _arity Just{} -> Nothing JoinId arity Nothing -> Just (JoinId arity (Just [])) VanillaId -> Just $ WorkerLikeId [] @@ -957,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 @@ -979,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 @@ -8,9 +8,12 @@ Haskell. [WDP 94/11]) -} - -{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE BinaryLiterals #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE TypeFamilies #-} {-# OPTIONS_GHC -Wno-incomplete-record-updates #-} @@ -18,8 +21,11 @@ -- * The IdDetails type IdDetails(..), pprIdDetails, coVarDetails, isCoVarDetails, JoinArity, isJoinIdDetails_maybe, - RecSelParent(..), + RecSelParent(..), recSelParentName, recSelFirstConName, + recSelParentCons, idDetailsConcreteTvs, + RecSelInfo(..), conLikesRecSelInfo, + -- * The IdInfo type IdInfo, -- Abstract vanillaIdInfo, noCafIdInfo, @@ -31,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 @@ -95,20 +102,23 @@ import GHC.Types.Basic import GHC.Core.DataCon 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 GHC.StgToCmm.Types (LambdaFormInfo) +import Data.List as List( partition ) -- infixl so you can say (id `set` a `set` b) infixl 1 `setRuleInfo`, @@ -120,7 +130,8 @@ `setCafInfo`, `setDmdSigInfo`, `setCprSigInfo`, - `setDemandInfo` + `setDemandInfo`, + `setLFInfo` {- ************************************************************************ * * @@ -138,10 +149,14 @@ -- | The 'Id' for a record selector | RecSelId - { sel_tycon :: RecSelParent - , sel_naughty :: Bool -- True <=> a "naughty" selector which can't actually exist, for example @x@ in: + { sel_tycon :: RecSelParent + , 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/ @@ -150,14 +165,36 @@ -- a) to support isImplicitId -- b) when desugaring a RecordCon we can get -- from the Id back to the data con] - | ClassOpId Class -- ^ The 'Id' is a superclass selector, - -- or class operation of a class - | 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 + | ClassOpId -- ^ The 'Id' is a superclass selector or class operation + Class -- for this class + Bool -- True <=> given a non-bottom dictionary, the class op will + -- definitely return a non-bottom result + -- and Note [exprOkForSpeculation and type classes] + -- in GHC.Core.Utils + -- | 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 @@ -183,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 @@ -215,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 @@ -268,17 +329,49 @@ if there are unapplied occurrences like `map f xs`. -} --- | Recursive Selector Parent -data RecSelParent = RecSelData TyCon | RecSelPatSyn PatSyn deriving Eq - -- Either `TyCon` or `PatSyn` depending - -- on the origin of the record selector. - -- For a data type family, this is the - -- /instance/ 'TyCon' not the family 'TyCon' +-- | Parent of a record selector function. +-- +-- Either the parent 'TyCon' or 'PatSyn' depending +-- on the origin of the record selector. +-- +-- For a data family, this is the /instance/ 'TyCon', +-- **not** the family 'TyCon'. +data RecSelParent + -- | Parent of a data constructor record field. + -- + -- For a data family, this is the /instance/ 'TyCon'. + = RecSelData TyCon + -- | Parent of a pattern synonym record field: + -- the 'PatSyn' itself. + | RecSelPatSyn PatSyn + deriving (Eq, Data) +recSelParentName :: RecSelParent -> Name +recSelParentName (RecSelData tc) = tyConName tc +recSelParentName (RecSelPatSyn ps) = patSynName ps + +recSelFirstConName :: RecSelParent -> Name +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 ty_con -> ppr ty_con - RecSelPatSyn ps -> ppr ps + RecSelData tc + | Just (parent_tc, tys) <- tyConFamInst_maybe tc + -> ppr (mkTyConApp parent_tc tys) + | otherwise + -> ppr tc + RecSelPatSyn ps + -> ppr ps -- | Just a synonym for 'CoVarId'. Written separately so it can be -- exported in the hs-boot file. @@ -302,10 +395,11 @@ pprIdDetails other = brackets (pp other) where pp VanillaId = panic "pprIdDetails" - pp (WorkerLikeId dmds) = text "StrictWorker" <> parens (ppr dmds) + pp (WorkerLikeId dmds) = text "StrictWorker" <> parens (ppr dmds) 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" @@ -369,7 +463,12 @@ -- -- See documentation of the getters for what these packed fields mean. lfInfo :: !(Maybe LambdaFormInfo), - -- ^ See Note [The LFInfo of Imported Ids] in GHC.StgToCmm.Closure + -- ^ If lfInfo = Just info, then the `info` is guaranteed /correct/. + -- If lfInfo = Nothing, then we do not have a `LambdaFormInfo` for this Id, + -- so (for imported Ids) we make a conservative version. + -- See Note [The LFInfo of Imported Ids] in GHC.StgToCmm.Closure + -- For locally-defined Ids other than DataCons, the `lfInfo` field is always Nothing. + -- See also Note [LFInfo of DataCon workers and wrappers] -- See documentation of the getters for what these packed fields mean. tagSig :: !(Maybe TagSig) @@ -772,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,8 +68,10 @@ import GHC.Types.Literal import GHC.Types.SourceText +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 @@ -74,19 +79,23 @@ 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 import Data.List ( zipWith4 ) +-- A bit of a shame we must import these here +import GHC.StgToCmm.Types (LambdaFormInfo(..)) +import GHC.Runtime.Heap.Layout (ArgDescr(ArgUnknown)) + {- ************************************************************************ * * @@ -149,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] @@ -374,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 @@ -464,45 +476,36 @@ 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) name sel_ty info + = 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 arg_tys = dataConRepArgTys data_con -- Includes the dictionary superclasses val_index = assoc "MkId.mkDictSelId" (sel_names `zip` [0..]) name - sel_ty = mkInvisForAllTys tyvars $ - mkFunctionType ManyTy (mkClassPred clas (mkTyVarTys (binderVars tyvars))) $ - scaledThing (getNth arg_tys val_index) - -- See Note [Type classes and linear types] + pred_ty = mkClassPred clas (mkTyVarTys (binderVars tyvars)) + res_ty = scaledThing (getNth arg_tys val_index) + sel_ty = mkForAllTys tyvars $ + mkFunctionType ManyTy pred_ty res_ty + -- See Note [Type classes and linear types] + terminating = isTerminatingType res_ty || definitelyUnliftedType res_ty + -- If the field is unlifted, it can't be bottom + -- Ditto if it's a terminating type + base_info = noCafIdInfo `setArityInfo` 1 `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 @@ -515,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 @@ -529,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 } @@ -556,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 @@ -573,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 @@ -590,29 +602,124 @@ `setInlinePragInfo` wkr_inline_prag `setUnfoldingInfo` evaldUnfolding -- Record that it's evaluated, -- even if arity = 0 - -- No strictness: see Note [Data-con worker strictness] in GHC.Core.DataCon + `setDmdSigInfo` wkr_sig + -- Workers eval their strict fields + -- See Note [Strict fields in Core] + `setLFInfo` wkr_lf_info 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 + | otherwise = LFReEntrant TopLevel (countFunRepArgs wkr_arity wkr_ty) True ArgUnknown + -- 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 - 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) {- +Note [LFInfo of DataCon workers and wrappers] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +As noted in Note [The LFInfo of Imported Ids] in GHC.StgToCmm.Closure, it's +crucial that saturated data con applications are given an LFInfo of `LFCon`. + +Since for data constructors we never serialise the worker and the wrapper (only +the data type declaration), we never serialise their lambda form info either. + +Therefore, when making data constructors workers and wrappers, we construct a +correct `LFInfo` for them right away, and put it it in the `lfInfo` field of the +worker/wrapper Id, ensuring that: + + The `lfInfo` field of a DataCon worker or wrapper is always populated with the correct LFInfo. + +How do we construct a /correct/ LFInfo for workers and wrappers? +(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`, + `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`. + +(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`. + +For example, consider the following data constructors: + + data T1 a where + TCon1 :: {-# UNPACK #-} !(a :~: True) -> T1 a + + data T2 a where + TCon2 :: {-# UNPACK #-} !() -> T2 a + + data T3 a where + TCon3 :: T3 '[] + +`TCon1`'s wrapper has a lifted argument, which is non-zero-width, while the +worker has an unlifted equality argument, which is zero-width. + +`TCon2`'s wrapper has a lifted argument, which is non-zero-width, while the +worker has no arguments. + +Wrinkle (W1). Perhaps surprisingly, it is possible for the /wrapper/ to be an +`LFCon` even though the /worker/ is not. Consider `T3` above. Here is the +Core representation of the worker and wrapper: + + $WTCon3 :: T3 '[] -- Wrapper + $WTCon3 = TCon3 @[] -- A saturated constructor application: LFCon + + TCon3 :: forall (a :: * -> *). (a ~# []) => T a -- Worker + TCon3 = /\a. \(co :: a~#[]). TCon3 co -- A function: LFReEntrant + +For `TCon1`, both the wrapper and worker will be given `LFReEntrant` since they +both have arity == 1. + +For `TCon2`, the wrapper will be given `LFReEntrant` since it has arity == 1 +while the worker is `LFCon` since its arity == 0 + +For `TCon3`, the wrapper will be given `LFCon` since its arity == 0 and the +worker `LFReEntrant` since its arity == 1 + +One might think we could give *workers* with only zero-width-args the `LFCon` +LambdaFormInfo, e.g. give `LFCon` to the worker of `TCon1` and `TCon3`. +However, these workers are unambiguously functions +-- which makes `LFReEntrant`, the LambdaFormInfo we give them, correct. +See also the discussion in #23158. + +Wrinkles: + +(W1) Why do we panic when generating `LFInfo` for newtype workers and wrappers? + + We don't generate code for newtype workers/wrappers, so we should never have to + look at their LFInfo (and in general we can't; they may be representation-polymorphic). + +See also the Note [Imported unlifted nullary datacon wrappers must have correct LFInfo] +in GHC.StgToCmm.Types. + ------------------------------------------------- -- Data constructor representation -- @@ -681,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 @@ -704,11 +811,20 @@ -- We need to get the CAF info right here because GHC.Iface.Tidy -- does not tidy the IdInfo of implicit bindings (like the wrapper) -- so it not make sure that the CAF info is sane + `setLFInfo` wrap_lf_info -- The signature is purely for passes like the Simplifier, not for -- DmdAnal itself; see Note [DmdAnal for DataCon wrappers]. wrap_sig = mkClosedDmdSig wrap_arg_dmds topDiv + -- See Note [LFInfo of DataCon workers and wrappers] + wrap_lf_info + | wrap_arity == 0 = LFCon data_con + -- See W1 in Note [LFInfo of DataCon workers and wrappers] + | isNewTyCon tycon = panic "mkDataConRep: we shouldn't look at LFInfo for newtype wrapper ids" + | otherwise = LFReEntrant TopLevel (countFunRepArgs wrap_arity wrap_ty) True ArgUnknown + -- LFInfo stores post-unarisation arity + wrap_arg_dmds = replicate (length theta) topDmd ++ map mk_dmd arg_ibangs -- Don't forget the dictionary arguments when building @@ -732,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) @@ -796,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 @@ -830,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) } ) @@ -1069,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 @@ -1099,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) @@ -1401,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 @@ -1469,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 @@ -1666,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) {- ************************************************************************ @@ -1692,6 +1871,7 @@ failure when trying.) -} + nullAddrName, seqName, realWorldName, voidPrimIdName, coercionTokenName, coerceName, proxyName, @@ -1739,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 @@ -1763,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 ------------------------------------------------ @@ -1800,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 @@ -1818,6 +2002,9 @@ Var body `App` Var x' arity = 2 + concs = mkRepPolyIdConcreteTyVars + [((openAlphaTy, mkArgPos 2 Top), runtimeRep1TyVar)] + ---------------------------------------------------------------------- {- Note [Wired-in Ids for rebindable syntax] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1842,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 @@ -1860,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). @@ -1867,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 @@ -1890,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 @@ -1917,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] ~~~~~~~~~~~~~~~~~~ @@ -2045,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. @@ -2074,13 +2272,116 @@ This is crucial: otherwise, we could import an unfolding in which 'nospec' has been inlined (= erased), and we would lose the benefit. -'nospec' is used in the implementation of 'withDict': we insert 'nospec' -so that the typeclass specialiser doesn't assume any two evidence terms -of the same type are equal. See Note [withDict] in GHC.Tc.Instance.Class, -and see test case T21575b for an example. +'nospec' is used: -Note [The oneShot function] -~~~~~~~~~~~~~~~~~~~~~~~~~~~ +* In the implementation of 'withDict': we insert 'nospec' so that the + typeclass specialiser doesn't assume any two evidence terms of the + same type are equal. See Note [withDict] in GHC.Tc.Instance.Class, + and see test case T21575b for an example. + +* To defeat the specialiser when we have incoherent instances. + See Note [Coherence and specialisation: overview] in GHC.Core.InstEnv. + +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 @@ -2104,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@). @@ -2161,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 ( @@ -32,7 +30,7 @@ , mkLitFloat, mkLitDouble , mkLitChar, mkLitString , mkLitBigNat - , mkLitNumber, mkLitNumberWrap + , mkLitNumber, mkLitNumberWrap, mkLitNumberMaybe -- ** Operations on Literals , literalType @@ -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) @@ -411,6 +429,12 @@ assertPpr (litNumCheckRange platform nt i) (integer i) (LitNumber nt i) +-- | Create a numeric 'Literal' of the given type if it is in range +mkLitNumberMaybe :: Platform -> LitNumType -> Integer -> Maybe Literal +mkLitNumberMaybe platform nt i + | litNumCheckRange platform nt i = Just (LitNumber nt i) + | otherwise = Nothing + -- | Creates a 'Literal' of type @Int#@ mkLitInt :: Platform -> Integer -> Literal mkLitInt platform x = assertPpr (platformInIntRange platform x) (integer x) @@ -431,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 @@ -455,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 @@ -837,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 @@ -868,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` @@ -902,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,7 +1,10 @@ +{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeFamilies #-} +{-# OPTIONS_GHC -Wno-orphans #-} -- instance NFData FieldLabel + {- (c) The University of Glasgow 2006 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 @@ -56,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, - isWiredInName, isWiredIn, isBuiltInSyntax, + isValName, isVarName, isDynLinkName, isFieldName, + isWiredInName, isWiredIn, isBuiltInSyntax, isTupleTyConName, + isSumTyConName, + isUnboxedTupleDataConLikeName, isHoleName, wiredInNameTyThing_maybe, nameIsLocalOrFrom, nameIsExternalOrFrom, nameIsHomePackage, @@ -91,6 +96,7 @@ import GHC.Types.Name.Occurrence import GHC.Unit.Module import GHC.Unit.Home +import GHC.Types.FieldLabel import GHC.Types.SrcLoc import GHC.Types.Unique import GHC.Utils.Misc @@ -99,10 +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, Unboxed)) +import GHC.Builtin.Uniques ( isTupleTyConUnique, isCTupleTyConUnique, + isSumTyConUnique, isTupleDataConLikeUnique ) {- ************************************************************************ @@ -138,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') @@ -157,6 +171,10 @@ instance NFData Name where rnf Name{..} = rnf n_sort `seq` rnf n_occ `seq` n_uniq `seq` rnf n_loc +-- Needs NFData Name, so the instance is here to avoid cyclic imports. +instance NFData FieldLabel where + rnf (FieldLabel a b c) = rnf a `seq` rnf b `seq` rnf c + instance NFData NameSort where rnf (External m) = rnf m rnf (WiredIn m t b) = rnf m `seq` t `seq` b `seq` () @@ -176,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): @@ -204,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 @@ -230,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 @@ -282,6 +311,18 @@ isBuiltInSyntax (Name {n_sort = WiredIn _ _ BuiltInSyntax}) = True isBuiltInSyntax _ = False +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 @@ -338,8 +379,30 @@ -- 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 "[]") +namePun_maybe name + | getUnique name == getUnique listTyCon = Just (fsLit "[]") + + | 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 nameIsLocalOrFrom :: Module -> Name -> Bool @@ -424,6 +487,9 @@ isVarName :: Name -> Bool isVarName = isVarOcc . nameOccName +isFieldName :: Name -> Bool +isFieldName = isFieldOcc . nameOccName + isSystemName (Name {n_sort = System}) = True isSystemName _ = False @@ -569,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`. @@ -602,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 {- ************************************************************************ @@ -626,28 +692,41 @@ pprPrefixOcc = pprPrefixName pprName :: forall doc. IsLine doc => Name -> doc -pprName name@(Name {n_sort = sort, n_uniq = uniq, n_occ = occ}) - = docWithContext $ \ctx -> - let sty = sdocStyle ctx - debug = sdocPprDebug ctx - listTuplePuns = sdocListTuplePuns ctx - in 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 - System -> pprSystem debug sty uniq occ - Internal -> pprInternal debug sty uniq 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 - -- Print GHC.Types.List as [], etc. - handlePuns :: Bool -> Maybe FastString -> doc -> doc - handlePuns True (Just pun) _ = ftext pun - handlePuns _ _ r = r + codeDoc = case sort of + WiredIn mod _ _ -> pprModule mod <> char '_' <> z_occ + External mod -> pprModule mod <> char '_' <> z_occ + -- In code style, always qualify + -- ToDo: maybe we could print all wired-in things unqualified + -- in code style, to reduce symbol table bloat? + System -> pprUniqueAlways uniq + Internal -> pprUniqueAlways uniq + z_occ = ztext $ zEncodeFS $ occNameMangledFS occ + + normalDoc sty = + getPprDebug $ \debug -> + sdocOption sdocListTuplePuns $ \listTuplePuns -> + handlePuns listTuplePuns (namePun_maybe name) $ + case sort of + 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 + + handlePuns :: Bool -> Maybe FastString -> SDoc -> SDoc + handlePuns True (Just pun) _ = ftext pun + handlePuns _ _ r = r {-# 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 @@ -656,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 -- @@ -674,12 +763,14 @@ pprNameUnqualified :: Name -> SDoc pprNameUnqualified Name { n_occ = occ } = ppr_occ_name occ -pprExternal :: IsLine doc => Bool -> PprStyle -> Unique -> Module -> OccName -> Bool -> BuiltInSyntax -> doc -pprExternal debug sty uniq mod occ is_wired is_builtin - | codeStyle sty = pprModule mod <> char '_' <> ppr_z_occ_name occ - -- In code style, always qualify - -- ToDo: maybe we could print all wired-in things unqualified - -- in code style, to reduce symbol table bloat? +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), @@ -687,17 +778,16 @@ | 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) -pprInternal :: IsLine doc => Bool -> PprStyle -> Unique -> OccName -> doc +pprInternal :: Bool -> PprStyle -> Unique -> OccName -> SDoc pprInternal debug sty uniq occ - | codeStyle sty = pprUniqueAlways uniq | debug = ppr_occ_name occ <> braces (hsep [pprNameSpaceBrief (occNameSpace occ), pprUnique uniq]) | dumpStyle sty = ppr_occ_name occ <> ppr_underscore_unique uniq @@ -706,9 +796,8 @@ | otherwise = ppr_occ_name occ -- User style -- Like Internal, except that we only omit the unique in Iface style -pprSystem :: IsLine doc => Bool -> PprStyle -> Unique -> OccName -> doc -pprSystem debug sty uniq occ - | codeStyle sty = pprUniqueAlways uniq +pprSystem :: Bool -> PprStyle -> Unique -> OccName -> SDoc +pprSystem debug _sty uniq occ | debug = ppr_occ_name occ <> ppr_underscore_unique uniq <> braces (pprNameSpaceBrief (occNameSpace occ)) | otherwise = ppr_occ_name occ <> ppr_underscore_unique uniq @@ -717,40 +806,35 @@ -- so print the unique -pprModulePrefix :: IsLine doc => PprStyle -> Module -> OccName -> doc +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 <> pprModuleName (moduleName mod) <> dot -- scope either NameUnqual -> empty -- In scope unqualified -pprUnique :: IsLine doc => Unique -> doc +pprUnique :: Unique -> SDoc -- Print a unique unless we are suppressing them pprUnique uniq = ppUnlessOption sdocSuppressUniques $ pprUniqueAlways uniq -ppr_underscore_unique :: IsLine doc => Unique -> doc +ppr_underscore_unique :: Unique -> SDoc -- Print an underscore separating the name from its unique -- But suppress it if we aren't printing the uniques anyway ppr_underscore_unique uniq = ppUnlessOption sdocSuppressUniques $ char '_' <> pprUniqueAlways uniq -ppr_occ_name :: IsLine doc => OccName -> doc +ppr_occ_name :: OccName -> SDoc ppr_occ_name occ = ftext (occNameFS occ) -- Don't use pprOccName; instead, just print the string of the OccName; -- we print the namespace in the debug stuff above --- In code style, we Z-encode the strings. The results of Z-encoding each FastString are --- cached behind the scenes in the FastString implementation. -ppr_z_occ_name :: IsLine doc => OccName -> doc -ppr_z_occ_name occ = ztext (zEncodeFS (occNameFS occ)) - -- Prints (if mod information is available) "Defined at " or -- "Defined in " information for a Name. pprDefinedAt :: Name -> SDoc @@ -819,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.hs-boot b/GHC/Types/Name.hs-boot --- a/GHC/Types/Name.hs-boot +++ b/GHC/Types/Name.hs-boot @@ -3,7 +3,7 @@ module GHC.Types.Name.Occurrence ) where -import GHC.Prelude (Eq) +import GHC.Prelude (Eq, Bool) import {-# SOURCE #-} GHC.Types.Name.Occurrence import GHC.Types.Unique import GHC.Utils.Outputable @@ -28,3 +28,4 @@ setNameUnique :: Name -> Unique -> Name nameOccName :: Name -> OccName tidyNameOcc :: Name -> OccName -> Name +isFieldName :: Name -> Bool 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 @@ -1,9 +1,10 @@ - {-# LANGUAGE RankNTypes #-} -- | The Name Cache module GHC.Types.Name.Cache ( NameCache (..) + , newNameCache + , newNameCacheWith , initNameCache , takeUniqFromNameCache , updateNameCache' @@ -14,6 +15,10 @@ , lookupOrigNameCache , extendOrigNameCache' , extendOrigNameCache + + -- * Known-key names + , knownKeysOrigNameCache + , isKnownOrigName_maybe ) where @@ -24,10 +29,12 @@ 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 @@ -57,35 +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 tuples and unboxed sums 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) 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 syntax directly as Exact RdrNames, and 2) built-in 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 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. @@ -101,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 - = -- 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 @@ -125,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 @@ -158,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,22 +5,22 @@ \section[NameEnv]{@NameEnv@: name environments} -} - -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE ScopedTypeVariables #-} - module GHC.Types.Name.Env ( -- * Var, Id and TyVar environments (maps) NameEnv, -- ** Manipulating these environments mkNameEnv, mkNameEnvWith, + fromUniqMap, emptyNameEnv, isEmptyNameEnv, unitNameEnv, nonDetNameEnvElts, extendNameEnv_C, extendNameEnv_Acc, extendNameEnv, extendNameEnvList, extendNameEnvList_C, - filterNameEnv, mapMaybeNameEnv, anyNameEnv, + filterNameEnv, anyNameEnv, + mapMaybeNameEnv, + extendNameEnvListWith, plusNameEnv, plusNameEnv_C, plusNameEnv_CD, plusNameEnv_CD2, alterNameEnv, + plusNameEnvList, plusNameEnvListWith, lookupNameEnv, lookupNameEnv_NF, delFromNameEnv, delListFromNameEnv, elemNameEnv, mapNameEnv, disjointNameEnv, seqEltsNameEnv, @@ -47,6 +47,7 @@ import GHC.Types.Name import GHC.Types.Unique.FM import GHC.Types.Unique.DFM +import GHC.Types.Unique.Map import GHC.Data.Maybe {- @@ -103,6 +104,7 @@ isEmptyNameEnv :: NameEnv a -> Bool mkNameEnv :: [(Name,a)] -> NameEnv a mkNameEnvWith :: (a -> Name) -> [a] -> NameEnv a +fromUniqMap :: UniqMap Name a -> NameEnv a nonDetNameEnvElts :: NameEnv a -> [a] alterNameEnv :: (Maybe a-> Maybe a) -> NameEnv a -> Name -> NameEnv a extendNameEnv_C :: (a->a->a) -> NameEnv a -> Name -> a -> NameEnv a @@ -112,7 +114,10 @@ plusNameEnv_C :: (a->a->a) -> NameEnv a -> NameEnv a -> NameEnv a plusNameEnv_CD :: (a->a->a) -> NameEnv a -> a -> NameEnv a -> a -> NameEnv a plusNameEnv_CD2 :: (Maybe a->Maybe a->a) -> NameEnv a -> NameEnv a -> NameEnv a +plusNameEnvList :: [NameEnv a] -> NameEnv a +plusNameEnvListWith :: (a->a->a) -> [NameEnv a] -> NameEnv a extendNameEnvList :: NameEnv a -> [(Name,a)] -> NameEnv a +extendNameEnvListWith :: (a -> Name) -> NameEnv a -> [a] -> NameEnv a extendNameEnvList_C :: (a->a->a) -> NameEnv a -> [(Name,a)] -> NameEnv a delFromNameEnv :: NameEnv a -> Name -> NameEnv a delListFromNameEnv :: NameEnv a -> [Name] -> NameEnv a @@ -133,16 +138,22 @@ unitNameEnv x y = unitUFM x y extendNameEnv x y z = addToUFM x y z extendNameEnvList x l = addListToUFM x l +extendNameEnvListWith f x l = addListToUFM x (map (\a -> (f a, a)) l) lookupNameEnv x y = lookupUFM x y alterNameEnv = alterUFM mkNameEnv l = listToUFM l mkNameEnvWith f = mkNameEnv . map (\a -> (f a, a)) +fromUniqMap = mapUFM snd . getUniqMap elemNameEnv x y = elemUFM x y plusNameEnv x y = plusUFM x y plusNameEnv_C f x y = plusUFM_C f x y {-# INLINE plusNameEnv_CD #-} plusNameEnv_CD f x d y b = plusUFM_CD f x d y b plusNameEnv_CD2 f x y = plusUFM_CD2 f x y +{-# INLINE plusNameEnvList #-} +plusNameEnvList xs = plusUFMList xs +{-# INLINE plusNameEnvListWith #-} +plusNameEnvListWith f xs = plusUFMListWith f xs extendNameEnv_C f x y z = addToUFM_C f x y z mapNameEnv f x = mapUFM f x extendNameEnv_Acc x y z a b = addToUFM_Acc x y z a b @@ -151,11 +162,11 @@ delListFromNameEnv x y = delListFromUFM x y filterNameEnv x y = filterUFM x y mapMaybeNameEnv x y = mapMaybeUFM x y -anyNameEnv f x = foldUFM ((||) . f) False x +anyNameEnv f x = nonDetFoldUFM ((||) . f) False x 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,8 +3,8 @@ (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 -} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MagicHash #-} {-# LANGUAGE OverloadedStrings #-} -- | @@ -29,7 +29,7 @@ -- ** Construction -- $real_vs_source_data_constructors - tcName, clsName, tcClsName, dataName, varName, + tcName, clsName, tcClsName, dataName, varName, fieldName, tvName, srcDataName, -- ** Pretty Printing @@ -37,19 +37,22 @@ -- * The 'OccName' type OccName, -- Abstract, instance of Outputable - pprOccName, + pprOccName, occNameMangledFS, -- ** Construction mkOccName, mkOccNameFS, mkVarOcc, mkVarOccFS, + mkRecFieldOcc, mkRecFieldOccFS, mkDataOcc, mkDataOccFS, mkTyVarOcc, mkTyVarOccFS, mkTcOcc, mkTcOccFS, mkClsOcc, mkClsOccFS, mkDFunOcc, setOccNameSpace, - demoteOccName, + demoteOccName, demoteOccTcClsName, demoteOccTvName, promoteOccName, + varToRecFieldOcc, + recFieldToVarOcc, HasOccName(..), -- ** Derived 'OccName's @@ -66,33 +69,44 @@ mkSuperDictSelOcc, mkSuperDictAuxOcc, mkLocalOcc, mkMethodOcc, mkInstTyTcOcc, mkInstTyCoOcc, mkEqPredCoOcc, - mkRecFldSelOcc, mkTyConRepOcc, -- ** Deconstruction occNameFS, occNameString, occNameSpace, isVarOcc, isTvOcc, isTcOcc, isDataOcc, isDataSymOcc, isSymOcc, isValOcc, - parenSymOcc, startsWithUnderscore, + isFieldOcc, fieldOcc_maybe, + parenSymOcc, startsWithUnderscore, isUnderscore, isTcClsNameSpace, isTvNameSpace, isDataConNameSpace, isVarNameSpace, isValNameSpace, + isFieldNameSpace, isTermVarOrFieldNameSpace, -- * The 'OccEnv' type - OccEnv, emptyOccEnv, unitOccEnv, extendOccEnv, mapOccEnv, - lookupOccEnv, mkOccEnv, mkOccEnv_C, extendOccEnvList, elemOccEnv, - nonDetOccEnvElts, foldOccEnv, plusOccEnv, plusOccEnv_C, extendOccEnv_C, + OccEnv, emptyOccEnv, unitOccEnv, extendOccEnv, + mapOccEnv, strictMapOccEnv, + mapMaybeOccEnv, + lookupOccEnv, lookupOccEnv_AllNameSpaces, + lookupOccEnv_WithFields, lookupFieldsOccEnv, + mkOccEnv, mkOccEnv_C, extendOccEnvList, elemOccEnv, + nonDetOccEnvElts, nonDetFoldOccEnv, + plusOccEnv, plusOccEnv_C, extendOccEnv_Acc, filterOccEnv, delListFromOccEnv, delFromOccEnv, - alterOccEnv, minusOccEnv, minusOccEnv_C, pprOccEnv, + alterOccEnv, minusOccEnv, minusOccEnv_C, minusOccEnv_C_Ns, + sizeOccEnv, + pprOccEnv, forceOccEnv, + intersectOccEnv_C, -- * The 'OccSet' type OccSet, emptyOccSet, unitOccSet, mkOccSet, extendOccSet, extendOccSetList, - unionOccSets, unionManyOccSets, minusOccSet, elemOccSet, - isEmptyOccSet, intersectOccSet, - filterOccSet, occSetToEnv, + unionOccSets, unionManyOccSets, elemOccSet, + isEmptyOccSet, + -- * Dealing with main + mainOcc, ppMainFn, + -- * Tidying up - TidyOccEnv, emptyTidyOccEnv, initTidyOccEnv, + TidyOccEnv, emptyTidyOccEnv, initTidyOccEnv, trimTidyOccEnv, tidyOccName, avoidClashesOccEnv, delTidyOccEnvList, -- FsEnv @@ -101,9 +115,9 @@ import GHC.Prelude +import GHC.Builtin.Uniques import GHC.Utils.Misc import GHC.Types.Unique -import GHC.Builtin.Uniques import GHC.Types.Unique.FM import GHC.Types.Unique.Set import GHC.Data.FastString @@ -111,10 +125,13 @@ import GHC.Utils.Outputable import GHC.Utils.Lexeme import GHC.Utils.Binary +import GHC.Utils.Panic.Plain + import Control.DeepSeq import Data.Char import Data.Data import qualified Data.Semigroup as S +import GHC.Exts( Int(I#), dataToTag# ) {- ************************************************************************ @@ -124,33 +141,109 @@ ************************************************************************ -} -data NameSpace = VarName -- Variables, including "real" data constructors - | DataName -- "Source" data constructors - | TvName -- Type variables - | TcClsName -- Type constructors and classes; Haskell has them - -- in the same name space for now. - deriving( Eq, Ord ) +data NameSpace + -- | Variable name space (including "real" data constructors). + = VarName + -- | Record field namespace for the given record. + | FldName + { fldParent :: !FastString + -- ^ The textual name of the parent of the field. + -- + -- - For a field of a datatype, this is the name of the first constructor + -- of the datatype (regardless of whether this constructor has this field). + -- - For a field of a pattern synonym, this is the name of the pattern synonym. + } + -- | "Source" data constructor namespace. + | DataName + -- | Type variable namespace. + | TvName + -- | Type constructor and class namespace. + | TcClsName + -- Haskell has type constructors and classes in the same namespace, for now. + deriving Eq --- Note [Data Constructors] --- ~~~~~~~~~~~~~~~~~~~~~~~~ --- see also: Note [Data Constructor Naming] in GHC.Core.DataCon --- --- $real_vs_source_data_constructors --- There are two forms of data constructor: --- --- [Source data constructors] The data constructors mentioned in Haskell source code --- --- [Real data constructors] The data constructors of the representation type, which may not be the same as the source type --- --- For example: --- --- > data T = T !(Int, Int) --- --- The source datacon has type @(Int, Int) -> T@ --- The real datacon has type @Int -> Int -> T@ --- --- GHC chooses a representation based on the strictness etc. +instance Ord NameSpace where + compare ns1 ns2 = + case compare (I# (dataToTag# ns1)) (I# (dataToTag# ns2)) of + LT -> LT + GT -> GT + EQ + | FldName { fldParent = p1 } <- ns1 + , FldName { fldParent = p2 } <- ns2 + -> lexicalCompareFS p1 p2 + | otherwise + -> EQ +instance Uniquable NameSpace where + getUnique (FldName fs) = mkFldNSUnique fs + getUnique VarName = varNSUnique + getUnique DataName = dataNSUnique + getUnique TvName = tvNSUnique + getUnique TcClsName = tcNSUnique + +instance NFData NameSpace where + rnf VarName = () + rnf (FldName par) = rnf par + rnf DataName = () + rnf TvName = () + rnf TcClsName = () + +{- +Note [Data Constructors] +~~~~~~~~~~~~~~~~~~~~~~~~ +see also: Note [Data Constructor Naming] in GHC.Core.DataCon + +$real_vs_source_data_constructors +There are two forms of data constructor: + + [Source data constructors] The data constructors mentioned in Haskell source code + + [Real data constructors] The data constructors of the representation type, which may not be the same as the source type + +For example: + +> data T = T !(Int, Int) + +The source datacon has type @(Int, Int) -> T@ +The real datacon has type @Int -> Int -> T@ + +GHC chooses a representation based on the strictness etc. + +Note [Record field namespacing] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Record fields have a separate namespace from variables, to support +DuplicateRecordFields, e.g. in + + data X = MkX { fld :: Int } + data Y = MkY { fld :: Bool } + + f x = x { fld = 3 } + g y = y { fld = False } + +we want the two occurrences of "fld" to refer to the field names associated with +the corresponding data type. + +The namespace for a record field is as follows: + + - for a data type, it is the textual name of the first constructor of the + datatype, whether this constructor has this field or not; + - for a pattern synonym, it is the textual name of the pattern synonym itself. + +Record fields are initially parsed as variables, but the renamer resolves their +namespace in GHC.Rename.Names.newRecordFieldLabel, which is called when renaming +record data declarations and record pattern synonym declarations. + +To illustrate the namespacing, consider the record field "fld" in the following datatype + + data instance A Int Bool Char + = MkA1 | MkA2 { fld :: Int } | MkA3 { bar :: Bool, fld :: Int } + +Its namespace is `FldName "MkA1"`. This is a convention used throughout GHC +to circumvent the fact that we don't have a way to refer to the type constructor +"A Int Bool Char" in the renamer, as data family instances only get given +'Name's in the typechecker. +-} + tcName, clsName, tcClsName :: NameSpace dataName, srcDataName :: NameSpace tvName, varName :: NameSpace @@ -168,6 +261,9 @@ tvName = TvName varName = VarName +fieldName :: FastString -> NameSpace +fieldName = FldName + isDataConNameSpace :: NameSpace -> Bool isDataConNameSpace DataName = True isDataConNameSpace _ = False @@ -181,40 +277,71 @@ isTvNameSpace _ = False isVarNameSpace :: NameSpace -> Bool -- Variables or type variables, but not constructors -isVarNameSpace TvName = True -isVarNameSpace VarName = True -isVarNameSpace _ = False +isVarNameSpace TvName = True +isVarNameSpace VarName = True +isVarNameSpace (FldName {}) = True +isVarNameSpace _ = False +-- | Is this a term variable or field name namespace? +isTermVarOrFieldNameSpace :: NameSpace -> Bool +isTermVarOrFieldNameSpace VarName = True +isTermVarOrFieldNameSpace (FldName {}) = True +isTermVarOrFieldNameSpace _ = False + isValNameSpace :: NameSpace -> Bool -isValNameSpace DataName = True -isValNameSpace VarName = True -isValNameSpace _ = False +isValNameSpace DataName = True +isValNameSpace VarName = True +isValNameSpace (FldName {}) = True +isValNameSpace _ = False +isFieldNameSpace :: NameSpace -> Bool +isFieldNameSpace (FldName {}) = True +isFieldNameSpace _ = False + pprNameSpace :: NameSpace -> SDoc -pprNameSpace DataName = text "data constructor" -pprNameSpace VarName = text "variable" -pprNameSpace TvName = text "type variable" -pprNameSpace TcClsName = text "type constructor or class" +pprNameSpace DataName = text "data constructor" +pprNameSpace VarName = text "variable" +pprNameSpace TvName = text "type variable" +pprNameSpace TcClsName = text "type constructor or class" +pprNameSpace (FldName p) = text "record field of" <+> ftext p pprNonVarNameSpace :: NameSpace -> SDoc pprNonVarNameSpace VarName = empty pprNonVarNameSpace ns = pprNameSpace ns -pprNameSpaceBrief :: IsLine doc => NameSpace -> doc -pprNameSpaceBrief DataName = char 'd' -pprNameSpaceBrief VarName = char 'v' -pprNameSpaceBrief TvName = text "tv" -pprNameSpaceBrief TcClsName = text "tc" +pprNameSpaceBrief :: NameSpace -> SDoc +pprNameSpaceBrief DataName = char 'd' +pprNameSpaceBrief VarName = char 'v' +pprNameSpaceBrief TvName = text "tv" +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 +demoteTvNameSpace TvName = Just VarName +demoteTvNameSpace VarName = Nothing +demoteTvNameSpace DataName = Nothing +demoteTvNameSpace TcClsName = Nothing +demoteTvNameSpace (FldName {}) = Nothing + -- promoteNameSpace promotes the NameSpace as follows. -- See Note [Promotion] in GHC.Rename.Env. promoteNameSpace :: NameSpace -> Maybe NameSpace @@ -222,6 +349,7 @@ promoteNameSpace VarName = Just TvName promoteNameSpace TcClsName = Nothing promoteNameSpace TvName = Nothing +promoteNameSpace (FldName {}) = Nothing {- ************************************************************************ @@ -246,7 +374,8 @@ instance Ord OccName where -- Compares lexicographically, *not* by Unique of the string - compare (OccName sp1 s1) (OccName sp2 s2) = lexicalCompareFS s1 s2 S.<> compare sp1 sp2 + compare (OccName sp1 s1) (OccName sp2 s2) = + lexicalCompareFS s1 s2 S.<> compare sp1 sp2 instance Data OccName where -- don't traverse? @@ -278,11 +407,41 @@ pprOccName :: IsLine doc => OccName -> doc pprOccName (OccName sp occ) - = docWithContext $ \ sty -> - if codeStyle (sdocStyle sty) - then ztext (zEncodeFS occ) - else ftext occ <> whenPprDebug (braces (pprNameSpaceBrief sp)) + = docWithStyle (ztext (zEncodeFS occ)) + (\_ -> ftext occ <> whenPprDebug (braces (pprNameSpaceBrief sp))) +{-# SPECIALIZE pprOccName :: OccName -> SDoc #-} +{-# SPECIALIZE pprOccName :: OccName -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable +-- | Mangle field names to avoid duplicate symbols. +-- +-- See Note [Mangling OccNames]. +occNameMangledFS :: OccName -> FastString +occNameMangledFS (OccName ns fs) = + case ns of + -- Fields need to include the constructor, to ensure that we don't define + -- duplicate symbols when using DuplicateRecordFields. + FldName con -> concatFS [fsLit "$fld:", con, ":", fs] + -- Otherwise, we can ignore the namespace, as there is no risk of name + -- clashes. + _ -> fs + +{- Note [Mangling OccNames] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When generating a symbol for a Name, we usually discard the NameSpace entirely +(see GHC.Types.Name.pprName). This is because clashes are usually not possible, +e.g. a variable and a data constructor can't clash because data constructors +start with a capital letter or a colon, while variables never do. + +However, record field names, in the presence of DuplicateRecordFields, need this +disambiguation. So, for a record field like + + data A = MkA { foo :: Int } + +we generate the symbol $fld:MkA:foo. We use the constructor 'MkA' to disambiguate, +and not the TyCon A as one might naively expect: this is explained in +Note [Record field namespacing]. +-} + {- ************************************************************************ * * @@ -303,6 +462,27 @@ mkVarOccFS :: FastString -> OccName mkVarOccFS fs = mkOccNameFS varName fs +mkRecFieldOcc :: FastString -> String -> OccName +mkRecFieldOcc dc = mkOccName (fieldName dc) + +mkRecFieldOccFS :: FastString -> FastString -> OccName +mkRecFieldOccFS dc = mkOccNameFS (fieldName dc) + +varToRecFieldOcc :: HasDebugCallStack => FastString -> OccName -> OccName +varToRecFieldOcc dc (OccName ns s) = + assert makes_sense $ mkRecFieldOccFS dc s + where + makes_sense = case ns of + VarName -> True + FldName {} -> True + -- NB: it's OK to change the parent data constructor, + -- see e.g. test T23220 in which we construct with TH + -- a datatype using the fields of a different datatype. + _ -> False + +recFieldToVarOcc :: HasDebugCallStack => OccName -> OccName +recFieldToVarOcc (OccName _ns s) = mkVarOccFS s + mkDataOcc :: String -> OccName mkDataOcc = mkOccName dataName @@ -334,11 +514,23 @@ 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 + return $ OccName space' name + -- promoteOccName promotes the NameSpace of OccName. -- 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. @@ -353,91 +545,295 @@ * * ************************************************************************ -OccEnvs are used mainly for the envts in ModIfaces. +OccEnvs are used for the GlobalRdrEnv and for the envts in ModIface. -Note [The Unique of an OccName] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -They are efficient, because FastStrings have unique Int# keys. We assume -this key is less than 2^24, and indeed FastStrings are allocated keys -sequentially starting at 0. +Note [OccEnv] +~~~~~~~~~~~~~ +An OccEnv is a map keyed on OccName. Recall that an OccEnv consists of two +components: -So we can make a Unique using - mkUnique ns key :: Unique -where 'ns' is a Char representing the name space. This in turn makes it -easy to build an OccEnv. --} + - a namespace, + - a textual name (in the form of a FastString). -instance Uniquable OccName where - -- See Note [The Unique of an OccName] - getUnique (OccName VarName fs) = mkVarOccUnique fs - getUnique (OccName DataName fs) = mkDataOccUnique fs - getUnique (OccName TvName fs) = mkTvOccUnique fs - getUnique (OccName TcClsName fs) = mkTcOccUnique fs +In general, for a given textual name, there is only one appropriate namespace. +However, sometimes we do get an occurrence that belongs to several namespaces: -newtype OccEnv a = A (UniqFM OccName a) - deriving Data + - Symbolic identifiers such as (:+) can belong to both the data constructor and + type constructor/class namespaces. + - With duplicate record fields, a field name can belong to several different + namespaces, one for each parent datatype (or pattern synonym). +So we represent an OccEnv as a nested data structure + + FastStringEnv (UniqFM NameSpace a) + +in which we can first look up the textual name, and then choose which of the +namespaces are relevant. This supports the two main uses of OccEnvs: + + 1. One wants to look up a specific OccName in the environment, at a specific + namespace. One looks up the textual name, and then the namespace. + 2. One wants to look up something, but isn't sure in advance of the namespace. + So one looks up the textual name, and then can decide what to do based on + the returned map of namespaces. + +This data structure isn't performance critical in most situations, but some +improvements to its performance that might be worth it are as follows: + + A. Use a tailor-made data structure for a map keyed on NameSpaces. + + Recall that we have: + + data IntMap a = Bin !Int !Int !(IntMap a) !(IntMap a) + | Tip !Key a + | Nil + + This is already pretty efficient for singletons, but we don't need the + empty case (as we would simply omit the parent key in the OccEnv instead + of storing an empty inner map). + + B. Always ensure the inner map (keyed on namespaces) is evaluated, i.e. + is never a thunk. For this, we would need to use strict operations on + the outer FastStringEnv (but we'd keep using lazy operations on the inner + UniqFM). +-} + +-- | A map keyed on 'OccName'. See Note [OccEnv]. +newtype OccEnv a = MkOccEnv (FastStringEnv (UniqFM NameSpace a)) + deriving Functor + +-- | The empty 'OccEnv'. emptyOccEnv :: OccEnv a -unitOccEnv :: OccName -> a -> OccEnv a +emptyOccEnv = MkOccEnv emptyFsEnv + +-- | A singleton 'OccEnv'. +unitOccEnv :: OccName -> a -> OccEnv a +unitOccEnv (OccName ns s) a = MkOccEnv $ unitFsEnv s (unitUFM ns a) + +-- | Add a single element to an 'OccEnv'. extendOccEnv :: OccEnv a -> OccName -> a -> OccEnv a +extendOccEnv (MkOccEnv as) (OccName ns s) a = + MkOccEnv $ extendFsEnv_C plusUFM as s (unitUFM ns a) + +-- | Extend an 'OccEnv' by a list. +-- +-- 'OccName's later on in the list override earlier 'OccName's. extendOccEnvList :: OccEnv a -> [(OccName, a)] -> OccEnv a +extendOccEnvList = foldl' $ \ env (occ, a) -> extendOccEnv env occ a + +-- | Look an element up in an 'OccEnv'. lookupOccEnv :: OccEnv a -> OccName -> Maybe a -mkOccEnv :: [(OccName,a)] -> OccEnv a -mkOccEnv_C :: (a -> a -> a) -> [(OccName,a)] -> OccEnv a -elemOccEnv :: OccName -> OccEnv a -> Bool -foldOccEnv :: (a -> b -> b) -> b -> OccEnv a -> b -nonDetOccEnvElts :: OccEnv a -> [a] -extendOccEnv_C :: (a->a->a) -> OccEnv a -> OccName -> a -> OccEnv a -extendOccEnv_Acc :: (a->b->b) -> (a->b) -> OccEnv b -> OccName -> a -> OccEnv b -plusOccEnv :: OccEnv a -> OccEnv a -> OccEnv a -plusOccEnv_C :: (a->a->a) -> OccEnv a -> OccEnv a -> OccEnv a -mapOccEnv :: (a->b) -> OccEnv a -> OccEnv b -delFromOccEnv :: OccEnv a -> OccName -> OccEnv a +lookupOccEnv (MkOccEnv as) (OccName ns s) + = do { m <- lookupFsEnv as s + ; lookupUFM m ns } + +-- | Lookup an element in an 'OccEnv', ignoring 'NameSpace's entirely. +lookupOccEnv_AllNameSpaces :: OccEnv a -> OccName -> [a] +lookupOccEnv_AllNameSpaces (MkOccEnv as) (OccName _ s) + = case lookupFsEnv as s of + Nothing -> [] + Just r -> nonDetEltsUFM r + +-- | Lookup an element in an 'OccEnv', looking in the record field +-- namespace for a variable. +lookupOccEnv_WithFields :: OccEnv a -> OccName -> [a] +lookupOccEnv_WithFields env occ = + case lookupOccEnv env occ of + Nothing -> fieldGREs + Just gre -> gre : fieldGREs + where + fieldGREs + -- If the 'OccName' is a variable, also look up + -- in the record field namespaces. + | isVarOcc occ + = lookupFieldsOccEnv env (occNameFS occ) + | otherwise + = [] + +-- | Look up all the record fields that match with the given 'FastString' +-- in an 'OccEnv'. +lookupFieldsOccEnv :: OccEnv a -> FastString -> [a] +lookupFieldsOccEnv (MkOccEnv as) fld = + case lookupFsEnv as fld of + Nothing -> [] + Just flds -> nonDetEltsUFM $ filter_flds flds + -- NB: non-determinism is OK: in practice we will either end up resolving + -- to a single field or throwing an error. + where + filter_flds = filterUFM_Directly (\ uniq _ -> isFldNSUnique uniq) + +-- | Create an 'OccEnv' from a list. +-- +-- 'OccName's later on in the list override earlier 'OccName's. +mkOccEnv :: [(OccName,a)] -> OccEnv a +mkOccEnv = extendOccEnvList emptyOccEnv + +-- | Create an 'OccEnv' from a list, combining different values +-- with the same 'OccName' using the combining function. +mkOccEnv_C :: (a -> a -> a) -- ^ old -> new -> result + -> [(OccName,a)] + -> OccEnv a +mkOccEnv_C f elts + = MkOccEnv $ foldl' g emptyFsEnv elts + where + g env (OccName ns s, a) = + extendFsEnv_C (plusUFM_C $ flip f) env s (unitUFM ns a) + +-- | Compute whether there is a value keyed by the given 'OccName'. +elemOccEnv :: OccName -> OccEnv a -> Bool +elemOccEnv (OccName ns s) (MkOccEnv as) + = case lookupFsEnv as s of + Nothing -> False + Just m -> ns `elemUFM` m + +-- | Fold over an 'OccEnv'. Non-deterministic, unless the folding function +-- is commutative (i.e. @a1 `f` ( a2 `f` b ) == a2 `f` ( a1 `f` b )@ for all @a1@, @a2@, @b@). +nonDetFoldOccEnv :: (a -> b -> b) -> b -> OccEnv a -> b +nonDetFoldOccEnv f b0 (MkOccEnv as) = + nonDetFoldFsEnv (flip $ nonDetFoldUFM f) b0 as + +-- | Obtain the elements of an 'OccEnv'. +-- +-- The resulting order is non-deterministic. +nonDetOccEnvElts :: OccEnv a -> [a] +nonDetOccEnvElts = nonDetFoldOccEnv (:) [] + +-- | Union of two 'OccEnv's, right-biased. +plusOccEnv :: OccEnv a -> OccEnv a -> OccEnv a +plusOccEnv (MkOccEnv env1) (MkOccEnv env2) + = MkOccEnv $ plusFsEnv_C plusUFM env1 env2 + +-- | Union of two 'OccEnv's with a combining function. +plusOccEnv_C :: (a->a->a) -> OccEnv a -> OccEnv a -> OccEnv a +plusOccEnv_C f (MkOccEnv env1) (MkOccEnv env2) + = MkOccEnv $ plusFsEnv_C (plusUFM_C f) env1 env2 + +-- | Map over an 'OccEnv' ('Functor' instance). +mapOccEnv :: (a->b) -> OccEnv a -> OccEnv b +mapOccEnv = fmap + +-- | 'mapMaybe' for b 'OccEnv'. +mapMaybeOccEnv :: (a -> Maybe b) -> OccEnv a -> OccEnv b +mapMaybeOccEnv f (MkOccEnv env) + = MkOccEnv $ mapMaybeUFM g env + where + g as = + case mapMaybeUFM f as of + m' | isNullUFM m' -> Nothing + | otherwise -> Just m' + +-- | Add a single element to an 'OccEnv', using a different function whether +-- the 'OccName' already exists or not. +extendOccEnv_Acc :: forall a b + . (a->b->b) -- ^ add to existing + -> (a->b) -- ^ new element + -> OccEnv b -- ^ old + -> OccName -> a -- ^ new + -> OccEnv b +extendOccEnv_Acc f g (MkOccEnv env) (OccName ns s) = + MkOccEnv . extendFsEnv_Acc f' g' env s + where + f' :: a -> UniqFM NameSpace b -> UniqFM NameSpace b + f' a bs = alterUFM (Just . \ case { Nothing -> g a ; Just b -> f a b }) bs ns + g' a = unitUFM ns (g a) + +-- | Delete one element from an 'OccEnv'. +delFromOccEnv :: forall a. OccEnv a -> OccName -> OccEnv a +delFromOccEnv (MkOccEnv env1) (OccName ns s) = + MkOccEnv $ alterFsEnv f env1 s + where + f :: Maybe (UniqFM NameSpace a) -> Maybe (UniqFM NameSpace a) + f Nothing = Nothing + f (Just m) = + case delFromUFM m ns of + m' | isNullUFM m' -> Nothing + | otherwise -> Just m' + +-- | Delete multiple elements from an 'OccEnv'. delListFromOccEnv :: OccEnv a -> [OccName] -> OccEnv a -filterOccEnv :: (elt -> Bool) -> OccEnv elt -> OccEnv elt -alterOccEnv :: (Maybe elt -> Maybe elt) -> OccEnv elt -> OccName -> OccEnv elt +delListFromOccEnv = foldl' delFromOccEnv + +-- | Filter out all elements in an 'OccEnv' using a predicate. +filterOccEnv :: forall a. (a -> Bool) -> OccEnv a -> OccEnv a +filterOccEnv f (MkOccEnv env) = + MkOccEnv $ mapMaybeFsEnv g env + where + g :: UniqFM NameSpace a -> Maybe (UniqFM NameSpace a) + g ms = + case filterUFM f ms of + m' | isNullUFM m' -> Nothing + | otherwise -> Just m' + +-- | Alter an 'OccEnv', adding or removing an element at the given key. +alterOccEnv :: forall a. (Maybe a -> Maybe a) -> OccEnv a -> OccName -> OccEnv a +alterOccEnv f (MkOccEnv env) (OccName ns s) = + MkOccEnv $ alterFsEnv g env s + where + g :: Maybe (UniqFM NameSpace a) -> Maybe (UniqFM NameSpace a) + g Nothing = fmap (unitUFM ns) (f Nothing) + g (Just m) = + case alterUFM f m ns of + m' | isNullUFM m' -> Nothing + | otherwise -> Just m' + +intersectOccEnv_C :: (a -> b -> c) -> OccEnv a -> OccEnv b -> OccEnv c +intersectOccEnv_C f (MkOccEnv as) (MkOccEnv bs) + = MkOccEnv $ intersectUFM_C (intersectUFM_C f) as bs + +-- | Remove elements of the first 'OccEnv' that appear in the second 'OccEnv'. minusOccEnv :: OccEnv a -> OccEnv b -> OccEnv a +minusOccEnv = minusOccEnv_C_Ns minusUFM --- | Alters (replaces or removes) those elements of the map that are mentioned in the second map -minusOccEnv_C :: (a -> b -> Maybe a) -> OccEnv a -> OccEnv b -> OccEnv a +-- | Alters (replaces or removes) those elements of the first 'OccEnv' that are +-- mentioned in the second 'OccEnv'. +-- +-- Same idea as 'Data.Map.differenceWith'. +minusOccEnv_C :: (a -> b -> Maybe a) + -> OccEnv a -> OccEnv b -> OccEnv a +minusOccEnv_C f = minusOccEnv_C_Ns (minusUFM_C f) -emptyOccEnv = A emptyUFM -unitOccEnv x y = A $ unitUFM x y -extendOccEnv (A x) y z = A $ addToUFM x y z -extendOccEnvList (A x) l = A $ addListToUFM x l -lookupOccEnv (A x) y = lookupUFM x y -mkOccEnv l = A $ listToUFM l -elemOccEnv x (A y) = elemUFM x y -foldOccEnv a b (A c) = foldUFM a b c -nonDetOccEnvElts (A x) = nonDetEltsUFM x -plusOccEnv (A x) (A y) = A $ plusUFM x y -plusOccEnv_C f (A x) (A y) = A $ plusUFM_C f x y -extendOccEnv_C f (A x) y z = A $ addToUFM_C f x y z -extendOccEnv_Acc f g (A x) y z = A $ addToUFM_Acc f g x y z -mapOccEnv f (A x) = A $ mapUFM f x -mkOccEnv_C comb l = A $ addListToUFM_C comb emptyUFM l -delFromOccEnv (A x) y = A $ delFromUFM x y -delListFromOccEnv (A x) y = A $ delListFromUFM x y -filterOccEnv x (A y) = A $ filterUFM x y -alterOccEnv fn (A y) k = A $ alterUFM fn y k -minusOccEnv (A x) (A y) = A $ minusUFM x y -minusOccEnv_C fn (A x) (A y) = A $ minusUFM_C fn x y +minusOccEnv_C_Ns :: forall a b + . (UniqFM NameSpace a -> UniqFM NameSpace b -> UniqFM NameSpace a) + -> OccEnv a -> OccEnv b -> OccEnv a +minusOccEnv_C_Ns f (MkOccEnv as) (MkOccEnv bs) = + MkOccEnv $ minusUFM_C g as bs + where + g :: UniqFM NameSpace a -> UniqFM NameSpace b -> Maybe (UniqFM NameSpace a) + g as bs = + let m = f as bs + in if isNullUFM m + 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 pprOccEnv :: (a -> SDoc) -> OccEnv a -> SDoc -pprOccEnv ppr_elt (A env) = pprUniqFM ppr_elt env +pprOccEnv ppr_elt (MkOccEnv env) + = brackets $ fsep $ punctuate comma $ + [ ppr uq <+> text ":->" <+> ppr_elt elt + | (uq, elts) <- nonDetUFMToList env + , elt <- nonDetEltsUFM elts ] instance NFData a => NFData (OccEnv a) where rnf = forceOccEnv rnf +-- | Map over an 'OccEnv' strictly. +strictMapOccEnv :: (a -> b) -> OccEnv a -> OccEnv b +strictMapOccEnv f (MkOccEnv as) = + MkOccEnv $ strictMapFsEnv (strictMapUFM f) as + -- | Force an 'OccEnv' with the provided function. forceOccEnv :: (a -> ()) -> OccEnv a -> () -forceOccEnv nf (A fs) = seqEltsUFM nf fs +forceOccEnv nf (MkOccEnv fs) = seqEltsUFM (seqEltsUFM nf) fs -type OccSet = UniqSet OccName +-------------------------------------------------------------------------------- +newtype OccSet = OccSet (FastStringEnv (UniqSet NameSpace)) + emptyOccSet :: OccSet unitOccSet :: OccName -> OccSet mkOccSet :: [OccName] -> OccSet @@ -445,27 +841,18 @@ extendOccSetList :: OccSet -> [OccName] -> OccSet unionOccSets :: OccSet -> OccSet -> OccSet unionManyOccSets :: [OccSet] -> OccSet -minusOccSet :: OccSet -> OccSet -> OccSet elemOccSet :: OccName -> OccSet -> Bool isEmptyOccSet :: OccSet -> Bool -intersectOccSet :: OccSet -> OccSet -> OccSet -filterOccSet :: (OccName -> Bool) -> OccSet -> OccSet --- | Converts an OccSet to an OccEnv (operationally the identity) -occSetToEnv :: OccSet -> OccEnv OccName -emptyOccSet = emptyUniqSet -unitOccSet = unitUniqSet -mkOccSet = mkUniqSet -extendOccSet = addOneToUniqSet -extendOccSetList = addListToUniqSet -unionOccSets = unionUniqSets -unionManyOccSets = unionManyUniqSets -minusOccSet = minusUniqSet -elemOccSet = elementOfUniqSet -isEmptyOccSet = isEmptyUniqSet -intersectOccSet = intersectUniqSets -filterOccSet = filterUniqSet -occSetToEnv = A . getUniqSet +emptyOccSet = OccSet emptyFsEnv +unitOccSet (OccName ns s) = OccSet $ unitFsEnv s (unitUniqSet ns) +mkOccSet = extendOccSetList emptyOccSet +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) (OccSet occs) = maybe False (elementOfUniqSet ns) $ lookupFsEnv occs s +isEmptyOccSet (OccSet occs) = isNullUFM occs {- ************************************************************************ @@ -481,7 +868,7 @@ setOccNameSpace :: NameSpace -> OccName -> OccName setOccNameSpace sp (OccName _ occ) = OccName sp occ -isVarOcc, isTvOcc, isTcOcc, isDataOcc :: OccName -> Bool +isVarOcc, isTvOcc, isTcOcc, isDataOcc, isFieldOcc :: OccName -> Bool isVarOcc (OccName VarName _) = True isVarOcc _ = False @@ -492,12 +879,20 @@ isTcOcc (OccName TcClsName _) = True isTcOcc _ = False +isFieldOcc (OccName (FldName {}) _) = True +isFieldOcc _ = False + +fieldOcc_maybe :: OccName -> Maybe FastString +fieldOcc_maybe (OccName (FldName con) _) = Just con +fieldOcc_maybe _ = Nothing + -- | /Value/ 'OccNames's are those that are either in --- the variable or data constructor namespaces +-- the variable, field name or data constructor namespaces isValOcc :: OccName -> Bool -isValOcc (OccName VarName _) = True -isValOcc (OccName DataName _) = True -isValOcc _ = False +isValOcc (OccName VarName _) = True +isValOcc (OccName DataName _) = True +isValOcc (OccName (FldName {}) _) = True +isValOcc _ = False isDataOcc (OccName DataName _) = True isDataOcc _ = False @@ -512,10 +907,12 @@ -- | Test if the 'OccName' is that for any operator (whether -- it is a data constructor or variable or whatever) isSymOcc :: OccName -> Bool -isSymOcc (OccName DataName s) = isLexConSym s -isSymOcc (OccName TcClsName s) = isLexSym s -isSymOcc (OccName VarName s) = isLexSym s -isSymOcc (OccName TvName s) = isLexSym s +isSymOcc (OccName ns s) = case ns of + DataName -> isLexConSym s + TcClsName -> isLexSym s + VarName -> isLexSym s + TvName -> isLexSym s + FldName {} -> isLexSym s -- Pretty inefficient! parenSymOcc :: OccName -> SDoc -> SDoc @@ -530,6 +927,9 @@ '_':_ -> True _ -> False +isUnderscore :: OccName -> Bool +isUnderscore occ = occNameFS occ == fsLit "_" + {- ************************************************************************ * * @@ -652,10 +1052,6 @@ mkGenR = mk_simple_deriv tcName "Rep_" mkGen1R = mk_simple_deriv tcName "Rep1_" --- Overloaded record field selectors -mkRecFldSelOcc :: FastString -> OccName -mkRecFldSelOcc s = mk_deriv varName "$sel" [s] - mk_simple_deriv :: NameSpace -> FastString -> OccName -> OccName mk_simple_deriv sp px occ = mk_deriv sp px [occNameFS occ] @@ -762,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 @@ -817,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. @@ -837,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 @@ -882,10 +1286,38 @@ -- 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 {- ************************************************************************ * * + Utilies for "main" +* * +************************************************************************ +-} + +mainOcc :: OccName +mainOcc = mkVarOccFS (fsLit "main") + +ppMainFn :: OccName -> SDoc +ppMainFn main_occ + | main_occ == mainOcc + = text "IO action" <+> quotes (ppr main_occ) + | otherwise + = text "main IO action" <+> quotes (ppr main_occ) + +{- +************************************************************************ +* * Binary instance Here rather than in GHC.Iface.Binary because OccName is abstract * * @@ -901,13 +1333,19 @@ putByte bh 2 put_ bh TcClsName = putByte bh 3 + put_ bh (FldName parent) = do + putByte bh 4 + put_ bh parent get bh = do h <- getByte bh case h of 0 -> return VarName 1 -> return DataName 2 -> return TvName - _ -> return TcClsName + 3 -> return TcClsName + _ -> do + parent <- get bh + return $ FldName { fldParent = parent } instance Binary OccName where put_ bh (OccName aa ab) = do diff --git a/GHC/Types/Name/Occurrence.hs-boot b/GHC/Types/Name/Occurrence.hs-boot --- a/GHC/Types/Name/Occurrence.hs-boot +++ b/GHC/Types/Name/Occurrence.hs-boot @@ -8,5 +8,4 @@ occName :: name -> OccName occNameFS :: OccName -> FastString -mkRecFldSelOcc :: FastString -> OccName mkVarOccFS :: FastString -> OccName 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 @@ -23,6 +24,7 @@ import GHC.Utils.Misc import GHC.Builtin.Types.Prim ( fUNTyConName ) import GHC.Builtin.Types +import Data.Maybe (isJust) {- @@ -67,71 +69,83 @@ -- | Creates some functions that work out the best ways to format -- names for the user according to a set of heuristics. -mkNamePprCtx :: PromotionTickContext -> UnitEnv -> GlobalRdrEnv -> NamePprCtx +mkNamePprCtx :: Outputable info => PromotionTickContext -> UnitEnv -> GlobalRdrEnvX info -> NamePprCtx 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 :: GlobalRdrEnv -> QueryQualifyName +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_RdrName (mkRdrQual (moduleName mod) occ) env) - 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 - , manyDataConName ] + | 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_RdrName (mkRdrUnqual occ) env - qual_gres = filter right_name (lookupGlobalRdrEnv env occ) + -- 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). -mkPromTick :: PromotionTickContext -> GlobalRdrEnv -> QueryPromotionTick +mkPromTick :: PromotionTickContext -> GlobalRdrEnvX info -> QueryPromotionTick mkPromTick ptc env | ptcPrintRedundantPromTicks ptc = alwaysPrintPromTick | otherwise = print_prom_tick @@ -147,7 +161,7 @@ = ptcListTuplePuns ptc | Just occ' <- promoteOccName occ - , [] <- lookupGRE_RdrName (mkRdrUnqual occ') env + , [] <- lookupGRE env (LookupRdrName (mkRdrUnqual occ') SameNameSpace) = -- Could not find a corresponding type name in the environment, -- so the data name is unambiguous. Promotion tick not needed. False @@ -201,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,1386 +5,2227 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} - --- | --- #name_types# --- GHC uses several kinds of name internally: --- --- * 'GHC.Types.Name.Occurrence.OccName': see "GHC.Types.Name.Occurrence#name_types" --- --- * 'GHC.Types.Name.Reader.RdrName' is the type of names that come directly from the parser. They --- have not yet had their scoping and binding resolved by the renamer and can be --- thought of to a first approximation as an 'GHC.Types.Name.Occurrence.OccName' with an optional module --- qualifier --- --- * 'GHC.Types.Name.Name': see "GHC.Types.Name#name_types" --- --- * 'GHC.Types.Id.Id': see "GHC.Types.Id#name_types" --- --- * 'GHC.Types.Var.Var': see "GHC.Types.Var#name_types" - -module GHC.Types.Name.Reader ( - -- * The main type - RdrName(..), -- Constructors exported only to GHC.Iface.Binary - - -- ** Construction - mkRdrUnqual, mkRdrQual, - mkUnqual, mkVarUnqual, mkQual, mkOrig, - nameRdrName, getRdrName, - - -- ** Destruction - rdrNameOcc, rdrNameSpace, demoteRdrName, promoteRdrName, - isRdrDataCon, isRdrTyVar, isRdrTc, isQual, isQual_maybe, isUnqual, - isOrig, isOrig_maybe, isExact, isExact_maybe, isSrcRdrName, - - -- * Local mapping of 'RdrName' to 'Name.Name' - LocalRdrEnv, emptyLocalRdrEnv, extendLocalRdrEnv, extendLocalRdrEnvList, - lookupLocalRdrEnv, lookupLocalRdrOcc, - elemLocalRdrEnv, inLocalRdrEnvScope, - localRdrEnvElts, minusLocalRdrEnv, - - -- * Global mapping of 'RdrName' to 'GlobalRdrElt's - GlobalRdrEnv, emptyGlobalRdrEnv, mkGlobalRdrEnv, plusGlobalRdrEnv, - lookupGlobalRdrEnv, extendGlobalRdrEnv, greOccName, shadowNames, - pprGlobalRdrEnv, globalRdrEnvElts, - lookupGRE_RdrName, lookupGRE_RdrName', lookupGRE_Name, - lookupGRE_GreName, lookupGRE_FieldLabel, - lookupGRE_Name_OccName, - getGRE_NameQualifier_maybes, - transformGREs, pickGREs, pickGREsModExp, - - -- * GlobalRdrElts - gresFromAvails, gresFromAvail, localGREsFromAvail, availFromGRE, - greRdrNames, greSrcSpan, greQualModName, - gresToAvailInfo, - greDefinitionModule, greDefinitionSrcSpan, - greMangledName, grePrintableName, - greFieldLabel, - - -- ** Global 'RdrName' mapping elements: 'GlobalRdrElt', 'Provenance', 'ImportSpec' - GlobalRdrElt(..), isLocalGRE, isRecFldGRE, - isDuplicateRecFldGRE, isNoFieldSelectorGRE, isFieldSelectorGRE, - unQualOK, qualSpecOK, unQualSpecOK, - pprNameProvenance, - GreName(..), greNameSrcSpan, - Parent(..), greParent_maybe, - ImportSpec(..), ImpDeclSpec(..), ImpItemSpec(..), - importSpecLoc, importSpecModule, isExplicitItem, bestImport, - - -- * Utils - opIsAt - ) where - -import GHC.Prelude - -import GHC.Unit.Module -import GHC.Types.Name -import GHC.Types.Avail -import GHC.Types.Name.Set -import GHC.Data.Maybe -import GHC.Types.SrcLoc as SrcLoc -import GHC.Data.FastString -import GHC.Types.FieldLabel -import GHC.Utils.Outputable -import GHC.Types.Unique -import GHC.Types.Unique.FM -import GHC.Types.Unique.Set -import GHC.Utils.Misc as Utils -import GHC.Utils.Panic -import GHC.Types.Name.Env - -import Language.Haskell.Syntax.Basic (FieldLabelString(..)) - -import Data.Data -import Data.List( sortBy ) -import qualified Data.Semigroup as S -import Control.DeepSeq -import GHC.Data.Bag - -{- -************************************************************************ -* * -\subsection{The main data type} -* * -************************************************************************ --} - --- | Reader Name --- --- Do not use the data constructors of RdrName directly: prefer the family --- of functions that creates them, such as 'mkRdrUnqual' --- --- - Note: A Located RdrName will only have API Annotations if it is a --- compound one, --- e.g. --- --- > `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 - -- - -- Used for ordinary, unqualified occurrences, e.g. @x@, @y@ or @Foo@. - -- Create such a 'RdrName' with 'mkRdrUnqual' - - | Qual ModuleName OccName - -- ^ Qualified name - -- - -- A qualified name written by the user in - -- /source/ code. The module isn't necessarily - -- the module where the thing is defined; - -- just the one from which it is imported. - -- Examples are @Bar.x@, @Bar.y@ or @Bar.Foo@. - -- Create such a 'RdrName' with 'mkRdrQual' - - | Orig Module OccName - -- ^ Original name - -- - -- An original name; the module is the /defining/ module. - -- This is used when GHC generates code that will be fed - -- into the renamer (e.g. from deriving clauses), but where - -- we want to say \"Use Prelude.map dammit\". One of these - -- can be created with 'mkOrig' - - | Exact Name - -- ^ Exact name - -- - -- We know exactly the 'Name'. This is used: - -- - -- (1) When the parser parses built-in syntax like @[]@ - -- and @(,)@, but wants a 'RdrName' from it - -- - -- (2) By Template Haskell, when TH has generated a unique name - -- - -- Such a 'RdrName' can be created by using 'getRdrName' on a 'Name' - deriving Data - -{- -************************************************************************ -* * -\subsection{Simple functions} -* * -************************************************************************ --} - -instance HasOccName RdrName where - occName = rdrNameOcc - -rdrNameOcc :: RdrName -> OccName -rdrNameOcc (Qual _ occ) = occ -rdrNameOcc (Unqual occ) = occ -rdrNameOcc (Orig _ occ) = occ -rdrNameOcc (Exact name) = nameOccName name - -rdrNameSpace :: RdrName -> NameSpace -rdrNameSpace = occNameSpace . rdrNameOcc - --- demoteRdrName lowers the NameSpace of RdrName. --- See Note [Demotion] in GHC.Rename.Env -demoteRdrName :: RdrName -> Maybe RdrName -demoteRdrName (Unqual occ) = fmap Unqual (demoteOccName occ) -demoteRdrName (Qual m occ) = fmap (Qual m) (demoteOccName occ) -demoteRdrName (Orig _ _) = Nothing -demoteRdrName (Exact _) = Nothing - --- promoteRdrName promotes the NameSpace of RdrName. --- See Note [Promotion] in GHC.Rename.Env. -promoteRdrName :: RdrName -> Maybe RdrName -promoteRdrName (Unqual occ) = fmap Unqual (promoteOccName occ) -promoteRdrName (Qual m occ) = fmap (Qual m) (promoteOccName occ) -promoteRdrName (Orig _ _) = Nothing -promoteRdrName (Exact _) = Nothing - - -- These two are the basic constructors -mkRdrUnqual :: OccName -> RdrName -mkRdrUnqual occ = Unqual occ - -mkRdrQual :: ModuleName -> OccName -> RdrName -mkRdrQual mod occ = Qual mod occ - -mkOrig :: Module -> OccName -> RdrName -mkOrig mod occ = Orig mod occ - ---------------- - -- These two are used when parsing source files - -- They do encode the module and occurrence names -mkUnqual :: NameSpace -> FastString -> RdrName -mkUnqual sp n = Unqual (mkOccNameFS sp n) - -mkVarUnqual :: FastString -> RdrName -mkVarUnqual n = Unqual (mkVarOccFS n) - --- | Make a qualified 'RdrName' in the given namespace and where the 'ModuleName' and --- the 'OccName' are taken from the first and second elements of the tuple respectively -mkQual :: NameSpace -> (FastString, FastString) -> RdrName -mkQual sp (m, n) = Qual (mkModuleNameFS m) (mkOccNameFS sp n) - -getRdrName :: NamedThing thing => thing -> RdrName -getRdrName name = nameRdrName (getName name) - -nameRdrName :: Name -> RdrName -nameRdrName name = Exact name --- Keep the Name even for Internal names, so that the --- unique is still there for debug printing, particularly --- of Types (which are converted to IfaceTypes before printing) - -nukeExact :: Name -> RdrName -nukeExact n - | isExternalName n = Orig (nameModule n) (nameOccName n) - | otherwise = Unqual (nameOccName n) - -isRdrDataCon :: RdrName -> Bool -isRdrTyVar :: RdrName -> Bool -isRdrTc :: RdrName -> Bool - -isRdrDataCon rn = isDataOcc (rdrNameOcc rn) -isRdrTyVar rn = isTvOcc (rdrNameOcc rn) -isRdrTc rn = isTcOcc (rdrNameOcc rn) - -isSrcRdrName :: RdrName -> Bool -isSrcRdrName (Unqual _) = True -isSrcRdrName (Qual _ _) = True -isSrcRdrName _ = False - -isUnqual :: RdrName -> Bool -isUnqual (Unqual _) = True -isUnqual _ = False - -isQual :: RdrName -> Bool -isQual (Qual _ _) = True -isQual _ = False - -isQual_maybe :: RdrName -> Maybe (ModuleName, OccName) -isQual_maybe (Qual m n) = Just (m,n) -isQual_maybe _ = Nothing - -isOrig :: RdrName -> Bool -isOrig (Orig _ _) = True -isOrig _ = False - -isOrig_maybe :: RdrName -> Maybe (Module, OccName) -isOrig_maybe (Orig m n) = Just (m,n) -isOrig_maybe _ = Nothing - -isExact :: RdrName -> Bool -isExact (Exact _) = True -isExact _ = False - -isExact_maybe :: RdrName -> Maybe Name -isExact_maybe (Exact n) = Just n -isExact_maybe _ = Nothing - -{- -************************************************************************ -* * -\subsection{Instances} -* * -************************************************************************ --} - -instance Outputable RdrName where - 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) - -instance OutputableBndr RdrName where - pprBndr _ n - | isTvOcc (rdrNameOcc n) = char '@' <> ppr n - | otherwise = ppr n - - pprInfixOcc rdr = pprInfixVar (isSymOcc (rdrNameOcc rdr)) (ppr rdr) - pprPrefixOcc rdr - | Just name <- isExact_maybe rdr = pprPrefixName name - -- pprPrefixName has some special cases, so - -- we delegate to them rather than reproduce them - | otherwise = pprPrefixVar (isSymOcc (rdrNameOcc rdr)) (ppr rdr) - -instance Eq RdrName where - (Exact n1) == (Exact n2) = n1==n2 - -- Convert exact to orig - (Exact n1) == r2@(Orig _ _) = nukeExact n1 == r2 - r1@(Orig _ _) == (Exact n2) = r1 == nukeExact n2 - - (Orig m1 o1) == (Orig m2 o2) = m1==m2 && o1==o2 - (Qual m1 o1) == (Qual m2 o2) = m1==m2 && o1==o2 - (Unqual o1) == (Unqual o2) = o1==o2 - _ == _ = False - -instance Ord RdrName where - a <= b = case (a `compare` b) of { LT -> True; EQ -> True; GT -> False } - a < b = case (a `compare` b) of { LT -> True; EQ -> False; GT -> False } - a >= b = case (a `compare` b) of { LT -> False; EQ -> True; GT -> True } - a > b = case (a `compare` b) of { LT -> False; EQ -> False; GT -> True } - - -- Exact < Unqual < Qual < Orig - -- [Note: Apr 2004] We used to use nukeExact to convert Exact to Orig - -- before comparing so that Prelude.map == the exact Prelude.map, but - -- that meant that we reported duplicates when renaming bindings - -- generated by Template Haskell; e.g - -- do { n1 <- newName "foo"; n2 <- newName "foo"; - -- } - -- I think we can do without this conversion - compare (Exact n1) (Exact n2) = n1 `compare` n2 - compare (Exact _) _ = LT - - compare (Unqual _) (Exact _) = GT - compare (Unqual o1) (Unqual o2) = o1 `compare` o2 - compare (Unqual _) _ = LT - - compare (Qual _ _) (Exact _) = GT - compare (Qual _ _) (Unqual _) = GT - compare (Qual m1 o1) (Qual m2 o2) = compare o1 o2 S.<> compare m1 m2 - compare (Qual _ _) (Orig _ _) = LT - - compare (Orig m1 o1) (Orig m2 o2) = compare o1 o2 S.<> compare m1 m2 - compare (Orig _ _) _ = GT - -{- -************************************************************************ -* * - LocalRdrEnv -* * -************************************************************************ --} - -{- Note [LocalRdrEnv] -~~~~~~~~~~~~~~~~~~~~~ -The LocalRdrEnv is used to store local bindings (let, where, lambda, case). - -* It is keyed by OccName, because we never use it for qualified names. - -* It maps the OccName to a Name. That Name is almost always an - Internal Name, but (hackily) it can be External too for top-level - pattern bindings. See Note [bindLocalNames for an External name] - in GHC.Rename.Pat - -* We keep the current mapping (lre_env), *and* the set of all Names in - scope (lre_in_scope). Reason: see Note [Splicing Exact names] in - GHC.Rename.Env. --} - --- | Local Reader Environment --- See Note [LocalRdrEnv] -data LocalRdrEnv = LRE { lre_env :: OccEnv Name - , lre_in_scope :: NameSet } - -instance Outputable LocalRdrEnv where - ppr (LRE {lre_env = env, lre_in_scope = ns}) - = hang (text "LocalRdrEnv {") - 2 (vcat [ text "env =" <+> pprOccEnv ppr_elt env - , text "in_scope =" - <+> pprUFM (getUniqSet ns) (braces . pprWithCommas ppr) - ] <+> char '}') - where - ppr_elt name = parens (ppr (getUnique (nameOccName name))) <+> ppr name - -- So we can see if the keys line up correctly - -emptyLocalRdrEnv :: LocalRdrEnv -emptyLocalRdrEnv = LRE { lre_env = emptyOccEnv - , lre_in_scope = emptyNameSet } - -extendLocalRdrEnv :: LocalRdrEnv -> Name -> LocalRdrEnv --- See Note [LocalRdrEnv] -extendLocalRdrEnv lre@(LRE { lre_env = env, lre_in_scope = ns }) name - = lre { lre_env = extendOccEnv env (nameOccName name) name - , lre_in_scope = extendNameSet ns name } - -extendLocalRdrEnvList :: LocalRdrEnv -> [Name] -> LocalRdrEnv --- See Note [LocalRdrEnv] -extendLocalRdrEnvList lre@(LRE { lre_env = env, lre_in_scope = ns }) names - = lre { lre_env = extendOccEnvList env [(nameOccName n, n) | n <- names] - , lre_in_scope = extendNameSetList ns names } - -lookupLocalRdrEnv :: LocalRdrEnv -> RdrName -> Maybe Name -lookupLocalRdrEnv (LRE { lre_env = env, lre_in_scope = ns }) rdr - | Unqual occ <- rdr - = lookupOccEnv env occ - - -- See Note [Local bindings with Exact Names] - | Exact name <- rdr - , name `elemNameSet` ns - = Just name - - | otherwise - = Nothing - -lookupLocalRdrOcc :: LocalRdrEnv -> OccName -> Maybe Name -lookupLocalRdrOcc (LRE { lre_env = env }) occ = lookupOccEnv env occ - -elemLocalRdrEnv :: RdrName -> LocalRdrEnv -> Bool -elemLocalRdrEnv rdr_name (LRE { lre_env = env, lre_in_scope = ns }) - = case rdr_name of - Unqual occ -> occ `elemOccEnv` env - Exact name -> name `elemNameSet` ns -- See Note [Local bindings with Exact Names] - Qual {} -> False - Orig {} -> False - -localRdrEnvElts :: LocalRdrEnv -> [Name] -localRdrEnvElts (LRE { lre_env = env }) = nonDetOccEnvElts env - -inLocalRdrEnvScope :: Name -> LocalRdrEnv -> Bool --- This is the point of the NameSet -inLocalRdrEnvScope name (LRE { lre_in_scope = ns }) = name `elemNameSet` ns - -minusLocalRdrEnv :: LocalRdrEnv -> OccEnv a -> LocalRdrEnv -minusLocalRdrEnv lre@(LRE { lre_env = env }) occs - = lre { lre_env = minusOccEnv env occs } - -{- -Note [Local bindings with Exact Names] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -With Template Haskell we can make local bindings that have Exact Names. -Computing shadowing etc may use elemLocalRdrEnv (at least it certainly -does so in GHC.Rename.HsType.bindHsQTyVars), so for an Exact Name we must consult -the in-scope-name-set. - - -************************************************************************ -* * - GlobalRdrEnv -* * -************************************************************************ --} - --- | Global Reader Environment -type GlobalRdrEnv = OccEnv [GlobalRdrElt] --- ^ Keyed by 'OccName'; when looking up a qualified name --- we look up the 'OccName' part, and then check the 'Provenance' --- to see if the appropriate qualification is valid. This --- saves routinely doubling the size of the env by adding both --- qualified and unqualified names to the domain. --- --- The list in the codomain is required because there may be name clashes --- These only get reported on lookup, not on construction --- --- INVARIANT 1: All the members of the list have distinct --- 'gre_name' fields; that is, no duplicate Names --- --- INVARIANT 2: Imported provenance => Name is an ExternalName --- However LocalDefs can have an InternalName. This --- happens only when type-checking a [d| ... |] Template --- Haskell quotation; see this note in GHC.Rename.Names --- Note [Top-level Names in Template Haskell decl quotes] --- --- INVARIANT 3: If the GlobalRdrEnv maps [occ -> gre], then --- greOccName gre = occ --- --- NB: greOccName gre is usually the same as --- nameOccName (greMangledName gre), but not always in the --- case of record selectors; see Note [GreNames] - --- | Global Reader Element --- --- An element of the 'GlobalRdrEnv' -data GlobalRdrElt - = GRE { gre_name :: !GreName -- ^ See Note [GreNames] - , gre_par :: !Parent -- ^ See Note [Parents] - , gre_lcl :: !Bool -- ^ True <=> the thing was defined locally - , gre_imp :: !(Bag ImportSpec) -- ^ In scope through these imports - } deriving (Data) - -- INVARIANT: either gre_lcl = True or gre_imp is non-empty - -- See Note [GlobalRdrElt provenance] - -instance NFData GlobalRdrElt where - rnf (GRE name par _ imp) = rnf name `seq` rnf par `seq` rnf imp - - --- | See Note [Parents] -data Parent = NoParent - | ParentIs { par_is :: !Name } - deriving (Eq, Data) - -instance Outputable Parent where - ppr NoParent = empty - ppr (ParentIs n) = text "parent:" <> ppr n - -instance NFData Parent where - rnf NoParent = () - rnf (ParentIs n) = rnf n - -plusParent :: Parent -> Parent -> Parent --- See Note [Combining parents] -plusParent p1@(ParentIs _) p2 = hasParent p1 p2 -plusParent p1 p2@(ParentIs _) = hasParent p2 p1 -plusParent NoParent NoParent = NoParent - -hasParent :: Parent -> Parent -> Parent -#if defined(DEBUG) -hasParent p NoParent = p -hasParent p p' - | p /= p' = pprPanic "hasParent" (ppr p <+> ppr p') -- Parents should agree -#endif -hasParent p _ = p - - -{- Note [GlobalRdrElt provenance] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The gre_lcl and gre_imp fields of a GlobalRdrElt describe its "provenance", -i.e. how the Name came to be in scope. It can be in scope two ways: - - gre_lcl = True: it is bound in this module - - gre_imp: a list of all the imports that brought it into scope - -It's an INVARIANT that you have one or the other; that is, either -gre_lcl is True, or gre_imp is non-empty. - -It is just possible to have *both* if there is a module loop: a Name -is defined locally in A, and also brought into scope by importing a -module that SOURCE-imported A. Example (#7672): - - A.hs-boot module A where - data T - - B.hs module B(Decl.T) where - import {-# SOURCE #-} qualified A as Decl - - A.hs module A where - import qualified B - data T = Z | S B.T - -In A.hs, 'T' is locally bound, *and* imported as B.T. - - -Note [Parents] -~~~~~~~~~~~~~~~~~ -The children of a Name are the things that are abbreviated by the ".." notation -in export lists. - -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - Parent Children -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - data T Data constructors - Record-field ids - - data family T Data constructors and record-field ids - of all visible data instances of T - - class C Class operations - Associated type constructors - -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - Constructor Meaning -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - NoParent Not bundled with a type constructor. - ParentIs n Bundled with the type constructor corresponding to n. - -Pattern synonym constructors (and their record fields, if any) are unusual: -their gre_par is NoParent in the module in which they are defined. However, a -pattern synonym can be bundled with a type constructor on export, in which case -whenever the pattern synonym is imported the gre_par will be ParentIs. - -Thus the gre_name and gre_par fields are independent, because a normal datatype -introduces FieldGreNames using ParentIs, but a record pattern synonym can -introduce FieldGreNames that use NoParent. (In the past we represented fields -using an additional constructor of the Parent type, which could not adequately -represent this situation.) See also -Note [Representing pattern synonym fields in AvailInfo] in GHC.Types.Avail. - - -Note [GreNames] -~~~~~~~~~~~~~~~ -A `GlobalRdrElt` has a field `gre_name :: GreName`, which uniquely -identifies what the `GlobalRdrElt` describes. There are two sorts of -`GreName` (see the data type decl): - -* NormalGreName Name: this is used for most entities; the Name - uniquely identifies it. It is stored in the GlobalRdrEnv under - the OccName of the Name. - -* FieldGreName FieldLabel: is used only for field labels of a - record. With -XDuplicateRecordFields there may be many field - labels `x` in scope; e.g. - data T1 = MkT1 { x :: Int } - data T2 = MkT2 { x :: Bool } - Each has a different GlobalRdrElt with a distinct GreName. - The two fields are uniquely identified by their record selectors, - which are stored in the FieldLabel, and have mangled names like - `$sel:x:MkT1`. See Note [FieldLabel] in GHC.Types.FieldLabel. - - These GREs are stored in the GlobalRdrEnv under the OccName of the - field (i.e. "x" in both cases above), /not/ the OccName of the mangled - record selector function. - -A GreName, and hence a GRE, has both a "printable" and a "mangled" Name. These -are identical for normal names, but for record fields compiled with --XDuplicateRecordFields they will differ. So we have two pairs of functions: - - * greNameMangledName :: GreName -> Name - greMangledName :: GlobalRdrElt -> Name - The "mangled" Name is the actual Name of the selector function, - e.g. $sel:x:MkT1. This should not be displayed to the user, but is used to - uniquely identify the field in the renamer, and later in the backend. - - * greNamePrintableName :: GreName -> Name - grePrintableName :: GlobalRdrElt -> Name - The "printable" Name is the "manged" Name with its OccName replaced with that - of the field label. This is how the field should be output to the user. - -Since the right Name to use is context-dependent, we do not define a NamedThing -instance for GREName (or GlobalRdrElt), but instead make the choice explicit. - - -Note [Combining parents] -~~~~~~~~~~~~~~~~~~~~~~~~ -With an associated type we might have - module M where - class C a where - data T a - op :: T a -> a - instance C Int where - data T Int = TInt - instance C Bool where - data T Bool = TBool - -Then: C is the parent of T - T is the parent of TInt and TBool -So: in an export list - C(..) is short for C( op, T ) - T(..) is short for T( TInt, TBool ) - -Module M exports everything, so its exports will be - AvailTC C [C,T,op] - AvailTC T [T,TInt,TBool] -On import we convert to GlobalRdrElt and then combine -those. For T that will mean we have - one GRE with Parent C - one GRE with NoParent -That's why plusParent picks the "best" case. --} - --- | make a 'GlobalRdrEnv' where all the elements point to the same --- Provenance (useful for "hiding" imports, or imports with no details). -gresFromAvails :: Maybe ImportSpec -> [AvailInfo] -> [GlobalRdrElt] --- prov = Nothing => locally bound --- Just spec => imported as described by spec -gresFromAvails prov avails - = concatMap (gresFromAvail (const prov)) avails - -localGREsFromAvail :: AvailInfo -> [GlobalRdrElt] --- Turn an Avail into a list of LocalDef GlobalRdrElts -localGREsFromAvail = gresFromAvail (const Nothing) - -gresFromAvail :: (Name -> Maybe ImportSpec) -> AvailInfo -> [GlobalRdrElt] -gresFromAvail prov_fn avail - = map mk_gre (availNonFldNames avail) ++ map mk_fld_gre (availFlds avail) - where - mk_gre n - = case prov_fn n of -- Nothing => bound locally - -- Just is => imported from 'is' - Nothing -> GRE { gre_name = NormalGreName n, gre_par = mkParent n avail - , gre_lcl = True, gre_imp = emptyBag } - Just is -> GRE { gre_name = NormalGreName n, gre_par = mkParent n avail - , gre_lcl = False, gre_imp = unitBag is } - - mk_fld_gre fl - = case prov_fn (flSelector fl) of -- Nothing => bound locally - -- Just is => imported from 'is' - Nothing -> GRE { gre_name = FieldGreName fl, gre_par = availParent avail - , gre_lcl = True, gre_imp = emptyBag } - Just is -> GRE { gre_name = FieldGreName fl, gre_par = availParent avail - , gre_lcl = False, gre_imp = unitBag is } - -instance HasOccName GlobalRdrElt where - occName = greOccName - --- | See Note [GreNames] -greOccName :: GlobalRdrElt -> OccName -greOccName = occName . gre_name - --- | A 'Name' for the GRE for internal use. Careful: the 'OccName' of this --- 'Name' is not necessarily the same as the 'greOccName' (see Note [GreNames]). -greMangledName :: GlobalRdrElt -> Name -greMangledName = greNameMangledName . gre_name - --- | A 'Name' for the GRE suitable for output to the user. Its 'OccName' will --- be the 'greOccName' (see Note [GreNames]). -grePrintableName :: GlobalRdrElt -> Name -grePrintableName = greNamePrintableName . gre_name - --- | The SrcSpan of the name pointed to by the GRE. -greDefinitionSrcSpan :: GlobalRdrElt -> SrcSpan -greDefinitionSrcSpan = nameSrcSpan . greMangledName - --- | The module in which the name pointed to by the GRE is defined. -greDefinitionModule :: GlobalRdrElt -> Maybe Module -greDefinitionModule = nameModule_maybe . greMangledName - -greQualModName :: GlobalRdrElt -> ModuleName --- Get a suitable module qualifier for the GRE --- (used in mkPrintUnqualified) --- Precondition: the greMangledName is always External -greQualModName gre@(GRE { gre_lcl = lcl, gre_imp = iss }) - | lcl, Just mod <- greDefinitionModule gre = moduleName mod - | Just is <- headMaybe iss = is_as (is_decl is) - | otherwise = pprPanic "greQualModName" (ppr gre) - -greRdrNames :: GlobalRdrElt -> [RdrName] -greRdrNames gre@GRE{ gre_lcl = lcl, gre_imp = iss } - = bagToList $ (if lcl then unitBag unqual else emptyBag) `unionBags` concatMapBag do_spec (mapBag is_decl iss) - where - occ = greOccName gre - unqual = Unqual occ - do_spec decl_spec - | is_qual decl_spec = unitBag qual - | otherwise = listToBag [unqual,qual] - where qual = Qual (is_as decl_spec) occ - --- the SrcSpan that pprNameProvenance prints out depends on whether --- the Name is defined locally or not: for a local definition the --- definition site is used, otherwise the location of the import --- declaration. We want to sort the export locations in --- exportClashErr by this SrcSpan, we need to extract it: -greSrcSpan :: GlobalRdrElt -> SrcSpan -greSrcSpan gre@(GRE { gre_lcl = lcl, gre_imp = iss } ) - | lcl = greDefinitionSrcSpan gre - | Just is <- headMaybe iss = is_dloc (is_decl is) - | otherwise = pprPanic "greSrcSpan" (ppr gre) - -mkParent :: Name -> AvailInfo -> Parent -mkParent _ (Avail _) = NoParent -mkParent n (AvailTC m _) | n == m = NoParent - | otherwise = ParentIs m - -availParent :: AvailInfo -> Parent -availParent (AvailTC m _) = ParentIs m -availParent (Avail {}) = NoParent - - -greParent_maybe :: GlobalRdrElt -> Maybe Name -greParent_maybe gre = case gre_par gre of - NoParent -> Nothing - ParentIs n -> Just n - --- | Takes a list of distinct GREs and folds them --- into AvailInfos. This is more efficient than mapping each individual --- GRE to an AvailInfo and the folding using `plusAvail` but needs the --- uniqueness assumption. -gresToAvailInfo :: [GlobalRdrElt] -> [AvailInfo] -gresToAvailInfo gres - = nonDetNameEnvElts avail_env - where - avail_env :: NameEnv AvailInfo -- Keyed by the parent - (avail_env, _) = foldl' add (emptyNameEnv, emptyNameSet) gres - - add :: (NameEnv AvailInfo, NameSet) - -> GlobalRdrElt - -> (NameEnv AvailInfo, NameSet) - add (env, done) gre - | name `elemNameSet` done - = (env, done) -- Don't insert twice into the AvailInfo - | otherwise - = ( extendNameEnv_Acc comb availFromGRE env key gre - , done `extendNameSet` name ) - where - name = greMangledName gre - key = case greParent_maybe gre of - Just parent -> parent - Nothing -> greMangledName gre - - -- We want to insert the child `k` into a list of children but - -- need to maintain the invariant that the parent is first. - -- - -- We also use the invariant that `k` is not already in `ns`. - insertChildIntoChildren :: Name -> [GreName] -> GreName -> [GreName] - insertChildIntoChildren _ [] k = [k] - insertChildIntoChildren p (n:ns) k - | NormalGreName p == k = k:n:ns - | otherwise = n:k:ns - - comb :: GlobalRdrElt -> AvailInfo -> AvailInfo - comb _ (Avail n) = Avail n -- Duplicated name, should not happen - comb gre (AvailTC m ns) - = case gre_par gre of - NoParent -> AvailTC m (gre_name gre:ns) -- Not sure this ever happens - ParentIs {} -> AvailTC m (insertChildIntoChildren m ns (gre_name gre)) - -availFromGRE :: GlobalRdrElt -> AvailInfo -availFromGRE (GRE { gre_name = child, gre_par = parent }) - = case parent of - ParentIs p -> AvailTC p [child] - NoParent | NormalGreName me <- child, isTyConName me -> AvailTC me [child] - | otherwise -> Avail child - -emptyGlobalRdrEnv :: GlobalRdrEnv -emptyGlobalRdrEnv = emptyOccEnv - -globalRdrEnvElts :: GlobalRdrEnv -> [GlobalRdrElt] -globalRdrEnvElts env = foldOccEnv (++) [] env - -instance Outputable GlobalRdrElt where - ppr gre = hang (ppr (greMangledName gre) <+> ppr (gre_par gre)) - 2 (pprNameProvenance gre) - -pprGlobalRdrEnv :: Bool -> GlobalRdrEnv -> SDoc -pprGlobalRdrEnv locals_only env - = vcat [ text "GlobalRdrEnv" <+> ppWhen locals_only (text "(locals only)") - <+> lbrace - , nest 2 (vcat [ pp (remove_locals gre_list) | gre_list <- nonDetOccEnvElts env ] - <+> rbrace) ] - where - remove_locals gres | locals_only = filter isLocalGRE gres - | otherwise = gres - pp [] = empty - pp gres@(gre:_) = hang (ppr occ - <+> parens (text "unique" <+> ppr (getUnique occ)) - <> colon) - 2 (vcat (map ppr gres)) - where - occ = nameOccName (greMangledName gre) - -lookupGlobalRdrEnv :: GlobalRdrEnv -> OccName -> [GlobalRdrElt] -lookupGlobalRdrEnv env occ_name = case lookupOccEnv env occ_name of - Nothing -> [] - Just gres -> gres - -lookupGRE_RdrName :: RdrName -> GlobalRdrEnv -> [GlobalRdrElt] --- ^ Look for this 'RdrName' in the global environment. Omits record fields --- without selector functions (see Note [NoFieldSelectors] in GHC.Rename.Env). -lookupGRE_RdrName rdr_name env = - filter (not . isNoFieldSelectorGRE) (lookupGRE_RdrName' rdr_name env) - -lookupGRE_RdrName' :: RdrName -> GlobalRdrEnv -> [GlobalRdrElt] --- ^ Look for this 'RdrName' in the global environment. Includes record fields --- without selector functions (see Note [NoFieldSelectors] in GHC.Rename.Env). -lookupGRE_RdrName' rdr_name env - = case lookupOccEnv env (rdrNameOcc rdr_name) of - Nothing -> [] - Just gres -> pickGREs rdr_name gres - -lookupGRE_Name :: GlobalRdrEnv -> Name -> Maybe GlobalRdrElt --- ^ Look for precisely this 'Name' in the environment. This tests --- whether it is in scope, ignoring anything else that might be in --- scope with the same 'OccName'. -lookupGRE_Name env name - = lookupGRE_Name_OccName env name (nameOccName name) - -lookupGRE_GreName :: GlobalRdrEnv -> GreName -> Maybe GlobalRdrElt --- ^ Look for precisely this 'GreName' in the environment. This tests --- whether it is in scope, ignoring anything else that might be in --- scope with the same 'OccName'. -lookupGRE_GreName env gname - = lookupGRE_Name_OccName env (greNameMangledName gname) (occName gname) - -lookupGRE_FieldLabel :: GlobalRdrEnv -> FieldLabel -> Maybe GlobalRdrElt --- ^ Look for a particular record field selector in the environment, where the --- selector name and field label may be different: the GlobalRdrEnv is keyed on --- the label. See Note [GreNames] for why this happens. -lookupGRE_FieldLabel env fl - = lookupGRE_Name_OccName env (flSelector fl) (mkVarOccFS (field_label $ flLabel fl)) - -lookupGRE_Name_OccName :: GlobalRdrEnv -> Name -> OccName -> Maybe GlobalRdrElt --- ^ Look for precisely this 'Name' in the environment, but with an 'OccName' --- that might differ from that of the 'Name'. See 'lookupGRE_FieldLabel' and --- Note [GreNames]. -lookupGRE_Name_OccName env name occ - = case [ gre | gre <- lookupGlobalRdrEnv env occ - , greMangledName gre == name ] of - [] -> Nothing - [gre] -> Just gre - gres -> pprPanic "lookupGRE_Name_OccName" - (ppr name $$ ppr occ $$ ppr gres) - -- See INVARIANT 1 on GlobalRdrEnv - - -getGRE_NameQualifier_maybes :: GlobalRdrEnv -> Name -> [Maybe [ModuleName]] --- Returns all the qualifiers by which 'x' is in scope --- Nothing means "the unqualified version is in scope" --- [] means the thing is not in scope at all -getGRE_NameQualifier_maybes env name - = case lookupGRE_Name env name of - Just gre -> [qualifier_maybe gre] - Nothing -> [] - where - qualifier_maybe (GRE { gre_lcl = lcl, gre_imp = iss }) - | lcl = Nothing - | otherwise = Just $ map (is_as . is_decl) (bagToList iss) - -isLocalGRE :: GlobalRdrElt -> Bool -isLocalGRE (GRE {gre_lcl = lcl }) = lcl - -isRecFldGRE :: GlobalRdrElt -> Bool -isRecFldGRE = isJust . greFieldLabel - -isDuplicateRecFldGRE :: GlobalRdrElt -> Bool --- ^ Is this a record field defined with DuplicateRecordFields? --- (See Note [GreNames]) -isDuplicateRecFldGRE = - maybe False ((DuplicateRecordFields ==) . flHasDuplicateRecordFields) . greFieldLabel - -isNoFieldSelectorGRE :: GlobalRdrElt -> Bool --- ^ Is this a record field defined with NoFieldSelectors? --- (See Note [NoFieldSelectors] in GHC.Rename.Env) -isNoFieldSelectorGRE = - maybe False ((NoFieldSelectors ==) . flHasFieldSelector) . greFieldLabel - -isFieldSelectorGRE :: GlobalRdrElt -> Bool --- ^ Is this a record field defined with FieldSelectors? --- (See Note [NoFieldSelectors] in GHC.Rename.Env) -isFieldSelectorGRE = - maybe False ((FieldSelectors ==) . flHasFieldSelector) . greFieldLabel - -greFieldLabel :: GlobalRdrElt -> Maybe FieldLabel --- ^ Returns the field label of this GRE, if it has one -greFieldLabel = greNameFieldLabel . gre_name - -unQualOK :: GlobalRdrElt -> Bool --- ^ Test if an unqualified version of this thing would be in scope -unQualOK (GRE {gre_lcl = lcl, gre_imp = iss }) - | lcl = True - | otherwise = any unQualSpecOK iss - -{- Note [GRE filtering] -~~~~~~~~~~~~~~~~~~~~~~~ -(pickGREs rdr gres) takes a list of GREs which have the same OccName -as 'rdr', say "x". It does two things: - -(a) filters the GREs to a subset that are in scope - * Qualified, as 'M.x' if want_qual is Qual M _ - * Unqualified, as 'x' if want_unqual is Unqual _ - -(b) for that subset, filter the provenance field (gre_lcl and gre_imp) - to ones that brought it into scope qualified or unqualified resp. - -Example: - module A ( f ) where - import qualified Foo( f ) - import Baz( f ) - f = undefined - -Let's suppose that Foo.f and Baz.f are the same entity really, but the local -'f' is different, so there will be two GREs matching "f": - gre1: gre_lcl = True, gre_imp = [] - gre2: gre_lcl = False, gre_imp = [ imported from Foo, imported from Bar ] - -The use of "f" in the export list is ambiguous because it's in scope -from the local def and the import Baz(f); but *not* the import qualified Foo. -pickGREs returns two GRE - gre1: gre_lcl = True, gre_imp = [] - gre2: gre_lcl = False, gre_imp = [ imported from Bar ] - -Now the "ambiguous occurrence" message can correctly report how the -ambiguity arises. --} - -pickGREs :: RdrName -> [GlobalRdrElt] -> [GlobalRdrElt] --- ^ Takes a list of GREs which have the right OccName 'x' --- Pick those GREs that are in scope --- * Qualified, as 'M.x' if want_qual is Qual M _ --- * Unqualified, as 'x' if want_unqual is Unqual _ --- --- Return each such GRE, with its ImportSpecs filtered, to reflect --- how it is in scope qualified or unqualified respectively. --- See Note [GRE filtering] -pickGREs (Unqual {}) gres = mapMaybe pickUnqualGRE gres -pickGREs (Qual mod _) gres = mapMaybe (pickQualGRE mod) gres -pickGREs _ _ = [] -- I don't think this actually happens - -pickUnqualGRE :: GlobalRdrElt -> Maybe GlobalRdrElt -pickUnqualGRE gre@(GRE { gre_lcl = lcl, gre_imp = iss }) - | not lcl, null iss' = Nothing - | otherwise = Just (gre { gre_imp = iss' }) - where - iss' = filterBag unQualSpecOK iss - -pickQualGRE :: ModuleName -> GlobalRdrElt -> Maybe GlobalRdrElt -pickQualGRE mod gre@(GRE { gre_lcl = lcl, gre_imp = iss }) - | not lcl', null iss' = Nothing - | otherwise = Just (gre { gre_lcl = lcl', gre_imp = iss' }) - where - iss' = filterBag (qualSpecOK mod) iss - lcl' = lcl && name_is_from mod - - name_is_from :: ModuleName -> Bool - name_is_from mod = case greDefinitionModule gre of - Just n_mod -> moduleName n_mod == mod - Nothing -> False - -pickGREsModExp :: ModuleName -> [GlobalRdrElt] -> [(GlobalRdrElt,GlobalRdrElt)] --- ^ Pick GREs that are in scope *both* qualified *and* unqualified --- Return each GRE that is, as a pair --- (qual_gre, unqual_gre) --- These two GREs are the original GRE with imports filtered to express how --- it is in scope qualified an unqualified respectively --- --- 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 - --- | 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 --- cluttered envt is no use. Really, it's only useful for --- GHC.Base and GHC.Tuple. -pickBothGRE :: ModuleName -> GlobalRdrElt -> Maybe (GlobalRdrElt, GlobalRdrElt) -pickBothGRE mod gre - | isBuiltInSyntax (greMangledName gre) = Nothing - | Just gre1 <- pickQualGRE mod gre - , Just gre2 <- pickUnqualGRE gre = Just (gre1, gre2) - | otherwise = Nothing - --- Building GlobalRdrEnvs - -plusGlobalRdrEnv :: GlobalRdrEnv -> GlobalRdrEnv -> GlobalRdrEnv -plusGlobalRdrEnv env1 env2 = plusOccEnv_C (foldr insertGRE) env1 env2 - -mkGlobalRdrEnv :: [GlobalRdrElt] -> GlobalRdrEnv -mkGlobalRdrEnv gres - = foldr add emptyGlobalRdrEnv gres - where - add gre env = extendOccEnv_Acc insertGRE Utils.singleton env - (greOccName gre) - gre - -insertGRE :: GlobalRdrElt -> [GlobalRdrElt] -> [GlobalRdrElt] -insertGRE new_g [] = [new_g] -insertGRE new_g (old_g : old_gs) - | gre_name new_g == gre_name old_g - = new_g `plusGRE` old_g : old_gs - | otherwise - = old_g : insertGRE new_g old_gs - -plusGRE :: GlobalRdrElt -> GlobalRdrElt -> GlobalRdrElt --- Used when the gre_name fields match -plusGRE g1 g2 - = GRE { gre_name = gre_name g1 - , gre_lcl = gre_lcl g1 || gre_lcl g2 - , gre_imp = gre_imp g1 `unionBags` gre_imp g2 - , gre_par = gre_par g1 `plusParent` gre_par g2 } - -transformGREs :: (GlobalRdrElt -> GlobalRdrElt) - -> [OccName] - -> GlobalRdrEnv -> GlobalRdrEnv --- ^ Apply a transformation function to the GREs for these OccNames -transformGREs trans_gre occs rdr_env - = foldr trans rdr_env occs - where - trans occ env - = case lookupOccEnv env occ of - Just gres -> extendOccEnv env occ (map trans_gre gres) - Nothing -> env - -extendGlobalRdrEnv :: GlobalRdrEnv -> GlobalRdrElt -> GlobalRdrEnv -extendGlobalRdrEnv env gre - = extendOccEnv_Acc insertGRE Utils.singleton env - (greOccName gre) gre - -{- Note [GlobalRdrEnv shadowing] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Before adding new names to the GlobalRdrEnv we nuke some existing entries; -this is "shadowing". The actual work is done by RdrEnv.shadowNames. -Suppose - env' = shadowNames env f `extendGlobalRdrEnv` M.f - -Then: - * Looking up (Unqual f) in env' should succeed, returning M.f, - even if env contains existing unqualified bindings for f. - They are shadowed - - * Looking up (Qual M.f) in env' should succeed, returning M.f - - * Looking up (Qual X.f) in env', where X /= M, should be the same as - looking up (Qual X.f) in env. - - That is, shadowNames does /not/ delete earlier qualified bindings - -There are two reasons for shadowing: - -* The GHCi REPL - - - Ids bought into scope on the command line (eg let x = True) have - External Names, like Ghci4.x. We want a new binding for 'x' (say) - to override the existing binding for 'x'. Example: - - ghci> :load M -- Brings `x` and `M.x` into scope - ghci> x - ghci> "Hello" - ghci> M.x - ghci> "hello" - ghci> let x = True -- Shadows `x` - ghci> x -- The locally bound `x` - -- NOT an ambiguous reference - ghci> True - ghci> M.x -- M.x is still in scope! - ghci> "Hello" - - So when we add `x = True` we must not delete the `M.x` from the - `GlobalRdrEnv`; rather we just want to make it "qualified only"; - hence the `set_qual` in `shadowNames`. See also Note - [Interactively-bound Ids in GHCi] in GHC.Runtime.Context - - - Data types also have External Names, like Ghci4.T; but we still want - 'T' to mean the newly-declared 'T', not an old one. - -* Nested Template Haskell declaration brackets - See Note [Top-level Names in Template Haskell decl quotes] in GHC.Rename.Names - - Consider a TH decl quote: - module M where - f x = h [d| f = ...f...M.f... |] - We must shadow the outer unqualified binding of 'f', else we'll get - a complaint when extending the GlobalRdrEnv, saying that there are - two bindings for 'f'. There are several tricky points: - - - This shadowing applies even if the binding for 'f' is in a - where-clause, and hence is in the *local* RdrEnv not the *global* - RdrEnv. This is done in lcl_env_TH in extendGlobalRdrEnvRn. - - - The External Name M.f from the enclosing module must certainly - still be available. So we don't nuke it entirely; we just make - it seem like qualified import. - - - We only shadow *External* names (which come from the main module), - or from earlier GHCi commands. Do not shadow *Internal* names - because in the bracket - [d| class C a where f :: a - f = 4 |] - rnSrcDecls will first call extendGlobalRdrEnvRn with C[f] from the - class decl, and *separately* extend the envt with the value binding. - At that stage, the class op 'f' will have an Internal name. --} - -shadowNames :: GlobalRdrEnv -> OccEnv a -> GlobalRdrEnv --- Remove certain old GREs that share the same OccName as this new Name. --- See Note [GlobalRdrEnv shadowing] for details -shadowNames = minusOccEnv_C (\gres _ -> Just (mapMaybe shadow gres)) - where - shadow :: GlobalRdrElt -> Maybe GlobalRdrElt - shadow - old_gre@(GRE { gre_lcl = lcl, gre_imp = iss }) - = case greDefinitionModule old_gre of - Nothing -> Just old_gre -- Old name is Internal; do not shadow - Just old_mod - | null iss' -- Nothing remains - -> Nothing - - | otherwise - -> Just (old_gre { gre_lcl = False, gre_imp = iss' }) - - where - iss' = lcl_imp `unionBags` mapMaybeBag set_qual iss - lcl_imp | lcl = listToBag [mk_fake_imp_spec old_gre old_mod] - | otherwise = emptyBag - - mk_fake_imp_spec old_gre old_mod -- Urgh! - = ImpSpec id_spec ImpAll - where - old_mod_name = moduleName old_mod - id_spec = ImpDeclSpec { is_mod = old_mod_name - , is_as = old_mod_name - , is_qual = True - , is_dloc = greDefinitionSrcSpan old_gre } - - set_qual :: ImportSpec -> Maybe ImportSpec - set_qual is = Just (is { is_decl = (is_decl is) { is_qual = True } }) - - -{- -************************************************************************ -* * - ImportSpec -* * -************************************************************************ --} - --- | Import Specification --- --- The 'ImportSpec' of something says how it came to be imported --- It's quite elaborate so that we can give accurate unused-name warnings. -data ImportSpec = ImpSpec { is_decl :: !ImpDeclSpec, - is_item :: !ImpItemSpec } - deriving( Eq, Data ) - -instance NFData ImportSpec where - rnf = rwhnf -- All fields are strict, so we don't need to do anything - --- | Import Declaration Specification --- --- Describes a particular import declaration and is --- shared among all the 'Provenance's for that decl -data ImpDeclSpec - = ImpDeclSpec { - is_mod :: !ModuleName, -- ^ Module imported, e.g. @import Muggle@ - -- Note the @Muggle@ may well not be - -- the defining module for this thing! - - -- 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_qual :: !Bool, -- ^ Was this import qualified? - is_dloc :: !SrcSpan -- ^ The location of the entire import declaration - } deriving (Eq, Data) - --- | Import Item Specification --- --- Describes import info a particular Name -data ImpItemSpec - = ImpAll -- ^ The import had no import list, - -- or had a hiding list - - | ImpSome { - is_explicit :: !Bool, - is_iloc :: !SrcSpan -- Location of the import item - } -- ^ The import had an import list. - -- The 'is_explicit' field is @True@ iff the thing was named - -- /explicitly/ in the import specs rather - -- than being imported as part of a "..." group. Consider: - -- - -- > import C( T(..) ) - -- - -- Here the constructors of @T@ are not named explicitly; - -- only @T@ is named explicitly. - deriving (Eq, Data) - -bestImport :: [ImportSpec] -> ImportSpec --- See Note [Choosing the best import declaration] -bestImport iss - = case sortBy best iss of - (is:_) -> is - [] -> pprPanic "bestImport" (ppr iss) - where - best :: ImportSpec -> ImportSpec -> Ordering - -- Less means better - -- Unqualified always wins over qualified; then - -- import-all wins over import-some; then - -- earlier declaration wins over later - best (ImpSpec { is_item = item1, is_decl = d1 }) - (ImpSpec { is_item = item2, is_decl = d2 }) - = (is_qual d1 `compare` is_qual d2) S.<> best_item item1 item2 S.<> - SrcLoc.leftmost_smallest (is_dloc d1) (is_dloc d2) - - best_item :: ImpItemSpec -> ImpItemSpec -> Ordering - best_item ImpAll ImpAll = EQ - best_item ImpAll (ImpSome {}) = LT - best_item (ImpSome {}) ImpAll = GT - best_item (ImpSome { is_explicit = e1 }) - (ImpSome { is_explicit = e2 }) = e1 `compare` e2 - -- False < True, so if e1 is explicit and e2 is not, we get GT - -{- Note [Choosing the best import declaration] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When reporting unused import declarations we use the following rules. - (see [wiki:commentary/compiler/unused-imports]) - -Say that an import-item is either - * an entire import-all decl (eg import Foo), or - * a particular item in an import list (eg import Foo( ..., x, ...)). -The general idea is that for each /occurrence/ of an imported name, we will -attribute that use to one import-item. Once we have processed all the -occurrences, any import items with no uses attributed to them are unused, -and are warned about. More precisely: - -1. For every RdrName in the program text, find its GlobalRdrElt. - -2. Then, from the [ImportSpec] (gre_imp) of that GRE, choose one - the "chosen import-item", and mark it "used". This is done - by 'bestImport' - -3. After processing all the RdrNames, bleat about any - import-items that are unused. - This is done in GHC.Rename.Names.warnUnusedImportDecls. - -The function 'bestImport' returns the dominant import among the -ImportSpecs it is given, implementing Step 2. We say import-item A -dominates import-item B if we choose A over B. In general, we try to -choose the import that is most likely to render other imports -unnecessary. Here is the dominance relationship we choose: - - a) import Foo dominates import qualified Foo. - - b) import Foo dominates import Foo(x). - - c) Otherwise choose the textually first one. - -Rationale for (a). Consider - import qualified M -- Import #1 - import M( x ) -- Import #2 - foo = M.x + x - -The unqualified 'x' can only come from import #2. The qualified 'M.x' -could come from either, but bestImport picks import #2, because it is -more likely to be useful in other imports, as indeed it is in this -case (see #5211 for a concrete example). - -But the rules are not perfect; consider - import qualified M -- Import #1 - import M( x ) -- Import #2 - foo = M.x + M.y - -The M.x will use import #2, but M.y can only use import #1. --} - - -unQualSpecOK :: ImportSpec -> Bool --- ^ Is in scope unqualified? -unQualSpecOK is = not (is_qual (is_decl is)) - -qualSpecOK :: ModuleName -> ImportSpec -> Bool --- ^ Is in scope qualified with the given module? -qualSpecOK mod is = mod == is_as (is_decl is) - -importSpecLoc :: ImportSpec -> SrcSpan -importSpecLoc (ImpSpec decl ImpAll) = is_dloc decl -importSpecLoc (ImpSpec _ item) = is_iloc item - -importSpecModule :: ImportSpec -> ModuleName -importSpecModule is = is_mod (is_decl is) - -isExplicitItem :: ImpItemSpec -> Bool -isExplicitItem ImpAll = False -isExplicitItem (ImpSome {is_explicit = exp}) = exp - -pprNameProvenance :: GlobalRdrElt -> SDoc --- ^ Print out one place where the name was define/imported --- (With -dppr-debug, print them all) -pprNameProvenance gre@(GRE { gre_lcl = lcl, gre_imp = iss }) - = ifPprDebug (vcat pp_provs) - (head pp_provs) - where - name = greMangledName gre - pp_provs = pp_lcl ++ map pp_is (bagToList iss) - pp_lcl = if lcl then [text "defined at" <+> ppr (nameSrcLoc name)] - else [] - pp_is is = sep [ppr is, ppr_defn_site is name] - --- If we know the exact definition point (which we may do with GHCi) --- then show that too. But not if it's just "imported from X". -ppr_defn_site :: ImportSpec -> Name -> SDoc -ppr_defn_site imp_spec name - | same_module && not (isGoodSrcSpan loc) - = empty -- Nothing interesting to say - | otherwise - = parens $ hang (text "and originally defined" <+> pp_mod) - 2 (pprLoc loc) - where - loc = nameSrcSpan name - defining_mod = assertPpr (isExternalName name) (ppr name) $ nameModule name - same_module = importSpecModule imp_spec == moduleName defining_mod - pp_mod | same_module = empty - | otherwise = text "in" <+> quotes (ppr defining_mod) - - -instance Outputable ImportSpec where - ppr imp_spec - = text "imported" <+> qual - <+> text "from" <+> quotes (ppr (importSpecModule imp_spec)) - <+> pprLoc (importSpecLoc imp_spec) - where - qual | is_qual (is_decl imp_spec) = text "qualified" - | otherwise = empty - -pprLoc :: SrcSpan -> SDoc -pprLoc (RealSrcSpan s _) = text "at" <+> ppr s -pprLoc (UnhelpfulSpan {}) = empty - --- | Indicate if the given name is the "@" operator -opIsAt :: RdrName -> Bool -opIsAt e = e == mkUnqual varName (fsLit "@") +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE PatternSynonyms #-} + +-- | +-- #name_types# +-- GHC uses several kinds of name internally: +-- +-- * 'GHC.Types.Name.Occurrence.OccName': see "GHC.Types.Name.Occurrence#name_types" +-- +-- * 'GHC.Types.Name.Reader.RdrName' is the type of names that come directly from the parser. They +-- have not yet had their scoping and binding resolved by the renamer and can be +-- thought of to a first approximation as an 'GHC.Types.Name.Occurrence.OccName' with an optional module +-- qualifier +-- +-- * 'GHC.Types.Name.Name': see "GHC.Types.Name#name_types" +-- +-- * 'GHC.Types.Id.Id': see "GHC.Types.Id#name_types" +-- +-- * 'GHC.Types.Var.Var': see "GHC.Types.Var#name_types" + +module GHC.Types.Name.Reader ( + -- * The main type + RdrName(..), -- Constructors exported only to GHC.Iface.Binary + + -- ** Construction + mkRdrUnqual, mkRdrQual, + mkUnqual, mkVarUnqual, mkQual, mkOrig, + nameRdrName, getRdrName, + + -- ** Destruction + 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, + elemLocalRdrEnv, inLocalRdrEnvScope, + localRdrEnvElts, minusLocalRdrEnv, minusLocalRdrEnvList, + + -- * Global mapping of 'RdrName' to 'GlobalRdrElt's + GlobalRdrEnvX, GlobalRdrEnv, IfGlobalRdrEnv, + emptyGlobalRdrEnv, mkGlobalRdrEnv, plusGlobalRdrEnv, + extendGlobalRdrEnv, greOccName, + pprGlobalRdrEnv, globalRdrEnvElts, globalRdrEnvLocal, + + -- ** Looking up 'GlobalRdrElt's + FieldsOrSelectors(..), filterFieldGREs, allowGRE, + + LookupGRE(..), lookupGRE, + WhichGREs(.., AllRelevantGREs, RelevantGREsFOS), + greIsRelevant, + + lookupGRE_Name, + lookupGRE_FieldLabel, + getGRE_NameQualifier_maybes, + transformGREs, pickGREs, pickGREsModExp, pickLevelZeroGRE, + + -- * GlobalRdrElts + availFromGRE, + greRdrNames, greSrcSpan, greQualModName, + gresToAvailInfo, + greDefinitionModule, greDefinitionSrcSpan, + greFieldLabel_maybe, + + -- ** Global 'RdrName' mapping elements: 'GlobalRdrElt', 'Provenance', 'ImportSpec' + GlobalRdrEltX(..), GlobalRdrElt, IfGlobalRdrElt, FieldGlobalRdrElt, + greName, greNameSpace, greParent, greInfo, + plusGRE, insertGRE, + forceGlobalRdrEnv, hydrateGlobalRdrEnv, + isLocalGRE, isImportedGRE, isRecFldGRE, + fieldGREInfo, + isDuplicateRecFldGRE, isNoFieldSelectorGRE, isFieldSelectorGRE, + unQualOK, qualSpecOK, unQualSpecOK, + pprNameProvenance, + mkGRE, mkExactGRE, mkLocalGRE, mkLocalVanillaGRE, mkLocalTyConGRE, + mkLocalConLikeGRE, mkLocalFieldGREs, + gresToNameSet, greLevels, + + -- ** Shadowing + greClashesWith, shadowNames, + + -- ** Information attached to a 'GlobalRdrElt' + ConLikeName(..), + GREInfo(..), RecFieldInfo(..), + plusGREInfo, + recFieldConLike_maybe, recFieldInfo_maybe, + fieldGRE_maybe, fieldGRELabel, + + -- ** Parent information + Parent(..), ParentGRE(..), greParent_maybe, + mkParent, availParent, + ImportSpec(..), ImpDeclSpec(..), ImpItemSpec(..), + importSpecLoc, importSpecModule, importSpecLevel, isExplicitItem, bestImport, + ImportLevel(..), + + -- * Utils + opIsAt, + + ) where + +import GHC.Prelude + +import GHC.Data.Bag +import GHC.Data.FastString +import GHC.Data.Maybe + +import GHC.Types.Avail +import GHC.Types.Basic +import GHC.Types.GREInfo +import GHC.Types.FieldLabel +import GHC.Types.Name +import GHC.Types.Name.Env +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 Data.Data +import Data.List ( sort ) +import qualified Data.List.NonEmpty as NE +import qualified Data.Map.Strict as Map +import qualified Data.Semigroup as S +import System.IO.Unsafe ( unsafePerformIO ) + +{- +************************************************************************ +* * +\subsection{The main data type} +* * +************************************************************************ +-} + +-- | Reader Name +-- +-- Do not use the data constructors of RdrName directly: prefer the family +-- of functions that creates them, such as 'mkRdrUnqual' +-- +-- - Note: A Located RdrName will only have API Annotations if it is a +-- compound one, +-- e.g. +-- +-- > `bar` +-- > ( ~ ) +-- +data RdrName + = Unqual OccName + -- ^ Unqualified name + -- + -- Used for ordinary, unqualified occurrences, e.g. @x@, @y@ or @Foo@. + -- Create such a 'RdrName' with 'mkRdrUnqual' + + | Qual ModuleName OccName + -- ^ Qualified name + -- + -- A qualified name written by the user in + -- /source/ code. The module isn't necessarily + -- the module where the thing is defined; + -- just the one from which it is imported. + -- Examples are @Bar.x@, @Bar.y@ or @Bar.Foo@. + -- Create such a 'RdrName' with 'mkRdrQual' + + | Orig Module OccName + -- ^ Original name + -- + -- An original name; the module is the /defining/ module. + -- This is used when GHC generates code that will be fed + -- into the renamer (e.g. from deriving clauses), but where + -- we want to say \"Use Prelude.map dammit\". One of these + -- can be created with 'mkOrig' + + | Exact Name + -- ^ Exact name + -- + -- We know exactly the 'Name'. This is used: + -- + -- (1) When the parser parses built-in syntax like @[]@ + -- and @(,)@, but wants a 'RdrName' from it + -- + -- (2) By Template Haskell, when TH has generated a unique name + -- + -- Such a 'RdrName' can be created by using 'getRdrName' on a 'Name' + deriving Data + +{- +************************************************************************ +* * +\subsection{Simple functions} +* * +************************************************************************ +-} + +instance HasOccName RdrName where + occName = rdrNameOcc + +rdrNameOcc :: RdrName -> OccName +rdrNameOcc (Qual _ occ) = occ +rdrNameOcc (Unqual occ) = occ +rdrNameOcc (Orig _ occ) = occ +rdrNameOcc (Exact name) = nameOccName name + +rdrNameSpace :: RdrName -> NameSpace +rdrNameSpace = occNameSpace . rdrNameOcc + +-- | '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) +demoteRdrName (Qual m occ) = fmap (Qual m) (demoteOccName occ) +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) +demoteRdrNameTv (Orig _ _) = Nothing +demoteRdrNameTv (Exact _) = Nothing + +-- promoteRdrName promotes the NameSpace of RdrName. +-- See Note [Promotion] in GHC.Rename.Env. +promoteRdrName :: RdrName -> Maybe RdrName +promoteRdrName (Unqual occ) = fmap Unqual (promoteOccName occ) +promoteRdrName (Qual m occ) = fmap (Qual m) (promoteOccName occ) +promoteRdrName (Orig _ _) = Nothing +promoteRdrName (Exact _) = Nothing + + -- These two are the basic constructors +mkRdrUnqual :: OccName -> RdrName +mkRdrUnqual occ = Unqual occ + +mkRdrQual :: ModuleName -> OccName -> RdrName +mkRdrQual mod occ = Qual mod occ + +mkOrig :: Module -> OccName -> RdrName +mkOrig mod occ = Orig mod occ + +--------------- + -- These two are used when parsing source files + -- They do encode the module and occurrence names +mkUnqual :: NameSpace -> FastString -> RdrName +mkUnqual sp n = Unqual (mkOccNameFS sp n) + +mkVarUnqual :: FastString -> RdrName +mkVarUnqual n = Unqual (mkVarOccFS n) + +-- | Make a qualified 'RdrName' in the given namespace and where the 'ModuleName' and +-- the 'OccName' are taken from the first and second elements of the tuple respectively +mkQual :: NameSpace -> (FastString, FastString) -> RdrName +mkQual sp (m, n) = Qual (mkModuleNameFS m) (mkOccNameFS sp n) + +getRdrName :: NamedThing thing => thing -> RdrName +getRdrName name = nameRdrName (getName name) + +nameRdrName :: Name -> RdrName +nameRdrName name = Exact name +-- Keep the Name even for Internal names, so that the +-- unique is still there for debug printing, particularly +-- of Types (which are converted to IfaceTypes before printing) + +nukeExact :: Name -> RdrName +nukeExact n + | isExternalName n = Orig (nameModule n) (nameOccName n) + | otherwise = Unqual (nameOccName n) + +isRdrDataCon :: RdrName -> Bool +isRdrTyVar :: RdrName -> Bool +isRdrTc :: RdrName -> Bool + +isRdrDataCon rn = isDataOcc (rdrNameOcc rn) +isRdrTyVar rn = isTvOcc (rdrNameOcc rn) +isRdrTc rn = isTcOcc (rdrNameOcc rn) + +isSrcRdrName :: RdrName -> Bool +isSrcRdrName (Unqual _) = True +isSrcRdrName (Qual _ _) = True +isSrcRdrName _ = False + +isUnqual :: RdrName -> Bool +isUnqual (Unqual _) = True +isUnqual _ = False + +isQual :: RdrName -> Bool +isQual (Qual _ _) = True +isQual _ = False + +isQual_maybe :: RdrName -> Maybe (ModuleName, OccName) +isQual_maybe (Qual m n) = Just (m,n) +isQual_maybe _ = Nothing + +isOrig :: RdrName -> Bool +isOrig (Orig _ _) = True +isOrig _ = False + +isOrig_maybe :: RdrName -> Maybe (Module, OccName) +isOrig_maybe (Orig m n) = Just (m,n) +isOrig_maybe _ = Nothing + +isExact :: RdrName -> Bool +isExact (Exact _) = True +isExact _ = False + +isExact_maybe :: RdrName -> Maybe Name +isExact_maybe (Exact n) = Just n +isExact_maybe _ = Nothing + +{- +************************************************************************ +* * +\subsection{Instances} +* * +************************************************************************ +-} + +instance Outputable RdrName where + 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 Nothing occ <> ppr occ) + +instance OutputableBndr RdrName where + pprBndr _ n + | isTvOcc (rdrNameOcc n) = char '@' <> ppr n + | otherwise = ppr n + + pprInfixOcc rdr = pprInfixVar (isSymOcc (rdrNameOcc rdr)) (ppr rdr) + pprPrefixOcc rdr + | Just name <- isExact_maybe rdr = pprPrefixName name + -- pprPrefixName has some special cases, so + -- we delegate to them rather than reproduce them + | otherwise = pprPrefixVar (isSymOcc (rdrNameOcc rdr)) (ppr rdr) + +instance Eq RdrName where + (Exact n1) == (Exact n2) = n1==n2 + -- Convert exact to orig + (Exact n1) == r2@(Orig _ _) = nukeExact n1 == r2 + r1@(Orig _ _) == (Exact n2) = r1 == nukeExact n2 + + (Orig m1 o1) == (Orig m2 o2) = m1==m2 && o1==o2 + (Qual m1 o1) == (Qual m2 o2) = m1==m2 && o1==o2 + (Unqual o1) == (Unqual o2) = o1==o2 + _ == _ = False + +instance Ord RdrName where + a <= b = case (a `compare` b) of { LT -> True; EQ -> True; GT -> False } + a < b = case (a `compare` b) of { LT -> True; EQ -> False; GT -> False } + a >= b = case (a `compare` b) of { LT -> False; EQ -> True; GT -> True } + a > b = case (a `compare` b) of { LT -> False; EQ -> False; GT -> True } + + -- Exact < Unqual < Qual < Orig + -- [Note: Apr 2004] We used to use nukeExact to convert Exact to Orig + -- before comparing so that Prelude.map == the exact Prelude.map, but + -- that meant that we reported duplicates when renaming bindings + -- generated by Template Haskell; e.g + -- do { n1 <- newName "foo"; n2 <- newName "foo"; + -- } + -- I think we can do without this conversion + compare (Exact n1) (Exact n2) = n1 `compare` n2 + compare (Exact _) _ = LT + + compare (Unqual _) (Exact _) = GT + compare (Unqual o1) (Unqual o2) = o1 `compare` o2 + compare (Unqual _) _ = LT + + compare (Qual _ _) (Exact _) = GT + compare (Qual _ _) (Unqual _) = GT + compare (Qual m1 o1) (Qual m2 o2) = compare o1 o2 S.<> compare m1 m2 + compare (Qual _ _) (Orig _ _) = LT + + compare (Orig m1 o1) (Orig m2 o2) = compare o1 o2 S.<> compare m1 m2 + compare (Orig _ _) _ = GT + +{- +************************************************************************ +* * + LocalRdrEnv +* * +************************************************************************ +-} + +{- Note [LocalRdrEnv] +~~~~~~~~~~~~~~~~~~~~~ +The LocalRdrEnv is used to store local bindings (let, where, lambda, case). + +* It is keyed by OccName, because we never use it for qualified names. + +* It maps the OccName to a Name. That Name is almost always an + Internal Name, but (hackily) it can be External too for top-level + pattern bindings. See Note [bindLocalNames for an External name] + in GHC.Rename.Pat + +* We keep the current mapping (lre_env), *and* the set of all Names in + scope (lre_in_scope). Reason: see Note [Splicing Exact names] in + GHC.Rename.Env. +-} + +-- | Local Reader Environment +-- See Note [LocalRdrEnv] +data LocalRdrEnv = LRE { lre_env :: OccEnv Name + , lre_in_scope :: NameSet } + +instance Outputable LocalRdrEnv where + ppr (LRE {lre_env = env, lre_in_scope = ns}) + = hang (text "LocalRdrEnv {") + 2 (vcat [ text "env =" <+> pprOccEnv ppr_elt env + , text "in_scope =" + <+> pprUFM (getUniqSet ns) (braces . pprWithCommas ppr) + ] <+> char '}') + where + ppr_elt name = parens (ppr (nameOccName name)) <+> ppr name + -- So we can see if the keys line up correctly + +emptyLocalRdrEnv :: LocalRdrEnv +emptyLocalRdrEnv = LRE { lre_env = emptyOccEnv + , lre_in_scope = emptyNameSet } + +extendLocalRdrEnv :: LocalRdrEnv -> Name -> LocalRdrEnv +-- See Note [LocalRdrEnv] +extendLocalRdrEnv lre@(LRE { lre_env = env, lre_in_scope = ns }) name + = lre { lre_env = extendOccEnv env (nameOccName name) name + , lre_in_scope = extendNameSet ns name } + +extendLocalRdrEnvList :: LocalRdrEnv -> [Name] -> LocalRdrEnv +-- See Note [LocalRdrEnv] +extendLocalRdrEnvList lre@(LRE { lre_env = env, lre_in_scope = ns }) names + = lre { lre_env = extendOccEnvList env [(nameOccName n, n) | n <- names] + , lre_in_scope = extendNameSetList ns names } + +lookupLocalRdrEnv :: LocalRdrEnv -> RdrName -> Maybe Name +lookupLocalRdrEnv (LRE { lre_env = env, lre_in_scope = ns }) rdr + | Unqual occ <- rdr + = lookupOccEnv env occ + + -- See Note [Local bindings with Exact Names] + | Exact name <- rdr + , name `elemNameSet` ns + = 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 +lookupLocalRdrOcc (LRE { lre_env = env }) occ = lookupOccEnv env occ + +elemLocalRdrEnv :: RdrName -> LocalRdrEnv -> Bool +elemLocalRdrEnv rdr_name (LRE { lre_env = env, lre_in_scope = ns }) + = case rdr_name of + Unqual occ -> occ `elemOccEnv` env + Exact name -> name `elemNameSet` ns -- See Note [Local bindings with Exact Names] + Qual {} -> False + Orig {} -> False + +localRdrEnvElts :: LocalRdrEnv -> [Name] +localRdrEnvElts (LRE { lre_env = env }) = nonDetOccEnvElts env + +inLocalRdrEnvScope :: Name -> LocalRdrEnv -> Bool +-- This is the point of the NameSet +inLocalRdrEnvScope name (LRE { lre_in_scope = ns }) = name `elemNameSet` ns + +minusLocalRdrEnv :: LocalRdrEnv -> OccEnv a -> LocalRdrEnv +minusLocalRdrEnv lre@(LRE { lre_env = env }) occs + = lre { lre_env = minusOccEnv env occs } + +minusLocalRdrEnvList :: LocalRdrEnv -> [OccName] -> LocalRdrEnv +minusLocalRdrEnvList lre@(LRE { lre_env = env }) occs + = lre { lre_env = delListFromOccEnv env occs } + +{- +Note [Local bindings with Exact Names] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +With Template Haskell we can make local bindings that have Exact Names. +Computing shadowing etc may use elemLocalRdrEnv (at least it certainly +does so in GHC.Rename.HsType.bindHsQTyVars), so for an Exact Name we must consult +the in-scope-name-set. + + +************************************************************************ +* * + GlobalRdrEnv +* * +************************************************************************ +-} + +-- | Global Reader Environment +type GlobalRdrEnv = GlobalRdrEnvX GREInfo +-- ^ Keyed by 'OccName'; when looking up a qualified name +-- we look up the 'OccName' part, and then check the 'Provenance' +-- to see if the appropriate qualification is valid. This +-- saves routinely doubling the size of the env by adding both +-- qualified and unqualified names to the domain. +-- +-- The list in the codomain is required because there may be name clashes +-- These only get reported on lookup, not on construction +-- +-- INVARIANT 1: All the members of the list have distinct +-- 'gre_name' fields; that is, no duplicate Names +-- +-- INVARIANT 2: Imported provenance => Name is an ExternalName +-- However LocalDefs can have an InternalName. This +-- happens only when type-checking a [d| ... |] Template +-- Haskell quotation; see this note in GHC.Rename.Names +-- Note [Top-level Names in Template Haskell decl quotes] +-- +-- INVARIANT 3: If the GlobalRdrEnv maps [occ -> gre], then +-- greOccName gre = occ + +-- | A 'GlobalRdrEnv' in which the 'GlobalRdrElt's don't have any 'GREInfo' +-- attached to them. This is useful to avoid space leaks, see Note [IfGlobalRdrEnv]. +type IfGlobalRdrEnv = GlobalRdrEnvX () + +-- | Parametrises 'GlobalRdrEnv' over the presence or absence of 'GREInfo'. +-- +-- See Note [IfGlobalRdrEnv]. +type GlobalRdrEnvX info = OccEnv [GlobalRdrEltX info] + +-- | Global Reader Element +-- +-- Something in scope in the renamer; usually a member of the 'GlobalRdrEnv'. +-- See Note [GlobalRdrElt provenance]. + +type GlobalRdrElt = GlobalRdrEltX GREInfo + +-- | A 'GlobalRdrElt' in which we stripped out the 'GREInfo' field, +-- in order to avoid space leaks. +-- +-- See Note [IfGlobalRdrEnv]. +type IfGlobalRdrElt = GlobalRdrEltX () + +-- | Global Reader Element +-- +-- Something in scope in the renamer; usually a member of the 'GlobalRdrEnv'. +-- See Note [GlobalRdrElt provenance]. +-- +-- Why do we parametrise over the 'gre_info' field? See Note [IfGlobalRdrEnv]. +data GlobalRdrEltX info + = GRE { gre_name :: !Name + , gre_par :: !Parent -- ^ See Note [Parents] + , gre_lcl :: !Bool -- ^ True <=> the thing was defined locally + , gre_imp :: !(Bag ImportSpec) -- ^ In scope through these imports + -- See Note [GlobalRdrElt provenance] for the relation between gre_lcl and gre_imp. + + , gre_info :: info + -- ^ Information the renamer knows about this particular 'Name'. + -- + -- Careful about forcing this field! Forcing it can trigger + -- the loading of interface files. + -- + -- Note [Retrieving the GREInfo from interfaces] in GHC.Types.GREInfo. + } deriving (Data) + +instance NFData a => NFData (GlobalRdrEltX a) where + rnf (GRE name par _ imp info) = rnf name `seq` rnf par `seq` rnf imp `seq` rnf info + + +{- Note [IfGlobalRdrEnv] +~~~~~~~~~~~~~~~~~~~~~~~~ +Information pertinent to the renamer about a 'Name' is stored in the fields of +'GlobalRdrElt'. The 'gre_info' field, described in Note [GREInfo] in GHC.Types.GREInfo, +is a bit special: as Note [Retrieving the GREInfo from interfaces] in GHC.Types.GREInfo +describes, for imported 'Name's it is usually obtained by a look up in a type environment, +and forcing can cause the interface file for the module defining the 'Name' to be +loaded. As described in Note [Forcing GREInfo] in GHC.Types.GREInfo, keeping it +a thunk can cause space leaks, while forcing it can cause extra work to be done. +So it's best to discard it when we don't need it, for example when we are about +to store it in a 'ModIface'. + +We thus parametrise 'GlobalRdrElt' (and 'GlobalRdrEnv') over the presence or +absence of the 'GREInfo' field. + + - When we are about to stash the 'GlobalRdrElt' in a long-lived data structure, + e.g. a 'ModIface', we force it by setting all the 'GREInfo' fields to '()'. + See 'forceGlobalRdrEnv'. + - To go back the other way, we use 'hydrateGlobalRdrEnv', which sets the + 'gre_info' fields back to lazy lookups. + +This parametrisation also helps ensure that we don't accidentally force the +GREInfo field (which can cause unnecessary loading of interface files). +In particular, the 'lookupGRE' function is statically guaranteed to not consult +the 'GREInfo' field when using 'SameNameSpace', which is important +as we sometimes need to use this function with an 'IfaceGlobalRdrEnv' in which +the 'GREInfo' fields have been stripped. +-} + +-- | A 'FieldGlobalRdrElt' is a 'GlobalRdrElt' +-- in which the 'gre_info' field is 'IAmRecField'. +type FieldGlobalRdrElt = GlobalRdrElt + +greName :: GlobalRdrEltX info -> Name +greName = gre_name + +greNameSpace :: GlobalRdrEltX info -> NameSpace +greNameSpace = nameNameSpace . greName + +greParent :: GlobalRdrEltX info -> Parent +greParent = gre_par + +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 } + deriving (Eq, Data) + +instance Outputable Parent where + ppr NoParent = empty + ppr (ParentIs n) = text "parent:" <> ppr n + +instance NFData Parent where + rnf NoParent = () + rnf (ParentIs n) = rnf n + +plusParent :: Parent -> Parent -> Parent +-- See Note [Combining parents] +plusParent p1@(ParentIs _) p2 = hasParent p1 p2 +plusParent p1 p2@(ParentIs _) = hasParent p2 p1 +plusParent NoParent NoParent = NoParent + +hasParent :: Parent -> Parent -> Parent +#if defined(DEBUG) +hasParent p NoParent = p +hasParent p p' + | p /= p' = pprPanic "hasParent" (ppr p <+> ppr p') -- Parents should agree +#endif +hasParent p _ = p + + +{- Note [GlobalRdrElt provenance] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The gre_lcl and gre_imp fields of a GlobalRdrElt describe its "provenance", +i.e. how the Name came to be in scope. It can be in scope in one of the following +three ways: + + A. The Name was locally bound, in the current module. + gre_lcl = True + + The renamer adds this Name to the GlobalRdrEnv after renaming the binding. + See the calls to "extendGlobalRdrEnvRn" in GHC.Rename.Module.rnSrcDecls. + + B. The Name was imported + gre_imp = Just imps <=> brought into scope by the imports "imps" + + The renamer adds this Name to the GlobalRdrEnv after processing the imports. + See GHC.Rename.Names.filterImports and GHC.Tc.Module.tcRnImports. + + C. We followed an exact reference (i.e. an Exact or Orig RdrName) + gre_lcl = False, gre_imp = Nothing + + In this case, we directly fetch a Name and its GREInfo from direct reference. + We don't add it to the GlobalRdrEnv. See "GHC.Rename.Env.lookupExactOrOrig". + +It is just about possible to have *both* gre_lcl = True and gre_imp = Just imps. +This can happen with module loops: a Name is defined locally in A, and also +brought into scope by importing a module that SOURCE-imported A. + +Example (#7672): + + A.hs-boot module A where + data T + + B.hs module B(Decl.T) where + import {-# SOURCE #-} qualified A as Decl + + A.hs module A where + import qualified B + data T = Z | S B.T + +In A.hs, 'T' is locally bound, *and* imported as B.T. + + +Note [Parents] +~~~~~~~~~~~~~~~~~ +The children of a Name are the things that are abbreviated by the ".." notation +in export lists. + +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + Parent Children +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + data T Data constructors + Record-field ids + + data family T Data constructors and record-field ids + of all visible data instances of T + + class C Class operations + Associated type constructors + +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + Constructor Meaning +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + NoParent Not bundled with a type constructor. + ParentIs n Bundled with the type constructor corresponding to n. + +Pattern synonym constructors (and their record fields, if any) are unusual: +their gre_par is NoParent in the module in which they are defined. However, a +pattern synonym can be bundled with a type constructor on export, in which case +whenever the pattern synonym is imported the gre_par will be ParentIs. + +Thus the gre_name and gre_par fields are independent, because a normal datatype +introduces FieldGlobalRdrElts using ParentIs, but a record pattern synonym can +introduce FieldGlobalRdrElts that use NoParent. (In the past we represented +fields using an additional constructor of the Parent type, which could not +adequately represent this situation.) See also +Note [Representing pattern synonym fields in AvailInfo] in GHC.Types.Avail. + +Note [Combining parents] +~~~~~~~~~~~~~~~~~~~~~~~~ +With an associated type we might have + module M where + class C a where + data T a + op :: T a -> a + instance C Int where + data T Int = TInt + instance C Bool where + data T Bool = TBool + +Then: C is the parent of T + T is the parent of TInt and TBool +So: in an export list + C(..) is short for C( op, T ) + T(..) is short for T( TInt, TBool ) + +Module M exports everything, so its exports will be + AvailTC C [C,T,op] + AvailTC T [T,TInt,TBool] +On import we convert to GlobalRdrElt and then combine +those. For T that will mean we have + one GRE with Parent C + one GRE with NoParent +That's why plusParent picks the "best" case. +-} + +mkGRE :: (Name -> Maybe ImportSpec) -> GREInfo -> Parent -> Name -> GlobalRdrElt +mkGRE prov_fn info par n = + case prov_fn n of + -- Nothing => bound locally + -- Just is => imported from 'is' + Nothing -> GRE { gre_name = n, gre_par = par + , gre_lcl = True, gre_imp = emptyBag + , gre_info = info } + Just is -> GRE { gre_name = n, gre_par = par + , gre_lcl = False, gre_imp = unitBag is + , gre_info = info } + +mkExactGRE :: Name -> GREInfo -> GlobalRdrElt +mkExactGRE nm info = + GRE { gre_name = nm, gre_par = NoParent + , gre_lcl = False, gre_imp = emptyBag + , gre_info = info } + +mkLocalGRE :: GREInfo -> Parent -> Name -> GlobalRdrElt +mkLocalGRE = mkGRE (const Nothing) + +mkLocalVanillaGRE :: Parent -> Name -> GlobalRdrElt +mkLocalVanillaGRE = mkLocalGRE Vanilla + +-- | Create a local 'GlobalRdrElt' for a 'TyCon'. +mkLocalTyConGRE :: TyConFlavour Name + -> Name + -> GlobalRdrElt +mkLocalTyConGRE flav nm = mkLocalGRE (IAmTyCon flav) par nm + where + par = case tyConFlavourAssoc_maybe flav of + Nothing -> NoParent + Just p -> ParentIs p + +mkLocalConLikeGRE :: Parent -> (ConLikeName, ConInfo) -> GlobalRdrElt +mkLocalConLikeGRE p (con_nm, con_info) = + mkLocalGRE (IAmConLike con_info) p (conLikeName_Name con_nm ) + +mkLocalFieldGREs :: Parent -> [(ConLikeName, ConInfo)] -> [GlobalRdrElt] +mkLocalFieldGREs p cons = + [ mkLocalGRE (IAmRecField fld_info) p fld_nm + | (S.Arg fld_nm fl, fl_cons) <- flds + , let fld_info = RecFieldInfo { recFieldLabel = fl + , 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 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 + , ConInfo _ (ConHasRecordFields fls) <- [con_info] + , fl <- NE.toList fls ] + +instance HasOccName (GlobalRdrEltX info) where + occName = greOccName + +greOccName :: GlobalRdrEltX info -> OccName +greOccName ( GRE { gre_name = nm } ) = nameOccName nm + +-- | The SrcSpan of the name pointed to by the GRE. +greDefinitionSrcSpan :: GlobalRdrEltX info -> SrcSpan +greDefinitionSrcSpan = nameSrcSpan . greName + +-- | The module in which the name pointed to by the GRE is defined. +greDefinitionModule :: GlobalRdrEltX info -> Maybe Module +greDefinitionModule = nameModule_maybe . greName + +greQualModName :: Outputable info => GlobalRdrEltX info -> ModuleName +-- Get a suitable module qualifier for the GRE +-- (used in mkPrintUnqualified) +-- Precondition: the gre_name is always External +greQualModName gre@(GRE { gre_lcl = lcl, gre_imp = iss }) + | lcl, Just mod <- greDefinitionModule gre = moduleName mod + | Just is <- headMaybe iss = is_as (is_decl is) + | otherwise = pprPanic "greQualModName" (ppr gre) + +greRdrNames :: GlobalRdrEltX info -> [RdrName] +greRdrNames gre@GRE{ gre_lcl = lcl, gre_imp = iss } + = bagToList $ (if lcl then unitBag unqual else emptyBag) `unionBags` concatMapBag do_spec (mapBag is_decl iss) + where + occ = greOccName gre + unqual = Unqual occ + do_spec decl_spec + | is_qual decl_spec = unitBag qual + | otherwise = listToBag [unqual,qual] + where qual = Qual (is_as decl_spec) occ + +-- the SrcSpan that pprNameProvenance prints out depends on whether +-- the Name is defined locally or not: for a local definition the +-- definition site is used, otherwise the location of the import +-- declaration. We want to sort the export locations in +-- exportClashErr by this SrcSpan, we need to extract it: +greSrcSpan :: Outputable info => GlobalRdrEltX info -> SrcSpan +greSrcSpan gre@(GRE { gre_lcl = lcl, gre_imp = iss } ) + | lcl = greDefinitionSrcSpan gre + | Just is <- headMaybe iss = is_dloc (is_decl is) + | otherwise = pprPanic "greSrcSpan" (ppr gre) + +mkParent :: Name -> AvailInfo -> Parent +mkParent _ (Avail _) = NoParent +mkParent n (AvailTC m _) | n == m = NoParent + | otherwise = ParentIs m + +availParent :: AvailInfo -> Parent +availParent (AvailTC m _) = ParentIs m +availParent (Avail {}) = NoParent + + +greParent_maybe :: GlobalRdrEltX info -> Maybe Name +greParent_maybe gre = case gre_par gre of + NoParent -> Nothing + ParentIs n -> Just n + +gresToNameSet :: [GlobalRdrEltX info] -> NameSet +gresToNameSet gres = foldr add emptyNameSet gres + where add gre set = extendNameSet set (greName gre) + +-- | Takes a list of distinct GREs and folds them +-- into AvailInfos. This is more efficient than mapping each individual +-- GRE to an AvailInfo and then folding using `plusAvail`, but needs the +-- uniqueness assumption. +gresToAvailInfo :: forall info. [GlobalRdrEltX info] -> [AvailInfo] +gresToAvailInfo gres + = nonDetNameEnvElts avail_env + where + avail_env :: NameEnv AvailInfo -- Keyed by the parent + (avail_env, _) = foldl' add (emptyNameEnv, emptyNameSet) gres + + add :: (NameEnv AvailInfo, NameSet) + -> GlobalRdrEltX info + -> (NameEnv AvailInfo, NameSet) + add (env, done) gre + | name `elemNameSet` done + = (env, done) -- Don't insert twice into the AvailInfo + | otherwise + = ( extendNameEnv_Acc comb availFromGRE env key gre + , done `extendNameSet` name ) + where + name = greName gre + key = case greParent_maybe gre of + Just parent -> parent + Nothing -> greName gre + + -- We want to insert the child `k` into a list of children but + -- need to maintain the invariant that the parent is first. + -- + -- We also use the invariant that `k` is not already in `ns`. + insertChildIntoChildren :: Name -> [Name] -> Name -> [Name] + insertChildIntoChildren _ [] k = [k] + insertChildIntoChildren p (n:ns) k + | p == k = k:n:ns + | otherwise = n:k:ns + + comb :: GlobalRdrEltX info -> AvailInfo -> AvailInfo + comb _ (Avail n) = Avail n -- Duplicated name, should not happen + comb gre (AvailTC m ns) + = case gre_par gre of + NoParent -> AvailTC m (greName gre:ns) -- Not sure this ever happens + ParentIs {} -> AvailTC m (insertChildIntoChildren m ns (greName gre)) + +availFromGRE :: GlobalRdrEltX info -> AvailInfo +availFromGRE (GRE { gre_name = child, gre_par = parent }) + = case parent of + ParentIs p + -> AvailTC p [child] + NoParent + | isTyConName child -- NB: don't force the GREInfo field unnecessarily. + -> AvailTC child [child] + | otherwise + -> Avail child + +emptyGlobalRdrEnv :: GlobalRdrEnvX info +emptyGlobalRdrEnv = emptyOccEnv + +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. +forceGlobalRdrEnv :: GlobalRdrEnvX info -> IfGlobalRdrEnv +forceGlobalRdrEnv rdrs = + strictMapOccEnv (strictMap (\ gre -> gre { gre_info = ()})) rdrs + +-- | Hydrate a previously dehydrated 'GlobalRdrEnv', +-- by (lazily!) looking up the 'GREInfo' using the provided function. +-- +-- See Note [Forcing GREInfo] in GHC.Types.GREInfo. +hydrateGlobalRdrEnv :: forall info noInfo + . (Name -> IO info) + -> GlobalRdrEnvX noInfo -> GlobalRdrEnvX info +hydrateGlobalRdrEnv f = mapOccEnv (fmap g) + where + g gre = gre { gre_info = unsafePerformIO $ f (greName gre) } + -- NB: use unsafePerformIO to delay the lookup until it is forced. + -- See also 'GHC.Rename.Env.lookupGREInfo'. + +instance Outputable info => Outputable (GlobalRdrEltX info) where + ppr gre = hang (ppr (greName gre) <+> ppr (gre_par gre) <+> ppr (gre_info gre)) + 2 (pprNameProvenance gre) + +pprGlobalRdrEnv :: Bool -> GlobalRdrEnv -> SDoc +pprGlobalRdrEnv locals_only env + = vcat [ text "GlobalRdrEnv" <+> ppWhen locals_only (text "(locals only)") + <+> lbrace + , nest 2 (vcat [ pp (remove_locals gre_list) | gre_list <- nonDetOccEnvElts env ] + <+> rbrace) ] + where + remove_locals gres | locals_only = filter isLocalGRE gres + | otherwise = gres + pp [] = empty + pp gres@(gre:_) = hang (ppr occ <> colon) + 2 (vcat (map ppr gres)) + where + occ = nameOccName (greName gre) + +{- +Note [NoFieldSelectors] +~~~~~~~~~~~~~~~~~~~~~~~ +The NoFieldSelectors extension allows record fields to be defined without +bringing the corresponding selector functions into scope. However, such fields +may still be used in contexts such as record construction, pattern matching or +update. This requires us to distinguish contexts in which selectors are required +from those in which any field may be used. For example: + + {-# LANGUAGE NoFieldSelectors #-} + module M (T(foo), foo) where -- T(foo) refers to the field, + -- unadorned foo to the value binding + data T = MkT { foo :: Int } + foo = () + + bar = foo -- refers to the value binding, field ignored + + module N where + import M (T(..)) + baz = MkT { foo = 3 } -- refers to the field + oops = foo -- an error: the field is in scope but the value binding is not + +Each 'FieldLabel' indicates (in the 'flHasFieldSelector' field) whether the +FieldSelectors extension was enabled in the defining module. This allows them +to be filtered out by 'filterFieldGREs'. + +Even when NoFieldSelectors is in use, we still generate selector functions +internally. For example, the expression + getField @"foo" t +or (with dot-notation) + t.foo +extracts the `foo` field of t::T, and hence needs the selector function +(see Note [HasField instances] in GHC.Tc.Instance.Class). + +In many of the name lookup functions in this module we pass a FieldsOrSelectors +value, indicating what we are looking for: + + * WantNormal: fields are in scope only if they have an accompanying selector + function, e.g. we are looking up a variable in an expression + (lookupExprOccRn). + + * WantBoth: any name or field will do, regardless of whether the selector + function is available, e.g. record updates (lookupRecUpdFields) with + NoDisambiguateRecordFields. + + * WantField: any field will do, regardless of whether the selector function is + available, but ignoring any non-field names, e.g. record updates + (lookupRecUpdFields with DisambiguateRecordFields. + +----------------------------------------------------------------------------------- + Context FieldsOrSelectors +----------------------------------------------------------------------------------- + Record construction/pattern match WantField, but unless DisambiguateRecordFields + e.g. MkT { foo = 3 } is in effect, also look up using WantBoth + Record update, e.g. e { foo = 3 } to report when a non-field clashes with a field. + + :info in GHCi WantBoth + + Variable occurrence in expression WantNormal + Type variable, data constructor + Pretty much everything else +----------------------------------------------------------------------------------- +-} + +fieldGRE_maybe :: GlobalRdrElt -> Maybe FieldGlobalRdrElt +fieldGRE_maybe gre = do + guard (isRecFldGRE gre) + return gre + +fieldGRELabel :: HasDebugCallStack => FieldGlobalRdrElt -> FieldLabel +fieldGRELabel = recFieldLabel . fieldGREInfo + +fieldGREInfo :: HasDebugCallStack => FieldGlobalRdrElt -> RecFieldInfo +fieldGREInfo gre + = assertPpr (isRecFldGRE gre) (ppr gre) $ + case greInfo gre of + IAmRecField info -> info + info -> pprPanic "fieldGREInfo" $ + vcat [ text "gre_name:" <+> ppr (greName gre) + , text "info:" <+> ppr info ] + +recFieldConLike_maybe :: HasDebugCallStack => GlobalRdrElt -> Maybe ConInfo +recFieldConLike_maybe gre = + case greInfo gre of + IAmConLike info -> Just info + _ -> Nothing + +recFieldInfo_maybe :: HasDebugCallStack => GlobalRdrElt -> Maybe RecFieldInfo +recFieldInfo_maybe gre = + case greInfo gre of + IAmRecField info -> assertPpr (isRecFldGRE gre) (ppr gre) $ Just info + _ -> Nothing + +-- | When looking up GREs, we may or may not want to include fields that were +-- defined in modules with @NoFieldSelectors@ enabled. See Note +-- [NoFieldSelectors]. +data FieldsOrSelectors + = WantNormal -- ^ Include normal names, and fields with selectors, but + -- ignore fields without selectors. + | WantBoth -- ^ Include normal names and all fields (regardless of whether + -- they have selectors). + | WantField -- ^ Include only fields, with or without selectors, ignoring + -- any non-fields in scope. + deriving (Eq, Show) + +filterFieldGREs :: FieldsOrSelectors -> [GlobalRdrElt] -> [GlobalRdrElt] +filterFieldGREs WantBoth = id +filterFieldGREs fos = filter (allowGRE fos) + +allowGRE :: FieldsOrSelectors -> GlobalRdrElt -> Bool +allowGRE WantBoth _ + = True +allowGRE WantNormal gre + -- NB: we only need to consult the GREInfo for record field GREs, + -- to check whether they define field selectors. + -- By checking 'isRecFldGRE' first, which only consults the NameSpace, + -- we avoid forcing the GREInfo for things that aren't record fields. + | isRecFldGRE gre + = flHasFieldSelector (fieldGRELabel gre) == FieldSelectors + | otherwise + = True +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? +-- +-- Depending on the answer, we might need more or less information from the +-- 'GlobalRdrEnv', e.g. if we want to include matching record fields we need +-- to know if the corresponding record fields define field selectors, for which +-- we need to consult the 'GREInfo'. This is why this datatype is a GADT. +-- +-- See Note [IfGlobalRdrEnv]. +data LookupGRE info where + -- | Look for this specific 'OccName', with the exact same 'NameSpace', + -- in the 'GlobalRdrEnv'. + LookupOccName :: OccName -- ^ the 'OccName' to look up + -> WhichGREs info + -- ^ information about other relevant 'NameSpace's + -> LookupGRE info + + -- | Look up the 'OccName' of this 'RdrName' in the 'GlobalRdrEnv', + -- filtering out those whose qualification matches that of the 'RdrName'. + -- + -- Lookup returns an empty result for 'Exact' or 'Orig' 'RdrName's. + LookupRdrName :: RdrName -- ^ the 'RdrName' to look up + -> WhichGREs info + -- ^ information about other relevant 'NameSpace's + -> LookupGRE info + + -- | Look for 'GRE's with the same unique as the given 'Name' + -- in the 'GlobalRdrEnv'. + LookupExactName + :: { lookupExactName :: Name + -- ^ the 'Name' to look up + , lookInAllNameSpaces :: Bool + -- ^ whether to look in *all* 'NameSpace's, or just + -- in the 'NameSpace' of the 'Name' + -- See Note [Template Haskell ambiguity] + } + -> LookupGRE info + + -- | Look up children 'GlobalRdrElt's with a given 'Parent'. + LookupChildren + :: 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? +data WhichGREs info where + -- | Only consider 'GlobalRdrElt's with the exact 'NameSpace' we look up. + SameNameSpace :: WhichGREs info + -- | Allow 'GlobalRdrElt's with different 'NameSpace's, e.g. allow looking up + -- record fields from the variable 'NameSpace', or looking up a 'TyCon' from + -- the data constructor 'NameSpace'. + RelevantGREs + :: { includeFieldSelectors :: !FieldsOrSelectors + -- ^ how should we handle looking up variables? + -- + -- - should we include record fields defined with @-XNoFieldSelectors@? + -- - should we include non-fields? + -- + -- See Note [NoFieldSelectors]. + , lookupVariablesForFields :: !Bool + -- ^ when looking up a record field, should we also look up plain variables? + , lookupTyConsAsWell :: !Bool + -- ^ when looking up a variable, field or data constructor, should we + -- also try the type constructor 'NameSpace'? + } + -> WhichGREs GREInfo + +instance Outputable (WhichGREs info) where + ppr SameNameSpace = text "SameNameSpace" + ppr (RelevantGREs { includeFieldSelectors = sel + , lookupVariablesForFields = vars + , lookupTyConsAsWell = tcs_too }) + = braces $ hsep + [ text "RelevantGREs" + , text (show sel) + , if vars then text "[vars]" else empty + , if tcs_too then text "[tcs]" else empty ] + +-- | Look up as many possibly relevant 'GlobalRdrElt's as possible. +pattern AllRelevantGREs :: WhichGREs GREInfo +pattern AllRelevantGREs = + RelevantGREs { includeFieldSelectors = WantBoth + , lookupVariablesForFields = True + , lookupTyConsAsWell = True } + +-- | Look up relevant GREs, taking into account the interaction between the +-- variable and field 'NameSpace's as determined by the 'FieldsOrSelector' +-- argument. +pattern RelevantGREsFOS :: FieldsOrSelectors -> WhichGREs GREInfo +pattern RelevantGREsFOS fos <- RelevantGREs { includeFieldSelectors = fos } + where + RelevantGREsFOS fos = + RelevantGREs { includeFieldSelectors = fos + , lookupVariablesForFields = fos == WantBoth + , lookupTyConsAsWell = False } + +-- | 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? +greIsRelevant :: WhichGREs GREInfo -- ^ specification of which 'GlobalRdrElt's to consider relevant + -> NameSpace -- ^ the 'NameSpace' of the thing we are looking up + -> GlobalRdrElt -- ^ the 'GlobalRdrElt' we have looked up, in a + -- potentially different 'NameSpace' than we wanted + -> Bool +greIsRelevant which_gres ns gre + | ns == other_ns + = True + | otherwise + = case which_gres of + SameNameSpace -> False + RelevantGREs { includeFieldSelectors = fos + , lookupVariablesForFields = vars_for_flds + , lookupTyConsAsWell = tycons_too } + | ns == varName + -> (isFieldNameSpace other_ns && allowGRE fos gre) || tc_too + | isFieldNameSpace ns + -> vars_for_flds && + ( other_ns == varName + || (isFieldNameSpace other_ns && allowGRE fos gre) + || tc_too ) + | isDataConNameSpace ns + -> tc_too + | otherwise + -> False + where + tc_too = tycons_too && isTcClsNameSpace other_ns + where + other_ns = greNameSpace gre + +{- Note [childGREPriority] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +There are currently two places in the compiler where we look up GlobalRdrElts +which have a given Parent. These are the two calls to lookupSubBndrOcc_helper: + + A. Looking up children in an export item, e.g. + + module M ( T(MkT, D) ) where { data T = MkT; data D = D } + + B. Looking up binders in a class or instance declaration, e.g. + the operator +++ in the fixity declaration: + + class C a where { type (+++) :: a -> a ->; infixl 6 +++ } + (+++) :: Int -> Int -> Int; (+++) = (+) + +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'? + +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. + +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'. +-- +-- 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 (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 :: 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 wanted_ns + , isTermVarOrFieldNameSpace child_ns + = Just 0 + | 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`" + -- inside a class declaration, we want to account for the possibility + -- that the identifier refers to an associated type (type constructor + -- NameSpace), when otherwise "+!" would be in the term-level variable + -- NameSpace, and "Fun" would be in the term-level data constructor + -- NameSpace. See tests T10816, T23664, T24037. + = 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 :: 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 +-- whether there should there be any lee-way if the 'NameSpace's don't +-- exactly match. +lookupGRE :: GlobalRdrEnvX info -> LookupGRE info -> [GlobalRdrEltX info] +lookupGRE env = \case + LookupOccName occ which_gres -> + case which_gres of + SameNameSpace -> + concat $ lookupOccEnv env occ + rel@(RelevantGREs{}) -> + filter (greIsRelevant rel (occNameSpace occ)) $ + concat $ lookupOccEnv_AllNameSpaces env occ + LookupRdrName rdr rel -> + pickGREs rdr $ lookupGRE env (LookupOccName (rdrNameOcc rdr) rel) + LookupExactName { lookupExactName = nm + , lookInAllNameSpaces = all_ns } -> + [ gre | gre <- lkup, greName gre == nm ] + where + occ = nameOccName nm + lkup | all_ns = concat $ lookupOccEnv_AllNameSpaces env occ + | otherwise = fromMaybe [] $ lookupOccEnv env occ + 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). +-- +-- This allows us to first look in e.g. the data 'NameSpace', and then fall back +-- to the type/class 'NameSpace'. +highestPriorityGREs :: forall gre prio + . Ord prio + => (gre -> Maybe prio) + -- ^ priority function + -- lower value <=> higher priority + -> [gre] -> [gre] +highestPriorityGREs priority gres = + take_highest_prio $ NE.group $ sort + [ S.Arg prio gre + | gre <- gres + , prio <- maybeToList $ priority gre ] + where + take_highest_prio :: [NE.NonEmpty (S.Arg prio gre)] -> [gre] + take_highest_prio [] = [] + take_highest_prio (fs:_) = map (\ (S.Arg _ gre) -> gre) $ NE.toList fs +{-# INLINEABLE highestPriorityGREs #-} + +-- | Look for precisely this 'Name' in the environment, +-- in the __same 'NameSpace'__ as the 'Name'. +-- +-- This tests whether it is in scope, ignoring anything +-- else that might be in scope which doesn't have the same 'Unique'. +lookupGRE_Name :: Outputable info => GlobalRdrEnvX info -> Name -> Maybe (GlobalRdrEltX info) +lookupGRE_Name env name = + case lookupGRE env (LookupExactName { lookupExactName = name + , lookInAllNameSpaces = False }) of + [] -> Nothing + [gre] -> Just gre + gres -> pprPanic "lookupGRE_Name" + (ppr name $$ ppr (nameOccName name) $$ ppr gres) + -- See INVARIANT 1 on GlobalRdrEnv + +-- | Look for a particular record field selector in the environment. +lookupGRE_FieldLabel :: GlobalRdrEnv -> FieldLabel -> Maybe FieldGlobalRdrElt +lookupGRE_FieldLabel env fl = + case lookupGRE_Name env (flSelector fl) of + Nothing -> Nothing + Just gre -> + assertPpr (isRecFldGRE gre) + (vcat [ text "lookupGre_FieldLabel:" <+> ppr fl ]) $ + Just gre + +getGRE_NameQualifier_maybes :: GlobalRdrEnv -> Name -> [Maybe [ModuleName]] +-- Returns all the qualifiers by which 'x' is in scope +-- Nothing means "the unqualified version is in scope" +-- [] means the thing is not in scope at all +getGRE_NameQualifier_maybes env name + = case lookupGRE_Name env name of + Just gre -> [qualifier_maybe gre] + Nothing -> [] + where + qualifier_maybe (GRE { gre_lcl = lcl, gre_imp = iss }) + | lcl = Nothing + | otherwise = Just $ map (is_as . is_decl) (bagToList iss) + +-- | Is this 'GlobalRdrElt' defined locally? +isLocalGRE :: GlobalRdrEltX info -> Bool +isLocalGRE (GRE { gre_lcl = lcl }) = lcl + +-- | Is this 'GlobalRdrElt' imported? +-- +-- Not just the negation of 'isLocalGRE', because it might be an Exact or +-- Orig name reference. See Note [GlobalRdrElt provenance]. +isImportedGRE :: GlobalRdrEltX info -> Bool +isImportedGRE (GRE { gre_imp = imps }) = not $ isEmptyBag imps + +-- | Is this a record field GRE? +-- +-- Important: does /not/ consult the 'GreInfo' field. +isRecFldGRE :: GlobalRdrEltX info -> Bool +isRecFldGRE (GRE { gre_name = nm }) = isFieldName nm + +isDuplicateRecFldGRE :: GlobalRdrElt -> Bool +-- ^ Is this a record field defined with DuplicateRecordFields? +isDuplicateRecFldGRE = + maybe False ((DuplicateRecordFields ==) . flHasDuplicateRecordFields) . greFieldLabel_maybe + +isNoFieldSelectorGRE :: GlobalRdrElt -> Bool +-- ^ Is this a record field defined with NoFieldSelectors? +-- (See Note [NoFieldSelectors] in GHC.Rename.Env) +isNoFieldSelectorGRE = + maybe False ((NoFieldSelectors ==) . flHasFieldSelector) . greFieldLabel_maybe + +isFieldSelectorGRE :: GlobalRdrElt -> Bool +-- ^ Is this a record field defined with FieldSelectors? +-- (See Note [NoFieldSelectors] in GHC.Rename.Env) +isFieldSelectorGRE = + maybe False ((FieldSelectors ==) . flHasFieldSelector) . greFieldLabel_maybe + +greFieldLabel_maybe :: GlobalRdrElt -> Maybe FieldLabel +-- ^ Returns the field label of this GRE, if it has one +greFieldLabel_maybe = fmap fieldGRELabel . fieldGRE_maybe + +unQualOK :: GlobalRdrEltX info -> Bool +-- ^ Test if an unqualified version of this thing would be in scope +unQualOK (GRE {gre_lcl = lcl, gre_imp = iss }) + | lcl = True + | otherwise = any unQualSpecOK iss + +{- Note [GRE filtering] +~~~~~~~~~~~~~~~~~~~~~~~ +(pickGREs rdr gres) takes a list of GREs which have the same OccName +as 'rdr', say "x". It does two things: + +(a) filters the GREs to a subset that are in scope + * Qualified, as 'M.x' if want_qual is Qual M _ + * Unqualified, as 'x' if want_unqual is Unqual _ + +(b) for that subset, filter the provenance field (gre_lcl and gre_imp) + to ones that brought it into scope qualified or unqualified resp. + +Example: + module A ( f ) where + import qualified Foo( f ) + import Baz( f ) + f = undefined + +Let's suppose that Foo.f and Baz.f are the same entity really, but the local +'f' is different, so there will be two GREs matching "f": + gre1: gre_lcl = True, gre_imp = [] + gre2: gre_lcl = False, gre_imp = [ imported from Foo, imported from Bar ] + +The use of "f" in the export list is ambiguous because it's in scope +from the local def and the import Baz(f); but *not* the import qualified Foo. +pickGREs returns two GRE + gre1: gre_lcl = True, gre_imp = [] + gre2: gre_lcl = False, gre_imp = [ imported from Bar ] + +Now the "ambiguous occurrence" message can correctly report how the +ambiguity arises. +-} + +pickGREs :: RdrName -> [GlobalRdrEltX info] -> [GlobalRdrEltX info] +-- ^ Takes a list of GREs which have the right OccName 'x' +-- Pick those GREs that are in scope +-- * Qualified, as 'M.x' if want_qual is Qual M _ +-- * Unqualified, as 'x' if want_unqual is Unqual _ +-- +-- Return each such GRE, with its ImportSpecs filtered, to reflect +-- how it is in scope qualified or unqualified respectively. +-- See Note [GRE filtering] +pickGREs (Unqual {}) gres = mapMaybe pickUnqualGRE gres +pickGREs (Qual mod _) gres = mapMaybe (pickQualGRE mod) gres +pickGREs _ _ = [] -- I don't think this actually happens + +pickUnqualGRE :: GlobalRdrEltX info -> Maybe (GlobalRdrEltX info) +pickUnqualGRE gre@(GRE { gre_lcl = lcl, gre_imp = iss }) + | not lcl, null iss' = Nothing + | otherwise = Just (gre { gre_imp = iss' }) + where + iss' = filterBag unQualSpecOK iss + +pickQualGRE :: ModuleName -> GlobalRdrEltX info -> Maybe (GlobalRdrEltX info) +pickQualGRE mod gre@(GRE { gre_lcl = lcl, gre_imp = iss }) + | not lcl', null iss' = Nothing + | otherwise = Just (gre { gre_lcl = lcl', gre_imp = iss' }) + where + iss' = filterBag (qualSpecOK mod) iss + lcl' = lcl && name_is_from mod + + name_is_from :: ModuleName -> Bool + name_is_from mod = case greDefinitionModule gre of + Just n_mod -> moduleName n_mod == mod + Nothing -> False + +pickGREsModExp :: ModuleName -> [GlobalRdrEltX info] -> [(GlobalRdrEltX info,GlobalRdrEltX info)] +-- ^ Pick GREs that are in scope *both* qualified *and* unqualified +-- Return each GRE that is, as a pair +-- (qual_gre, unqual_gre) +-- These two GREs are the original GRE with imports filtered to express how +-- it is in scope qualified an unqualified respectively +-- +-- Used only for the 'module M' item in export list; +-- see 'GHC.Tc.Gen.Export.exports_from_avail' +-- 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 +-- cluttered envt is no use. Really, it's only useful for +-- GHC.Base and GHC.Tuple. +pickBothGRE :: ModuleName -> GlobalRdrEltX info -> Maybe (GlobalRdrEltX info, GlobalRdrEltX info) +pickBothGRE mod gre + | isBuiltInSyntax (greName gre) + = Nothing + | Just gre1 <- pickQualGRE mod gre + , Just gre2 <- pickUnqualGRE gre + = Just (gre1, gre2) + | otherwise + = Nothing + +-- Building GlobalRdrEnvs + +plusGlobalRdrEnv :: GlobalRdrEnv -> GlobalRdrEnv -> GlobalRdrEnv +plusGlobalRdrEnv env1 env2 = plusOccEnv_C (foldr insertGRE) env1 env2 + +mkGlobalRdrEnv :: [GlobalRdrElt] -> GlobalRdrEnv +mkGlobalRdrEnv gres + = foldr add emptyGlobalRdrEnv gres + where + add gre env = extendOccEnv_Acc insertGRE Utils.singleton env + (greOccName gre) + gre + +insertGRE :: GlobalRdrElt -> [GlobalRdrElt] -> [GlobalRdrElt] +insertGRE new_g [] = [new_g] +insertGRE new_g (old_g : old_gs) + | greName new_g == greName old_g + = new_g `plusGRE` old_g : old_gs + | otherwise + = old_g : insertGRE new_g old_gs + +plusGRE :: GlobalRdrElt -> GlobalRdrElt -> GlobalRdrElt +-- Used when the gre_name fields match +plusGRE g1 g2 + = GRE { gre_name = gre_name g1 + , gre_lcl = gre_lcl g1 || gre_lcl g2 + , gre_imp = gre_imp g1 `unionBags` gre_imp g2 + , gre_par = gre_par g1 `plusParent` gre_par g2 + , gre_info = gre_info g1 `plusGREInfo` gre_info g2 } + +transformGREs :: (GlobalRdrElt -> GlobalRdrElt) + -> [OccName] + -> GlobalRdrEnv -> GlobalRdrEnv +-- ^ Apply a transformation function to the GREs for these OccNames +transformGREs trans_gre occs rdr_env + = foldr trans rdr_env occs + where + trans occ env + = case lookupOccEnv env occ of + Just gres -> extendOccEnv env occ (map trans_gre gres) + Nothing -> env + +extendGlobalRdrEnv :: GlobalRdrEnv -> GlobalRdrElt -> GlobalRdrEnv +extendGlobalRdrEnv env gre + = extendOccEnv_Acc insertGRE Utils.singleton env + (greOccName gre) gre + +{- Note [GlobalRdrEnv shadowing] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Before adding new names to the GlobalRdrEnv we nuke some existing entries; +this is "shadowing". The actual work is done by GHC.Types.Name.Reader.shadowNames. +Suppose + + env' = shadowNames env { f } `extendGlobalRdrEnv` { M.f } + +Then: + * Looking up (Unqual f) in env' should succeed, returning M.f, + even if env contains existing unqualified bindings for f. + They are shadowed + + * Looking up (Qual M.f) in env' should succeed, returning M.f + + * Looking up (Qual X.f) in env', where X /= M, should be the same as + looking up (Qual X.f) in env. + + That is, shadowNames does /not/ delete earlier qualified bindings + +There are two reasons for shadowing: + +* The GHCi REPL + + - Ids bought into scope on the command line (eg let x = True) have + External Names, like Ghci4.x. We want a new binding for 'x' (say) + to override the existing binding for 'x'. Example: + + ghci> :load M -- Brings `x` and `M.x` into scope + ghci> x + ghci> "Hello" + ghci> M.x + ghci> "hello" + ghci> let x = True -- Shadows `x` + ghci> x -- The locally bound `x` + -- NOT an ambiguous reference + ghci> True + ghci> M.x -- M.x is still in scope! + ghci> "Hello" + + So when we add `x = True` we must not delete the `M.x` from the + `GlobalRdrEnv`; rather we just want to make it "qualified only"; + hence the `set_qual` in `shadowNames`. See also Note + [Interactively-bound Ids in GHCi] in GHC.Runtime.Context + + - Data types also have External Names, like Ghci4.T; but we still want + 'T' to mean the newly-declared 'T', not an old one. + +* Nested Template Haskell declaration brackets + See Note [Top-level Names in Template Haskell decl quotes] in GHC.Rename.Names + + Consider a TH decl quote: + module M where + f x = h [d| f = ...f...M.f... |] + We must shadow the outer unqualified binding of 'f', else we'll get + a complaint when extending the GlobalRdrEnv, saying that there are + two bindings for 'f'. There are several tricky points: + + - This shadowing applies even if the binding for 'f' is in a + where-clause, and hence is in the *local* RdrEnv not the *global* + RdrEnv. This is done in lcl_env_TH in extendGlobalRdrEnvRn. + + - The External Name M.f from the enclosing module must certainly + still be available. So we don't nuke it entirely; we just make + it seem like qualified import. + + - We only shadow *External* names (which come from the main module), + or from earlier GHCi commands. Do not shadow *Internal* names + because in the bracket + [d| class C a where f :: a + f = 4 |] + rnSrcDecls will first call extendGlobalRdrEnvRn with C[f] from the + class decl, and *separately* extend the envt with the value binding. + At that stage, the class op 'f' will have an Internal name. + +Wrinkle [Shadowing namespaces] + + In the following GHCi session: + + > data A = MkA { foo :: Int } + > foo = False + > bar = foo + + We expect the variable 'foo' to shadow the record field 'foo', even though + they are in separate namespaces, so that the occurrence of 'foo' in the body + of 'bar' is not ambiguous. + +-} + +shadowNames :: Bool -- ^ discard names that are only available qualified? + -> GlobalRdrEnv -> GlobalRdrEnv -> GlobalRdrEnv +-- Remove certain old GREs that share the same OccName as this new Name. +-- See Note [GlobalRdrEnv shadowing] for details +shadowNames drop_only_qualified env new_gres = minusOccEnv_C_Ns do_shadowing env new_gres + where + + do_shadowing :: UniqFM NameSpace [GlobalRdrElt] + -> UniqFM NameSpace [GlobalRdrElt] + -> UniqFM NameSpace [GlobalRdrElt] + do_shadowing olds news = + -- Start off by accumulating all 'NameSpace's shadowed + -- by the entire collection of new GREs. + let shadowed_gres :: ShadowedGREs + shadowed_gres = + nonDetFoldUFM (\ gres shads -> foldMap greShadowedNameSpaces gres S.<> shads) + mempty news + + -- Then shadow the old 'GlobalRdrElt's, now that we know which 'NameSpace's + -- should be shadowed. + shadow_list :: Unique -> [GlobalRdrElt] -> Maybe [GlobalRdrElt] + shadow_list old_ns old_gres = + case namespace_is_shadowed old_ns shadowed_gres of + IsNotShadowed -> Just old_gres + IsShadowed -> guard_nonEmpty $ mapMaybe shadow old_gres + IsShadowedIfFieldSelector -> + guard_nonEmpty $ + mapMaybe (\ old_gre -> if isFieldSelectorGRE old_gre then shadow old_gre else Just old_gre) + old_gres + + -- Now do all of the shadowing in a single go. This avoids traversing + -- the old GlobalRdrEnv multiple times over. + in mapMaybeWithKeyUFM shadow_list olds + + guard_nonEmpty :: [a] -> Maybe [a] + guard_nonEmpty xs | null xs = Nothing + | otherwise = Just xs + + -- Shadow a single GRE, by either qualifying it or removing it entirely. + shadow :: GlobalRdrElt-> Maybe GlobalRdrElt + shadow old_gre@(GRE { gre_lcl = lcl, gre_imp = iss }) = + case greDefinitionModule old_gre of + Nothing -> Just old_gre -- Old name is Internal; do not shadow + Just old_mod + | null iss' -- Nothing remains + || drop_only_qualified + -> Nothing + + | otherwise + -> Just (old_gre { gre_lcl = False, gre_imp = iss' }) + + where + iss' = lcl_imp `unionBags` mapBag set_qual iss + lcl_imp | lcl = unitBag $ mk_fake_imp_spec old_gre old_mod + | otherwise = emptyBag + + mk_fake_imp_spec old_gre old_mod -- Urgh! + = ImpSpec id_spec ImpAll + where + 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 + set_qual is = is { is_decl = (is_decl is) { is_qual = True } } + +-- | @greClashesWith new_gre old_gre@ computes whether @new_gre@ clashes +-- with @old_gre@ (assuming they both have the same underlying 'occNameFS'). +greClashesWith :: GlobalRdrElt -> (GlobalRdrElt -> Bool) +greClashesWith new_gre old_gre = + old_gre `greIsShadowed` greShadowedNameSpaces new_gre + +-- | Is the given 'GlobalRdrElt' shadowed, as specified by the 'ShadowedNameSpace's? +greIsShadowed :: GlobalRdrElt -> ShadowedGREs -> Bool +greIsShadowed old_gre shadowed = + case getUnique old_ns `namespace_is_shadowed` shadowed of + IsShadowed -> True + IsNotShadowed -> False + IsShadowedIfFieldSelector -> isFieldSelectorGRE old_gre + where + old_ns = occNameSpace $ greOccName old_gre + + +-- | Whether a 'GlobalRdrElt' is definitely shadowed, definitely not shadowed, +-- or conditionally shadowed based on more information beyond the 'NameSpace'. +data IsShadowed + -- | The GRE is not shadowed. + = IsNotShadowed + -- | The GRE is shadowed. + | IsShadowed + -- | The GRE is shadowed iff it is a record field GRE + -- which defines a field selector (i.e. FieldSelectors is enabled in its + -- defining module). + | IsShadowedIfFieldSelector + +-- | Internal function: is a 'GlobalRdrElt' with the 'NameSpace' with given +-- 'Unique' shadowed by the specified 'ShadowedGREs'? +namespace_is_shadowed :: Unique -> ShadowedGREs -> IsShadowed +namespace_is_shadowed old_ns (ShadowedGREs shadowed_nonflds shadowed_flds) + | isFldNSUnique old_ns + = case shadowed_flds of + ShadowAllFieldGREs -> IsShadowed + ShadowFieldSelectorsAnd shadowed + | old_ns `elemUniqSet_Directly` shadowed + -> IsShadowed + | otherwise + -> IsShadowedIfFieldSelector + ShadowFieldNameSpaces shadowed + | old_ns `elemUniqSet_Directly` shadowed + -> IsShadowed + | otherwise + -> IsNotShadowed + | old_ns `elemUniqSet_Directly` shadowed_nonflds + = IsShadowed + | otherwise + = IsNotShadowed + +-- | What are all the 'GlobalRdrElt's that are shadowed by this new 'GlobalRdrElt'? +greShadowedNameSpaces :: GlobalRdrElt -> ShadowedGREs +greShadowedNameSpaces gre = ShadowedGREs shadowed_nonflds shadowed_flds + where + ns = occNameSpace $ greOccName gre + !shadowed_nonflds + | isFieldNameSpace ns + -- A new record field shadows variables if it defines a field selector. + = if isFieldSelectorGRE gre + then unitUniqSet varName + else emptyUniqSet + | otherwise + = unitUniqSet ns + !shadowed_flds + | ns == varName + -- A new variable shadows record fields with field selectors. + = ShadowFieldSelectorsAnd emptyUniqSet + | isFieldNameSpace ns + -- A new record field shadows record fields unless it is a duplicate record field. + = if isDuplicateRecFldGRE gre + then ShadowFieldNameSpaces (unitUniqSet ns) + -- NB: we must still shadow fields with the same constructor name. + else ShadowAllFieldGREs + | otherwise + = ShadowFieldNameSpaces emptyUniqSet + +-- | A description of which 'GlobalRdrElt's are shadowed. +data ShadowedGREs + = ShadowedGREs + { shadowedNonFieldNameSpaces :: !(UniqSet NameSpace) + -- ^ These specific non-field 'NameSpace's are shadowed. + , shadowedFieldGREs :: !ShadowedFieldGREs + -- ^ These field 'GlobalRdrElt's are shadowed. + } + +-- | A description of which record field 'GlobalRdrElt's are shadowed. +data ShadowedFieldGREs + -- | All field 'GlobalRdrElt's are shadowed. + = ShadowAllFieldGREs + -- | Record field GREs defining field selectors, as well as those + -- with the explicitly specified field 'NameSpace's, are shadowed. + | ShadowFieldSelectorsAnd { shadowedFieldNameSpaces :: !(UniqSet NameSpace) } + -- | These specific field 'NameSpace's are shadowed. + | ShadowFieldNameSpaces { shadowedFieldNameSpaces :: !(UniqSet NameSpace) } + +instance Monoid ShadowedFieldGREs where + mempty = ShadowFieldNameSpaces { shadowedFieldNameSpaces = emptyUniqSet } + +instance Semigroup ShadowedFieldGREs where + ShadowAllFieldGREs <> _ = ShadowAllFieldGREs + _ <> ShadowAllFieldGREs = ShadowAllFieldGREs + ShadowFieldSelectorsAnd ns1 <> ShadowFieldSelectorsAnd ns2 = + ShadowFieldSelectorsAnd (ns1 S.<> ns2) + ShadowFieldSelectorsAnd ns1 <> ShadowFieldNameSpaces ns2 = + ShadowFieldSelectorsAnd (ns1 S.<> ns2) + ShadowFieldNameSpaces ns1 <> ShadowFieldSelectorsAnd ns2 = + ShadowFieldSelectorsAnd (ns1 S.<> ns2) + ShadowFieldNameSpaces ns1 <> ShadowFieldNameSpaces ns2 = + ShadowFieldNameSpaces (ns1 S.<> ns2) + +instance Monoid ShadowedGREs where + mempty = + ShadowedGREs + { shadowedNonFieldNameSpaces = emptyUniqSet + , shadowedFieldGREs = mempty } + +instance Semigroup ShadowedGREs where + ShadowedGREs nonflds1 flds1 <> ShadowedGREs nonflds2 flds2 = + ShadowedGREs (nonflds1 S.<> nonflds2) (flds1 S.<> flds2) + +{- +************************************************************************ +* * + ImportSpec +* * +************************************************************************ +-} + +-- | Import Specification +-- +-- The 'ImportSpec' of something says how it came to be imported +-- It's quite elaborate so that we can give accurate unused-name warnings. +data ImportSpec = ImpSpec { is_decl :: !ImpDeclSpec, + is_item :: !ImpItemSpec } + deriving( Eq, Data ) + +instance NFData ImportSpec where + rnf = rwhnf -- All fields are strict, so we don't need to do anything + +-- | Import Declaration Specification +-- +-- Describes a particular import declaration and is +-- shared among all the 'Provenance's for that decl +data ImpDeclSpec + = ImpDeclSpec { + is_mod :: !Module, -- ^ Module imported, e.g. @import Muggle@ + -- Note the @Muggle@ may well not be + -- the defining module for this thing! + + -- 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_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 +data ImpItemSpec + = ImpAll -- ^ The import had no import list, + -- or had a hiding list + + | ImpSome { + is_explicit :: !Bool, + is_iloc :: !SrcSpan -- Location of the import item + } -- ^ The import had an import list. + -- The 'is_explicit' field is @True@ iff the thing was named + -- /explicitly/ in the import specs rather + -- than being imported as part of a "..." group. Consider: + -- + -- > import C( T(..) ) + -- + -- Here the constructors of @T@ are not named explicitly; + -- only @T@ is named explicitly. + deriving (Eq, Data) + +bestImport :: NE.NonEmpty ImportSpec -> ImportSpec +-- See Note [Choosing the best import declaration] +bestImport iss = NE.head $ NE.sortBy best iss + where + best :: ImportSpec -> ImportSpec -> Ordering + -- Less means better + -- Unqualified always wins over qualified; then + -- import-all wins over import-some; then + -- earlier declaration wins over later + best (ImpSpec { is_item = item1, is_decl = d1 }) + (ImpSpec { is_item = item2, is_decl = d2 }) + = (is_qual d1 `compare` is_qual d2) S.<> best_item item1 item2 S.<> + SrcLoc.leftmost_smallest (is_dloc d1) (is_dloc d2) + + best_item :: ImpItemSpec -> ImpItemSpec -> Ordering + best_item ImpAll ImpAll = EQ + best_item ImpAll (ImpSome {}) = LT + best_item (ImpSome {}) ImpAll = GT + best_item (ImpSome { is_explicit = e1 }) + (ImpSome { is_explicit = e2 }) = e1 `compare` e2 + -- False < True, so if e1 is explicit and e2 is not, we get GT + +{- Note [Choosing the best import declaration] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When reporting unused import declarations we use the following rules. + (see [wiki:commentary/compiler/unused-imports]) + +Say that an import-item is either + * an entire import-all decl (eg import Foo), or + * a particular item in an import list (eg import Foo( ..., x, ...)). +The general idea is that for each /occurrence/ of an imported name, we will +attribute that use to one import-item. Once we have processed all the +occurrences, any import items with no uses attributed to them are unused, +and are warned about. More precisely: + +1. For every RdrName in the program text, find its GlobalRdrElt. + +2. Then, from the [ImportSpec] (gre_imp) of that GRE, choose one + the "chosen import-item", and mark it "used". This is done + by 'bestImport' + +3. After processing all the RdrNames, bleat about any + import-items that are unused. + This is done in GHC.Rename.Names.warnUnusedImportDecls. + +The function 'bestImport' returns the dominant import among the +ImportSpecs it is given, implementing Step 2. We say import-item A +dominates import-item B if we choose A over B. In general, we try to +choose the import that is most likely to render other imports +unnecessary. Here is the dominance relationship we choose: + + a) import Foo dominates import qualified Foo. + + b) import Foo dominates import Foo(x). + + c) Otherwise choose the textually first one. + +Rationale for (a). Consider + import qualified M -- Import #1 + import M( x ) -- Import #2 + foo = M.x + x + +The unqualified 'x' can only come from import #2. The qualified 'M.x' +could come from either, but bestImport picks import #2, because it is +more likely to be useful in other imports, as indeed it is in this +case (see #5211 for a concrete example). + +But the rules are not perfect; consider + import qualified M -- Import #1 + import M( x ) -- Import #2 + foo = M.x + M.y + +The M.x will use import #2, but M.y can only use import #1. +-} + + +unQualSpecOK :: ImportSpec -> Bool +-- ^ Is in scope unqualified? +unQualSpecOK is = not (is_qual (is_decl is)) + +qualSpecOK :: ModuleName -> ImportSpec -> Bool +-- ^ Is in scope qualified with the given module? +qualSpecOK mod is = mod == is_as (is_decl is) + +importSpecLoc :: ImportSpec -> SrcSpan +importSpecLoc (ImpSpec decl ImpAll) = is_dloc decl +importSpecLoc (ImpSpec _ item) = is_iloc item + +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 + +pprNameProvenance :: GlobalRdrEltX info -> SDoc +-- ^ Print out one place where the name was define/imported +-- (With -dppr-debug, print them all) +pprNameProvenance (GRE { gre_name = name, gre_lcl = lcl, gre_imp = iss }) + = ifPprDebug (vcat pp_provs) + (head pp_provs) + where + pp_provs = pp_lcl ++ map pp_is (bagToList iss) + pp_lcl = if lcl then [text "defined at" <+> ppr (nameSrcLoc name)] + else [] + pp_is is = sep [ppr is, ppr_defn_site is name] + +-- If we know the exact definition point (which we may do with GHCi) +-- then show that too. But not if it's just "imported from X". +ppr_defn_site :: ImportSpec -> Name -> SDoc +ppr_defn_site imp_spec name + | same_module && not (isGoodSrcSpan loc) + = empty -- Nothing interesting to say + | otherwise + = parens $ hang (text "and originally defined" <+> pp_mod) + 2 (pprLoc loc) + where + loc = nameSrcSpan name + defining_mod = assertPpr (isExternalName name) (ppr name) $ nameModule name + same_module = importSpecModule imp_spec == moduleName defining_mod + pp_mod | same_module = empty + | otherwise = text "in" <+> quotes (ppr defining_mod) + + +instance Outputable ImportSpec where + 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 + +-- | 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/Name/Shape.hs b/GHC/Types/Name/Shape.hs --- a/GHC/Types/Name/Shape.hs +++ b/GHC/Types/Name/Shape.hs @@ -17,16 +17,14 @@ import GHC.Unit.Module -import GHC.Types.Unique.FM import GHC.Types.Avail -import GHC.Types.FieldLabel import GHC.Types.Name import GHC.Types.Name.Env import GHC.Tc.Utils.Monad import GHC.Iface.Env +import GHC.Tc.Errors.Types -import GHC.Utils.Outputable import GHC.Utils.Panic.Plain import Control.Monad @@ -87,7 +85,7 @@ mkNameShape mod_name as = NameShape mod_name as $ mkOccEnv $ do a <- as - n <- availName a : availNamesWithSelectors a + n <- availName a : availNames a return (occName n, n) -- | Given an existing 'NameShape', merge it with a list of 'AvailInfo's @@ -106,7 +104,7 @@ -- restricted notion of shaping than in Backpack'14: we do shaping -- *as* we do type-checking. Thus, once we shape a signature, its -- exports are *final* and we're not allowed to refine them further, -extendNameShape :: HscEnv -> NameShape -> [AvailInfo] -> IO (Either SDoc NameShape) +extendNameShape :: HscEnv -> NameShape -> [AvailInfo] -> IO (Either HsigShapeMismatchReason NameShape) extendNameShape hsc_env ns as = case uAvailInfos (ns_mod_name ns) (ns_exports ns) as of Left err -> return (Left err) @@ -180,24 +178,14 @@ -- for type constructors, where it is sufficient to substitute the 'availName' -- to induce a substitution on 'availNames'. substNameAvailInfo :: HscEnv -> ShNameSubst -> AvailInfo -> IO AvailInfo -substNameAvailInfo _ env (Avail (NormalGreName n)) = return (Avail (NormalGreName (substName env n))) -substNameAvailInfo _ env (Avail (FieldGreName fl)) = - return (Avail (FieldGreName fl { flSelector = substName env (flSelector fl) })) +substNameAvailInfo _ env (Avail gre) = + return $ Avail (substName env gre) substNameAvailInfo hsc_env env (AvailTC n ns) = let mb_mod = fmap nameModule (lookupNameEnv env n) - in AvailTC (substName env n) <$> mapM (setNameGreName hsc_env mb_mod) ns - -setNameGreName :: HscEnv -> Maybe Module -> GreName -> IO GreName -setNameGreName hsc_env mb_mod gname = case gname of - NormalGreName n -> NormalGreName <$> initIfaceLoad hsc_env (setNameModule mb_mod n) - FieldGreName fl -> FieldGreName <$> setNameFieldSelector hsc_env mb_mod fl + in AvailTC (substName env n) <$> mapM (setName hsc_env mb_mod) ns --- | Set the 'Module' of a 'FieldSelector' -setNameFieldSelector :: HscEnv -> Maybe Module -> FieldLabel -> IO FieldLabel -setNameFieldSelector _ Nothing f = return f -setNameFieldSelector hsc_env mb_mod (FieldLabel l b has_sel sel) = do - sel' <- initIfaceLoad hsc_env $ setNameModule mb_mod sel - return (FieldLabel l b has_sel sel') +setName :: HscEnv -> Maybe Module -> Name -> IO Name +setName hsc_env mb_mod nm = initIfaceLoad hsc_env (setNameModule mb_mod nm) {- ************************************************************************ @@ -224,46 +212,39 @@ -- | Unify two lists of 'AvailInfo's, given an existing substitution @subst@, -- with only name holes from @flexi@ unifiable (all other name holes rigid.) -uAvailInfos :: ModuleName -> [AvailInfo] -> [AvailInfo] -> Either SDoc ShNameSubst +uAvailInfos :: ModuleName -> [AvailInfo] -> [AvailInfo] -> Either HsigShapeMismatchReason ShNameSubst uAvailInfos flexi as1 as2 = -- pprTrace "uAvailInfos" (ppr as1 $$ ppr as2) $ - let mkOE as = listToUFM $ do a <- as - n <- availNames a - return (nameOccName n, a) + let mkOE as = mkOccEnv [(nameOccName n, a) | a <- as, n <- availNames a] in foldM (\subst (a1, a2) -> uAvailInfo flexi subst a1 a2) emptyNameEnv - (nonDetEltsUFM (intersectUFM_C (,) (mkOE as1) (mkOE as2))) + (nonDetOccEnvElts $ intersectOccEnv_C (,) (mkOE as1) (mkOE as2)) -- Edward: I have to say, this is pretty clever. -- | Unify two 'AvailInfo's, given an existing substitution @subst@, -- with only name holes from @flexi@ unifiable (all other name holes rigid.) uAvailInfo :: ModuleName -> ShNameSubst -> AvailInfo -> AvailInfo - -> Either SDoc ShNameSubst -uAvailInfo flexi subst (Avail (NormalGreName n1)) (Avail (NormalGreName n2)) = uName flexi subst n1 n2 -uAvailInfo flexi subst (AvailTC n1 _) (AvailTC n2 _) = uName flexi subst n1 n2 -uAvailInfo _ _ a1 a2 = Left $ text "While merging export lists, could not combine" - <+> ppr a1 <+> text "with" <+> ppr a2 - <+> parens (text "one is a type, the other is a plain identifier") + -> Either HsigShapeMismatchReason ShNameSubst +uAvailInfo flexi subst (Avail n1) (Avail n2) + = uName flexi subst n1 n2 +uAvailInfo flexi subst (AvailTC n1 _) (AvailTC n2 _) + = uName flexi subst n1 n2 +uAvailInfo _ _ a1 a2 = Left $ HsigShapeSortMismatch a1 a2 -- | Unify two 'Name's, given an existing substitution @subst@, -- with only name holes from @flexi@ unifiable (all other name holes rigid.) -uName :: ModuleName -> ShNameSubst -> Name -> Name -> Either SDoc ShNameSubst +uName :: ModuleName -> ShNameSubst -> Name -> Name -> Either HsigShapeMismatchReason ShNameSubst uName flexi subst n1 n2 | n1 == n2 = Right subst | isFlexi n1 = uHoleName flexi subst n1 n2 | isFlexi n2 = uHoleName flexi subst n2 n1 - | otherwise = Left (text "While merging export lists, could not unify" - <+> ppr n1 <+> text "with" <+> ppr n2 $$ extra) + | otherwise = Left (HsigShapeNotUnifiable n1 n2 (isHoleName n1 || isHoleName n2)) where isFlexi n = isHoleName n && moduleName (nameModule n) == flexi - extra | isHoleName n1 || isHoleName n2 - = text "Neither name variable originates from the current signature." - | otherwise - = empty -- | Unify a name @h@ which 'isHoleName' with another name, given an existing -- substitution @subst@, with only name holes from @flexi@ unifiable (all -- other name holes rigid.) uHoleName :: ModuleName -> ShNameSubst -> Name {- hole name -} -> Name - -> Either SDoc ShNameSubst + -> Either HsigShapeMismatchReason ShNameSubst uHoleName flexi subst h n = assert (isHoleName h) $ case lookupNameEnv subst h of 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,22 +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 -> [PrimRep] -typePrimRepArgs ty - | [] <- reps - = [VoidRep] - | otherwise - = reps - 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: @@ -124,12 +111,19 @@ | otherwise = NS_Done +-- | Count the arity of a function post-unarisation, including zero-width arguments. +-- +-- The post-unarisation arity may be larger than the arity of the original +-- function type. See Note [Unarisation]. countFunRepArgs :: Arity -> Type -> RepArity countFunRepArgs 0 _ = 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)) @@ -160,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) @@ -304,16 +295,17 @@ 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 LiftedRep = PtrLiftedSlot -primRepSlot UnliftedRep = PtrUnliftedSlot +primRepSlot (BoxedRep mlev) = case mlev of + Nothing -> panic "primRepSlot: levity polymorphic BoxedRep" + Just Lifted -> PtrLiftedSlot + Just Unlifted -> PtrUnliftedSlot primRepSlot IntRep = WordSlot primRepSlot Int8Rep = WordSlot primRepSlot Int16Rep = WordSlot @@ -330,8 +322,8 @@ primRepSlot (VecRep n e) = VecSlot n e slotPrimRep :: SlotTy -> PrimRep -slotPrimRep PtrLiftedSlot = LiftedRep -slotPrimRep PtrUnliftedSlot = UnliftedRep +slotPrimRep PtrLiftedSlot = BoxedRep (Just Lifted) +slotPrimRep PtrUnliftedSlot = BoxedRep (Just Unlifted) slotPrimRep Word64Slot = Word64Rep slotPrimRep WordSlot = WordRep slotPrimRep DoubleSlot = DoubleRep @@ -392,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 @@ -442,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]. @@ -525,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. -} @@ -547,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] @@ -568,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] @@ -604,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 @@ -618,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] @@ -635,9 +638,10 @@ -- | Convert a 'PrimRep' to a 'Type' of kind RuntimeRep primRepToRuntimeRep :: PrimRep -> RuntimeRepType primRepToRuntimeRep rep = case rep of - VoidRep -> zeroBitRepTy - LiftedRep -> liftedRepTy - UnliftedRep -> unliftedRepTy + BoxedRep mlev -> case mlev of + Nothing -> panic "primRepToRuntimeRep: levity polymorphic BoxedRep" + Just Lifted -> liftedRepTy + Just Unlifted -> unliftedRepTy IntRep -> intRepDataConTy Int8Rep -> int8RepDataConTy Int16Rep -> int16RepDataConTy @@ -689,9 +693,12 @@ -- AK: It would be nice to figure out and document the difference -- between this and isFunTy at some point. mightBeFunTy ty - | [LiftedRep] <- typePrimRep 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/SaneDouble.hs b/GHC/Types/SaneDouble.hs new file mode 100644 --- /dev/null +++ b/GHC/Types/SaneDouble.hs @@ -0,0 +1,48 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} + +-- | Double datatype with saner instances +module GHC.Types.SaneDouble + ( SaneDouble (..) + ) +where + +import GHC.Prelude +import GHC.Utils.Binary +import GHC.Float (castDoubleToWord64, castWord64ToDouble) + +-- | A newtype wrapper around 'Double' to ensure we never generate a 'Double' +-- that becomes a 'NaN', see instances for details on sanity. +newtype SaneDouble = SaneDouble + { unSaneDouble :: Double + } + deriving (Fractional, Num) + +instance Eq SaneDouble where + (SaneDouble x) == (SaneDouble y) = x == y || (isNaN x && isNaN y) + +instance Ord SaneDouble where + compare (SaneDouble x) (SaneDouble y) = compare (fromNaN x) (fromNaN y) + where fromNaN z | isNaN z = Nothing + | otherwise = Just z + +instance Show SaneDouble where + show (SaneDouble x) = show x + +-- we need to preserve NaN and infinities, unfortunately the Binary instance for +-- Double does not do this +instance Binary SaneDouble where + put_ bh (SaneDouble d) + | isNaN d = putByte bh 1 + | isInfinite d && d > 0 = putByte bh 2 + | isInfinite d && d < 0 = putByte bh 3 + | isNegativeZero d = putByte bh 4 + | otherwise = putByte bh 5 >> put_ bh (castDoubleToWord64 d) + get bh = getByte bh >>= \case + 1 -> pure $ SaneDouble (0 / 0) + 2 -> pure $ SaneDouble (1 / 0) + 3 -> pure $ SaneDouble ((-1) / 0) + 4 -> pure $ SaneDouble (-0) + 5 -> SaneDouble . castWord64ToDouble <$> get bh + n -> error ("Binary get bh SaneDouble: invalid tag: " ++ show n) + diff --git a/GHC/Types/SourceFile.hs b/GHC/Types/SourceFile.hs --- a/GHC/Types/SourceFile.hs +++ b/GHC/Types/SourceFile.hs @@ -1,8 +1,11 @@ +{-# LANGUAGE PatternSynonyms #-} + module GHC.Types.SourceFile - ( HscSource(..) + ( HscSource(HsBootFile, HsigFile, ..) + , HsBootOrSig(..) , hscSourceToIsBoot , isHsBootOrSig - , isHsigFile + , isHsBootFile, isHsigFile , hscSourceString ) where @@ -10,46 +13,63 @@ import GHC.Prelude import GHC.Utils.Binary import GHC.Unit.Types +import Control.DeepSeq --- Note [HscSource types] --- ~~~~~~~~~~~~~~~~~~~~~~ --- There are three types of source file for Haskell code: --- --- * HsSrcFile is an ordinary hs file which contains code, --- --- * HsBootFile is an hs-boot file, which is used to break --- recursive module imports (there will always be an --- HsSrcFile associated with it), and --- --- * HsigFile is an hsig file, which contains only type --- signatures and is used to specify signatures for --- modules. --- --- Syntactically, hs-boot files and hsig files are quite similar: they --- only include type signatures and must be associated with an --- actual HsSrcFile. isHsBootOrSig allows us to abstract over code --- which is indifferent to which. However, there are some important --- differences, mostly owing to the fact that hsigs are proper --- modules (you `import Sig` directly) whereas HsBootFiles are --- temporary placeholders (you `import {-# SOURCE #-} Mod). --- When we finish compiling the true implementation of an hs-boot, --- we replace the HomeModInfo with the real HsSrcFile. An HsigFile, on the --- other hand, is never replaced (in particular, we *cannot* use the --- HomeModInfo of the original HsSrcFile backing the signature, since it --- will export too many symbols.) --- --- Additionally, while HsSrcFile is the only Haskell file --- which has *code*, we do generate .o files for HsigFile, because --- this is how the recompilation checker figures out if a file --- needs to be recompiled. These are fake object files which --- should NOT be linked against. +{- Note [HscSource types] +~~~~~~~~~~~~~~~~~~~~~~~~~ +There are three types of source file for Haskell code: + * HsSrcFile is an ordinary hs file which contains code, + + * HsBootFile is an hs-boot file, which is used to break + recursive module imports (there will always be an + HsSrcFile associated with it), and + + * HsigFile is an hsig file, which contains only type + signatures and is used to specify signatures for + modules. + +Syntactically, hs-boot files and hsig files are quite similar: they +only include type signatures and must be associated with an +actual HsSrcFile. isHsBootOrSig allows us to abstract over code +which is indifferent to which. However, there are some important +differences, mostly owing to the fact that hsigs are proper +modules (you `import Sig` directly) whereas HsBootFiles are +temporary placeholders (you `import {-# SOURCE #-} Mod). +When we finish compiling the true implementation of an hs-boot, +we replace the HomeModInfo with the real HsSrcFile. An HsigFile, on the +other hand, is never replaced (in particular, we *cannot* use the +HomeModInfo of the original HsSrcFile backing the signature, since it +will export too many symbols.) + +Additionally, while HsSrcFile is the only Haskell file +which has *code*, we do generate .o files for HsigFile, because +this is how the recompilation checker figures out if a file +needs to be recompiled. These are fake object files which +should NOT be linked against. +-} + +data HsBootOrSig + = HsBoot -- ^ .hs-boot file + | Hsig -- ^ .hsig file + deriving (Eq, Ord, Show) + +instance NFData HsBootOrSig where + rnf HsBoot = () + rnf Hsig = () + data HscSource - = HsSrcFile -- ^ .hs file - | HsBootFile -- ^ .hs-boot file - | HsigFile -- ^ .hsig file + -- | .hs file + = HsSrcFile + -- | .hs-boot or .hsig file + | HsBootOrSig !HsBootOrSig deriving (Eq, Ord, Show) +{-# COMPLETE HsSrcFile, HsBootFile, HsigFile #-} +pattern HsBootFile, HsigFile :: HscSource +pattern HsBootFile = HsBootOrSig HsBoot +pattern HsigFile = HsBootOrSig Hsig + -- | Tests if an 'HscSource' is a boot file, primarily for constructing elements -- of 'BuildModule'. We conflate signatures and modules because they are bound -- in the same namespace; only boot interfaces can be disambiguated with @@ -58,6 +78,10 @@ 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 put_ bh HsBootFile = putByte bh 1 @@ -70,15 +94,18 @@ _ -> return HsigFile hscSourceString :: HscSource -> String -hscSourceString HsSrcFile = "" -hscSourceString HsBootFile = "[boot]" -hscSourceString HsigFile = "[sig]" +hscSourceString HsSrcFile = "" +hscSourceString HsBootFile = "[boot]" +hscSourceString HsigFile = "[sig]" -- See Note [HscSource types] isHsBootOrSig :: HscSource -> Bool -isHsBootOrSig HsBootFile = True -isHsBootOrSig HsigFile = True -isHsBootOrSig _ = False +isHsBootOrSig (HsBootOrSig _) = True +isHsBootOrSig HsSrcFile = False + +isHsBootFile :: HscSource -> Bool +isHsBootFile HsBootFile = True +isHsBootFile _ = False isHsigFile :: HscSource -> Bool isHsigFile HsigFile = True diff --git a/GHC/Types/SourceText.hs b/GHC/Types/SourceText.hs --- a/GHC/Types/SourceText.hs +++ b/GHC/Types/SourceText.hs @@ -1,4 +1,7 @@ {-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RecordWildCards #-} -- | Source text -- @@ -38,6 +41,7 @@ import Data.Data import GHC.Real ( Ratio(..) ) import GHC.Types.SrcLoc +import Control.DeepSeq {- Note [Pragma source text] @@ -95,7 +99,7 @@ -- Note [Literal source text],[Pragma source text] data SourceText - = SourceText String + = SourceText FastString | NoSourceText -- ^ For when code is generated, e.g. TH, -- deriving. The pretty printer will then make @@ -103,9 +107,14 @@ deriving (Data, Show, Eq ) instance Outputable SourceText where - ppr (SourceText s) = text "SourceText" <+> text s + ppr (SourceText s) = text "SourceText" <+> ftext s ppr NoSourceText = text "NoSourceText" +instance NFData SourceText where + rnf = \case + SourceText s -> rnf s + NoSourceText -> () + instance Binary SourceText where put_ bh NoSourceText = putByte bh 0 put_ bh (SourceText s) = do @@ -124,7 +133,7 @@ -- | Special combinator for showing string literals. pprWithSourceText :: SourceText -> SDoc -> SDoc pprWithSourceText NoSourceText d = d -pprWithSourceText (SourceText src) _ = text src +pprWithSourceText (SourceText src) _ = ftext src ------------------------------------------------ -- Literals @@ -143,7 +152,7 @@ deriving (Data, Show) mkIntegralLit :: Integral a => a -> IntegralLit -mkIntegralLit i = IL { il_text = SourceText (show i_integer) +mkIntegralLit i = IL { il_text = SourceText (fsLit $ show i_integer) , il_neg = i < 0 , il_value = i_integer } where @@ -153,9 +162,9 @@ negateIntegralLit :: IntegralLit -> IntegralLit negateIntegralLit (IL text neg value) = case text of - SourceText ('-':src) -> IL (SourceText src) False (negate value) - SourceText src -> IL (SourceText ('-':src)) True (negate value) - NoSourceText -> IL NoSourceText (not neg) (negate value) + SourceText (unconsFS -> Just ('-',src)) -> IL (SourceText src) False (negate value) + SourceText src -> IL (SourceText ('-' `consFS` src)) True (negate value) + NoSourceText -> IL NoSourceText (not neg) (negate value) -- | Fractional Literal -- @@ -206,7 +215,7 @@ mkRationalWithExponentBase i e expBase mkTHFractionalLit :: Rational -> FractionalLit -mkTHFractionalLit r = FL { fl_text = SourceText (show (realToFrac r::Double)) +mkTHFractionalLit r = FL { fl_text = SourceText (fsLit $ show (realToFrac r::Double)) -- Converting to a Double here may technically lose -- precision (see #15502). We could alternatively -- convert to a Rational for the most accuracy, but @@ -222,13 +231,14 @@ negateFractionalLit :: FractionalLit -> FractionalLit negateFractionalLit (FL text neg i e eb) = case text of - SourceText ('-':src) -> FL (SourceText src) False (negate i) e eb - SourceText src -> FL (SourceText ('-':src)) True (negate i) e eb + SourceText (unconsFS -> Just ('-',src)) + -> FL (SourceText src) False (negate i) e eb + SourceText src -> FL (SourceText ('-' `consFS` src)) True (negate i) e eb NoSourceText -> FL NoSourceText (not neg) (negate i) e eb -- | The integer should already be negated if it's negative. integralFractionalLit :: Bool -> Integer -> FractionalLit -integralFractionalLit neg i = FL { fl_text = SourceText (show i) +integralFractionalLit neg i = FL { fl_text = SourceText (fsLit $ show i) , fl_neg = neg , fl_signi = i :% 1 , fl_exp = 0 @@ -238,7 +248,7 @@ mkSourceFractionalLit :: String -> Bool -> Integer -> Integer -> FractionalExponentBase -> FractionalLit -mkSourceFractionalLit !str !b !r !i !ff = FL (SourceText str) b (r :% 1) i ff +mkSourceFractionalLit !str !b !r !i !ff = FL (SourceText $ fsLit str) b (r :% 1) i ff {- Note [fractional exponent bases] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -258,7 +268,7 @@ compare = compare `on` il_value instance Outputable IntegralLit where - ppr (IL (SourceText src) _ _) = text src + ppr (IL (SourceText src) _ _) = ftext src ppr (IL NoSourceText _ value) = text (show value) @@ -295,30 +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) - -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) + 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 @@ -64,6 +64,9 @@ isGoodSrcSpan, isOneLineSpan, isZeroWidthSpan, containsSpan, isNoSrcSpan, + -- ** Predicates on RealSrcSpan + isPointRealSpan, + -- * StringBuffer locations BufPos(..), getBufPos, @@ -106,6 +109,10 @@ mkSrcSpanPs, combineRealSrcSpans, psLocatedToLocated, + + -- * Exact print locations + EpaLocation'(..), NoCommentsLocation, NoComments(..), + DeltaPos(..), deltaPos, getDeltaLine, ) where import GHC.Prelude @@ -216,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] @@ -366,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) @@ -423,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 @@ -889,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,10 +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 @@ -39,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, (<+>)) {- ********************************************************************* * * @@ -105,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 @@ -125,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 @@ -153,8 +160,8 @@ -- necessary to enable optimizations. | SourceNote { sourceSpan :: RealSrcSpan -- ^ Source covered - , sourceName :: String -- ^ Name for source location - -- (uses same names as CCs) + , sourceName :: LexicalFastString -- ^ Name for source location + -- (uses same names as CCs) } deriving instance Eq (GenTickish 'TickishPassCore) @@ -167,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 @@ -291,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 @@ -1,3 +1,5 @@ +{-# LANGUAGE LambdaCase #-} + -- | A global typecheckable-thing, essentially anything that has a name. module GHC.Types.TyThing ( TyThing (..) @@ -15,7 +17,7 @@ , isImplicitTyThing , tyThingParent_maybe , tyThingsTyCoVars - , tyThingAvailInfo + , tyThingLocalGREs, tyThingGREInfo , tyThingTyCon , tyThingCoAxiom , tyThingDataCon @@ -26,12 +28,14 @@ import GHC.Prelude +import GHC.Types.GREInfo import GHC.Types.Name +import GHC.Types.Name.Reader import GHC.Types.Var import GHC.Types.Var.Set import GHC.Types.Id import GHC.Types.Id.Info -import GHC.Types.Avail +import GHC.Types.Unique.Set import GHC.Core.Class import GHC.Core.DataCon @@ -49,6 +53,11 @@ import Control.Monad.Trans.Reader import Control.Monad.Trans.Class +import Data.List.NonEmpty ( NonEmpty(..) ) +import qualified Data.List.NonEmpty as NE +import Data.List ( intersect ) + + {- Note [ATyCon for classes] ~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -116,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 @@ -257,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 @@ -276,22 +286,90 @@ Nothing -> tyCoVarsOfType $ tyConKind tc ttToVarSet (ACoAxiom _) = emptyVarSet --- | The Names that a TyThing should bring into scope. Used to build --- the GlobalRdrEnv for the InteractiveContext. -tyThingAvailInfo :: TyThing -> [AvailInfo] -tyThingAvailInfo (ATyCon t) - = case tyConClass_maybe t of - Just c -> [availTC n ((n : map getName (classMethods c) - ++ map getName (classATs c))) [] ] - where n = getName c - Nothing -> [availTC n (n : map getName dcs) flds] - where n = getName t - dcs = tyConDataCons t - flds = tyConFieldLabels t -tyThingAvailInfo (AConLike (PatSynCon p)) - = avail (getName p) : map availField (patSynFieldLabels p) -tyThingAvailInfo t - = [avail (getName t)] +-- | The 'GlobalRdrElt's that a 'TyThing' should bring into scope. +-- Used to build the 'GlobalRdrEnv' for the InteractiveContext. +tyThingLocalGREs :: TyThing -> [GlobalRdrElt] +tyThingLocalGREs ty_thing = + case ty_thing of + ATyCon t + | Just c <- tyConClass_maybe t + -> myself NoParent + : ( map (mkLocalVanillaGRE (ParentIs $ className c) . getName) (classMethods c) + ++ map tc_GRE (classATs c) ) + | otherwise + -> let dcs = tyConDataCons t + par = ParentIs $ tyConName t + mk_nm = DataConName . dataConName + in myself NoParent + : map (dc_GRE par) dcs + ++ + mkLocalFieldGREs par + [ (mk_nm dc, con_info) + | dc <- dcs + , let con_info = conLikeConInfo (RealDataCon dc) ] + AConLike con -> + let (par, cons_flds) = case con of + PatSynCon {} -> + (NoParent, [(conLikeConLikeName con, conLikeConInfo con)]) + -- NB: NoParent for local pattern synonyms, as per + -- Note [Parents] in GHC.Types.Name.Reader. + RealDataCon dc1 -> + (ParentIs $ tyConName $ dataConTyCon dc1 + , [ (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) + , ConInfo conInfo (ConHasRecordFields flds0) <- [con_info] + , let flds1 = NE.toList flds0 `intersect` dataConFieldLabels dc + , fld:flds <- [flds1] + ]) + in myself par : mkLocalFieldGREs par cons_flds + AnId id + | RecSelId { sel_tycon = RecSelData tc } <- idDetails id + -> [ myself (ParentIs $ tyConName tc) ] + -- Fallback to NoParent for PatSyn record selectors, + -- as per Note [Parents] in GHC.Types.Name.Reader. + _ -> [ myself NoParent ] + where + tc_GRE :: TyCon -> GlobalRdrElt + tc_GRE at = mkLocalTyConGRE + (fmap tyConName $ tyConFlavour at) + (tyConName at) + dc_GRE :: Parent -> DataCon -> GlobalRdrElt + dc_GRE par dc = + let con_info = conLikeConInfo (RealDataCon dc) + in mkLocalConLikeGRE par (DataConName $ dataConName dc, con_info) + myself :: Parent -> GlobalRdrElt + myself p = mkLocalGRE (tyThingGREInfo ty_thing) p (getName ty_thing) + +-- | Obtain information pertinent to the renamer about a particular 'TyThing'. +-- +-- This extracts out renamer information from typechecker information. +tyThingGREInfo :: TyThing -> GREInfo +tyThingGREInfo = \case + AConLike con -> IAmConLike $ conLikeConInfo con + AnId id -> case idDetails id of + RecSelId { sel_tycon = parent, sel_fieldLabel = fl } -> + let relevant_cons = case parent of + RecSelPatSyn ps -> unitUniqSet $ PatSynName (patSynName ps) + RecSelData tc -> + let dcs = map RealDataCon $ tyConDataCons tc in + 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 ] + cons -> mkUniqSet $ map conLikeConLikeName cons + in IAmRecField $ + RecFieldInfo + { recFieldLabel = fl + , recFieldCons = relevant_cons } + _ -> Vanilla + ATyCon tc -> + IAmTyCon (fmap tyConName $ tyConFlavour tc) + _ -> Vanilla -- | Get the 'TyCon' from a 'TyThing' if it is a type constructor thing. Panics otherwise tyThingTyCon :: HasDebugCallStack => TyThing -> TyCon 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 @@ -26,9 +26,9 @@ import GHC.Core.FamInstEnv( FamInst(..), FamFlavor(..) ) import GHC.Core.TyCo.Ppr ( pprUserForAll, pprTypeApp ) +import GHC.Iface.Decl ( tyThingToIfaceDecl ) import GHC.Iface.Syntax ( ShowSub(..), ShowHowMuch(..), AltPpr(..) - , showToHeader, pprIfaceDecl ) -import GHC.Iface.Make ( tyThingToIfaceDecl ) + , showToHeader, pprIfaceDecl ) import GHC.Utils.Outputable @@ -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/TyThing/Ppr.hs-boot b/GHC/Types/TyThing/Ppr.hs-boot new file mode 100644 --- /dev/null +++ b/GHC/Types/TyThing/Ppr.hs-boot @@ -0,0 +1,11 @@ +module GHC.Types.TyThing.Ppr ( + pprTyThing, + pprTyThingInContext + ) where + +import GHC.Iface.Type ( ShowSub ) +import GHC.Types.TyThing ( TyThing ) +import GHC.Utils.Outputable ( SDoc ) + +pprTyThing :: ShowSub -> TyThing -> SDoc +pprTyThingInContext :: ShowSub -> TyThing -> SDoc diff --git a/GHC/Types/TypeEnv.hs b/GHC/Types/TypeEnv.hs --- a/GHC/Types/TypeEnv.hs +++ b/GHC/Types/TypeEnv.hs @@ -93,4 +93,3 @@ plusTypeEnv :: TypeEnv -> TypeEnv -> TypeEnv plusTypeEnv env1 env2 = plusNameEnv env1 env2 - 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, @@ -94,7 +96,7 @@ -- order then `udfmToList` returns them in deterministic order. -- -- There is an implementation cost: each element is given a serial number --- as it is added, and `udfmToList` sorts it's result by this serial +-- as it is added, and `udfmToList` sorts its result by this serial -- number. So you should only use `UniqDFM` if you need the deterministic -- property. -- @@ -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 @@ -44,7 +44,7 @@ addListToUFM,addListToUFM_C, addToUFM_Directly, addListToUFM_Directly, - adjustUFM, alterUFM, + adjustUFM, alterUFM, alterUFM_Directly, adjustUFM_Directly, delFromUFM, delFromUFM_Directly, @@ -57,6 +57,7 @@ mergeUFM, plusMaybeUFM_C, plusUFMList, + plusUFMListWith, sequenceUFMList, minusUFM, minusUFM_C, @@ -64,11 +65,13 @@ intersectUFM_C, disjointUFM, equalKeysUFM, - nonDetStrictFoldUFM, foldUFM, nonDetStrictFoldUFM_DirectlyM, + diffUFM, + nonDetStrictFoldUFM, nonDetFoldUFM, nonDetStrictFoldUFM_DirectlyM, + nonDetFoldWithKeyUFM, nonDetStrictFoldUFM_Directly, anyUFM, allUFM, seqEltsUFM, - mapUFM, mapUFM_Directly, - mapMaybeUFM, + mapUFM, mapUFM_Directly, strictMapUFM, + mapMaybeUFM, mapMaybeUFM_sameUnique, mapMaybeWithKeyUFM, elemUFM, elemUFM_Directly, filterUFM, filterUFM_Directly, partitionUFM, sizeUFM, @@ -137,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 @@ -150,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) @@ -165,10 +171,10 @@ addToUFM_C :: Uniquable key - => (elt -> elt -> elt) -- old -> new -> result - -> UniqFM key elt -- old - -> key -> elt -- new - -> UniqFM key elt -- result + => (elt -> elt -> elt) -- ^ old -> new -> result + -> UniqFM key elt -- ^ old + -> key -> elt -- ^ new + -> UniqFM key elt -- ^ result -- Arguments of combining function of M.insertWith and addToUFM_C are flipped. addToUFM_C f (UFM m) k v = UFM (M.insertWith (flip f) (getKey $ getUnique k) v m) @@ -177,9 +183,9 @@ :: Uniquable key => (elt -> elts -> elts) -- Add to existing -> (elt -> elts) -- New element - -> UniqFM key elts -- old + -> UniqFM key elts -- old -> key -> elt -- new - -> UniqFM key elts -- result + -> UniqFM key elts -- result addToUFM_Acc exi new (UFM m) k v = UFM (M.insertWith (\_new old -> exi v old) (getKey $ getUnique k) (new v) m) @@ -188,11 +194,11 @@ -- otherwise compute the element to add using the passed function. addToUFM_L :: Uniquable key - => (key -> elt -> elt -> elt) -- key,old,new + => (key -> elt -> elt -> elt) -- ^ key,old,new -> key -> elt -- new -> UniqFM key elt - -> (Maybe elt, UniqFM key elt) -- old, result + -> (Maybe elt, UniqFM key elt) -- ^ old, result addToUFM_L f k v (UFM m) = coerce $ M.insertLookupWithKey @@ -203,12 +209,19 @@ alterUFM :: Uniquable key - => (Maybe elt -> Maybe elt) -- How to adjust - -> UniqFM key elt -- old - -> key -- new - -> UniqFM key elt -- result + => (Maybe elt -> Maybe elt) -- ^ How to adjust + -> UniqFM key elt -- ^ old + -> key -- ^ new + -> UniqFM key elt -- ^ result alterUFM f (UFM m) k = UFM (M.alter f (getKey $ getUnique k) m) +alterUFM_Directly + :: (Maybe elt -> Maybe elt) -- ^ How to adjust + -> UniqFM key elt -- ^ old + -> Unique -- ^ new + -> UniqFM key elt -- ^ result +alterUFM_Directly f (UFM m) k = UFM (M.alter f (getKey k) m) + -- | Add elements to the map, combining existing values with inserted ones using -- the given function. addListToUFM_C @@ -227,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) @@ -323,6 +338,9 @@ plusUFMList :: [UniqFM key elt] -> UniqFM key elt plusUFMList = foldl' plusUFM emptyUFM +plusUFMListWith :: (elt -> elt -> elt) -> [UniqFM key elt] -> UniqFM key elt +plusUFMListWith f xs = unsafeIntMapToUFM $ M.unionsWith f (map ufmToIntMap xs) + sequenceUFMList :: forall key elt. [UniqFM key elt] -> UniqFM key [elt] sequenceUFMList = foldr (plusUFM_CD2 cons) emptyUFM where @@ -356,18 +374,39 @@ disjointUFM :: UniqFM key elt1 -> UniqFM key elt2 -> Bool disjointUFM (UFM x) (UFM y) = M.disjoint x y -foldUFM :: (elt -> a -> a) -> a -> UniqFM key elt -> a -foldUFM k z (UFM m) = M.foldr k z m +-- | Fold over a 'UniqFM'. +-- +-- Non-deterministic, unless the folding function is commutative +-- (i.e. @a1 `f` ( a2 `f` b ) == a2 `f` ( a1 `f` b )@ for all @a1@, @a2@, @b@). +nonDetFoldUFM :: (elt -> a -> a) -> a -> UniqFM key elt -> a +nonDetFoldUFM f z (UFM m) = M.foldr f z m +-- | Like 'nonDetFoldUFM', but with the 'Unique' key as well. +nonDetFoldWithKeyUFM :: (Unique -> elt -> a -> a) -> a -> UniqFM key elt -> a +nonDetFoldWithKeyUFM f z (UFM m) = M.foldrWithKey f' z m + where + f' k e a = f (mkUniqueGrimily k) e a + mapUFM :: (elt1 -> elt2) -> UniqFM key elt1 -> UniqFM key elt2 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) + mapUFM_Directly :: (Unique -> elt1 -> elt2) -> UniqFM key elt1 -> UniqFM key elt2 mapUFM_Directly f (UFM m) = UFM (M.mapWithKey (f . mkUniqueGrimily) m) +strictMapUFM :: (a -> b) -> UniqFM k a -> UniqFM k b +strictMapUFM f (UFM a) = UFM $ MS.map f a + filterUFM :: (elt -> Bool) -> UniqFM key elt -> UniqFM key elt filterUFM p (UFM m) = UFM (M.filter p m) @@ -411,7 +450,7 @@ allUFM p (UFM m) = M.foldr ((&&) . p) True m seqEltsUFM :: (elt -> ()) -> UniqFM key elt -> () -seqEltsUFM seqElt = foldUFM (\v rest -> seqElt v `seq` rest) () +seqEltsUFM seqElt = nonDetFoldUFM (\v rest -> seqElt v `seq` rest) () -- See Note [Deterministic UniqFM] to learn about nondeterminism. -- If you use this please provide a justification why it doesn't introduce @@ -492,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/Map.hs b/GHC/Types/Unique/Map.hs --- a/GHC/Types/Unique/Map.hs +++ b/GHC/Types/Unique/Map.hs @@ -30,20 +30,25 @@ plusUniqMap_C, plusMaybeUniqMap_C, plusUniqMapList, + plusUniqMapListWith, minusUniqMap, intersectUniqMap, intersectUniqMap_C, disjointUniqMap, mapUniqMap, filterUniqMap, + filterWithKeyUniqMap, partitionUniqMap, sizeUniqMap, elemUniqMap, + nonDetKeysUniqMap, + nonDetEltsUniqMap, lookupUniqMap, lookupWithDefaultUniqMap, anyUniqMap, allUniqMap, - nonDetEltsUniqMap, + nonDetUniqMapToList, + nonDetUniqMapToKeySet, nonDetFoldUniqMap -- Non-deterministic functions omitted ) where @@ -61,6 +66,8 @@ import Data.Data import Control.DeepSeq +import Data.Set (Set, fromList) + -- | Maps indexed by 'Uniquable' keys newtype UniqMap k a = UniqMap { getUniqMap :: UniqFM k (k, a) } deriving (Data, Eq, Functor) @@ -192,6 +199,13 @@ plusUniqMapList :: [UniqMap k a] -> UniqMap k a plusUniqMapList xs = UniqMap $ plusUFMList (coerce xs) +plusUniqMapListWith :: (a -> a -> a) -> [UniqMap k a] -> UniqMap k a +plusUniqMapListWith f xs = UniqMap $ plusUFMListWith go (coerce xs) + where + -- l and r keys will be identical so we choose the former + go (l_key, l) (_r, r) = (l_key, f l r) +{-# INLINE plusUniqMapListWith #-} + minusUniqMap :: UniqMap k a -> UniqMap k b -> UniqMap k a minusUniqMap (UniqMap m1) (UniqMap m2) = UniqMap $ minusUFM m1 m2 @@ -201,6 +215,7 @@ -- | Intersection with a combining function. intersectUniqMap_C :: (a -> b -> c) -> UniqMap k a -> UniqMap k b -> UniqMap k c intersectUniqMap_C f (UniqMap m1) (UniqMap m2) = UniqMap $ intersectUFM_C (\(k, a) (_, b) -> (k, f a b)) m1 m2 +{-# INLINE intersectUniqMap #-} disjointUniqMap :: UniqMap k a -> UniqMap k b -> Bool disjointUniqMap (UniqMap m1) (UniqMap m2) = disjointUFM m1 m2 @@ -211,6 +226,9 @@ filterUniqMap :: (a -> Bool) -> UniqMap k a -> UniqMap k a filterUniqMap f (UniqMap m) = UniqMap $ filterUFM (f . snd) m +filterWithKeyUniqMap :: (k -> a -> Bool) -> UniqMap k a -> UniqMap k a +filterWithKeyUniqMap f (UniqMap m) = UniqMap $ filterUFM (uncurry f) m + partitionUniqMap :: (a -> Bool) -> UniqMap k a -> (UniqMap k a, UniqMap k a) partitionUniqMap f (UniqMap m) = coerce $ partitionUFM (f . snd) m @@ -233,8 +251,21 @@ allUniqMap :: (a -> Bool) -> UniqMap k a -> Bool allUniqMap f (UniqMap m) = allUFM (f . snd) m -nonDetEltsUniqMap :: UniqMap k a -> [(k, a)] -nonDetEltsUniqMap (UniqMap m) = nonDetEltsUFM m +nonDetUniqMapToList :: UniqMap k a -> [(k, a)] +nonDetUniqMapToList (UniqMap m) = nonDetEltsUFM m +{-# INLINE nonDetUniqMapToList #-} +nonDetUniqMapToKeySet :: Ord k => UniqMap k a -> Set k +nonDetUniqMapToKeySet m = fromList (nonDetKeysUniqMap m) + +nonDetKeysUniqMap :: UniqMap k a -> [k] +nonDetKeysUniqMap m = map fst (nonDetUniqMapToList m) +{-# INLINE nonDetKeysUniqMap #-} + +nonDetEltsUniqMap :: UniqMap k a -> [a] +nonDetEltsUniqMap m = map snd (nonDetUniqMapToList m) +{-# INLINE nonDetEltsUniqMap #-} + nonDetFoldUniqMap :: ((k, a) -> b -> b) -> b -> UniqMap k a -> b -nonDetFoldUniqMap go z (UniqMap m) = foldUFM go z m +nonDetFoldUniqMap go z (UniqMap m) = nonDetFoldUFM go z m +{-# INLINE nonDetFoldUniqMap #-} 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,23 +86,29 @@ -- 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 unitUniqSet :: Uniquable a => a -> UniqSet a unitUniqSet x = UniqSet $ unitUFM x x -mkUniqSet :: Uniquable a => [a] -> UniqSet a +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 @@ -186,7 +222,7 @@ -- | 'unsafeUFMToUniqSet' converts a @'UniqFM' a@ into a @'UniqSet' a@ -- assuming, without checking, that it maps each 'Unique' to a value -- that has that 'Unique'. See Note [UniqSet invariant]. -unsafeUFMToUniqSet :: UniqFM a a -> UniqSet a +unsafeUFMToUniqSet :: UniqFM a a -> UniqSet a unsafeUFMToUniqSet = UniqSet instance Outputable a => Outputable (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. @@ -687,10 +641,6 @@ * TyCon.TyConBinder = VarBndr TyVar TyConBndrVis Binders of a TyCon; see TyCon in GHC.Core.TyCon -* TyCon.TyConPiTyBinder = VarBndr TyCoVar TyConBndrVis - Binders of a PromotedDataCon - See Note [Promoted GADT data constructors] in GHC.Core.TyCon - * IfaceType.IfaceForAllBndr = VarBndr IfaceBndr ForAllTyFlag * IfaceType.IfaceForAllSpecBndr = VarBndr IfaceBndr Specificity * IfaceType.IfaceTyConBinder = VarBndr IfaceBndr TyConBndrVis @@ -698,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 @@ -727,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 @@ -784,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 @@ -809,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 @@ -819,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 @@ -892,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 @@ -915,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 @@ -947,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) @@ -1022,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 -> * @@ -1034,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. -} @@ -1119,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) @@ -1248,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 @@ -24,6 +24,7 @@ elemVarEnvByKey, filterVarEnv, restrictVarEnv, partitionVarEnv, varEnvDomain, + nonDetStrictFoldVarEnv_Directly, -- * Deterministic Var environments (maps) DVarEnv, DIdEnv, DTyVarEnv, @@ -73,7 +74,8 @@ -- * TidyEnv and its operation TidyEnv, - emptyTidyEnv, mkEmptyTidyEnv, delTidyEnvList + emptyTidyEnv, mkEmptyTidyEnv, delTidyEnvList, + mapMaybeDVarEnv ) where import GHC.Prelude @@ -318,25 +320,30 @@ rnBndr2_var :: RnEnv2 -> Var -> Var -> (RnEnv2, Var) -- ^ Similar to 'rnBndr2' but returns the new variable as well as the --- new environment +-- new environment. +-- Postcondition: the type of the returned Var is that of bR rnBndr2_var (RV2 { envL = envL, envR = envR, in_scope = in_scope }) bL bR - = (RV2 { envL = extendVarEnv envL bL new_b -- See Note - , envR = extendVarEnv envR bR new_b -- [Rebinding] + = (RV2 { envL = extendVarEnv envL bL new_b -- See Note + , envR = extendVarEnv envR bR new_b -- [Rebinding] , in_scope = extendInScopeSet in_scope new_b }, new_b) where -- Find a new binder not in scope in either term - new_b | not (bL `elemInScopeSet` in_scope) = bL - | not (bR `elemInScopeSet` in_scope) = bR - | otherwise = uniqAway' in_scope bL + -- To avoid calling `uniqAway`, we try bL's Unique + -- But we always return a Var whose type is that of bR + new_b | not (bR `elemInScopeSet` in_scope) = bR + | not (bL `elemInScopeSet` in_scope) = bR `setVarUnique` varUnique bL + | otherwise = uniqAway' in_scope bR -- Note [Rebinding] -- ~~~~~~~~~~~~~~~~ -- If the new var is the same as the old one, note that - -- the extendVarEnv *deletes* any current renaming + -- the extendVarEnv *replaces* any current renaming -- E.g. (\x. \x. ...) ~ (\y. \z. ...) -- + -- envL envR in_scope -- Inside \x \y { [x->y], [y->y], {y} } - -- \x \z { [x->x], [y->y, z->x], {y,x} } + -- \x \z { [x->z], [y->y, z->z], {y,z} } + -- The envL binding [x->y] is replaced by [x->z] rnBndrL :: RnEnv2 -> Var -> (RnEnv2, Var) -- ^ Similar to 'rnBndr2' but used when there's a binder on the left @@ -464,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 {- @@ -511,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 @@ -530,6 +537,7 @@ elemVarEnv :: Var -> VarEnv a -> Bool elemVarEnvByKey :: Unique -> VarEnv a -> Bool disjointVarEnv :: VarEnv a -> VarEnv a -> Bool +nonDetStrictFoldVarEnv_Directly :: (Unique -> a -> r -> r) -> r -> VarEnv a -> r elemVarEnv = elemUFM elemVarEnvByKey = elemUFM_Directly @@ -543,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 @@ -565,13 +575,14 @@ isEmptyVarEnv = isNullUFM partitionVarEnv = partitionUFM varEnvDomain = domUFMUnVarSet +nonDetStrictFoldVarEnv_Directly = nonDetStrictFoldUFM_Directly restrictVarEnv env vs = filterUFM_Directly keep env 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" @@ -645,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.hs b/GHC/Unit.hs --- a/GHC/Unit.hs +++ b/GHC/Unit.hs @@ -63,7 +63,7 @@ Certain libraries (ghc-prim, base, etc.) are known to the compiler and to the RTS as they provide some basic primitives. Hence UnitIds of wired-in libraries -are fixed. Instead of letting Cabal chose the UnitId for these libraries, their +are fixed. Instead of letting Cabal choose the UnitId for these libraries, their .cabal file uses the following stanza to force it to a specific value: ghc-options: -this-unit-id ghc-prim -- taken from ghc-prim.cabal 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.Session +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,28 +1,40 @@ +{-# 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 import GHC.Prelude +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 @@ -37,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`. -- @@ -49,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). -- @@ -90,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 @@ -102,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. -- @@ -111,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 @@ -131,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 @@ -139,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 } @@ -159,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) @@ -186,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, @@ -229,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 @@ -266,16 +333,16 @@ -- ^ 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 } -- | A file upon which the module depends, e.g. a CPP #include, or using TH's -- 'addDependentFile' | UsageFile { - usg_file_path :: FilePath, + usg_file_path :: FastString, -- ^ External file dependency. From a CPP #include or TH -- addDependentFile. Should be absolute. usg_file_hash :: Fingerprint, @@ -324,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 @@ -390,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 @@ -488,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/Env.hs b/GHC/Unit/Module/Env.hs --- a/GHC/Unit/Module/Env.hs +++ b/GHC/Unit/Module/Env.hs @@ -6,6 +6,7 @@ , extendModuleEnvList_C, plusModuleEnv_C , delModuleEnvList, delModuleEnv, plusModuleEnv, lookupModuleEnv , lookupWithDefaultModuleEnv, mapModuleEnv, mkModuleEnv, emptyModuleEnv + , alterModuleEnv , partitionModuleEnv , moduleEnvKeys, moduleEnvElts, moduleEnvToList , unitModuleEnv, isEmptyModuleEnv @@ -146,6 +147,9 @@ partitionModuleEnv f (ModuleEnv e) = (ModuleEnv a, ModuleEnv b) where (a,b) = Map.partition f e + +alterModuleEnv :: (Maybe a -> Maybe a) -> Module -> ModuleEnv a -> ModuleEnv a +alterModuleEnv f m (ModuleEnv e) = ModuleEnv (Map.alter f (NDModule m) e) mkModuleEnv :: [(Module, a)] -> ModuleEnv a mkModuleEnv xs = ModuleEnv (Map.fromList [(NDModule k, v) | (k,v) <- xs]) 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,386 +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 - - , 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.Session - -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 GHC.Unit.Module -import GHC.Linker.Static.Utils - -import Data.Bifunctor -import Data.Either -import Data.Function -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 +-- | 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 @@ -3,583 +3,1274 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE UndecidableInstances #-} - -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_warn_fn :: !(OccName -> Maybe (WarningTxt GhcRn)) - -- ^ Cached lookup for 'mi_warns' - , 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 :: (Warnings GhcRn), - -- ^ 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 GlobalRdrEnv), - -- ^ 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_warn_fn = mkIfaceWarnCache 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 = NoWarnings, - 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_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 f1 f2 f3 f4 f5 f6 f7 f8 f9 f10 f11 f12 - f13 f14 f15 f16 f17 f18 f19 f20 f21 f22 f23 f24) = - rnf f1 `seq` rnf f2 `seq` f3 `seq` f4 `seq` f5 `seq` f6 `seq` rnf f7 `seq` f8 `seq` - f9 `seq` rnf f10 `seq` rnf f11 `seq` rnf f12 `seq` rnf f13 `seq` rnf f14 `seq` rnf f15 `seq` rnf f16 `seq` - rnf f17 `seq` f18 `seq` rnf f19 `seq` rnf f20 `seq` rnf f21 `seq` f22 `seq` f23 `seq` rnf f24 - `seq` () - - -instance NFData (ModIfaceBackend) where - rnf (ModIfaceBackend f1 f2 f3 f4 f5 f6 f7 f8 f9 f10 f11 f12 f13) - = 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` rnf f12 `seq` rnf f13 - - -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 NamedFieldPuns #-} +{-# 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,17 +17,24 @@ , 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.Session +import GHC.Driver.DynFlags import GHC.Unit.Types import GHC.Unit.Module @@ -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,85 +1,268 @@ +{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE TypeFamilies #-} -- | Warnings for a module module GHC.Unit.Module.Warnings - ( Warnings (..) + ( WarningCategory(..) + , mkWarningCategory + , defaultWarningCategory + , validWarningCategory + , InWarningCategory(..) + , fromWarningCategory + + , WarningCategorySet + , emptyWarningCategorySet + , completeWarningCategorySet + , nullWarningCategorySet + , elemWarningCategorySet + , insertWarningCategorySet + , deleteWarningCategorySet + + , Warnings (..) , WarningTxt (..) + , LWarningTxt + , DeclWarnOccNames + , ExportWarnNames + , warningTxtCategory + , warningTxtMessage + , warningTxtSame , pprWarningTxtForMsg - , mkIfaceWarnCache + , emptyWarn + , mkIfaceDeclWarnCache + , mkIfaceExportWarnCache , emptyIfaceWarnCache - , plusWarns + , insertWarnDecls + , insertWarnExports ) where import GHC.Prelude +import GHC.Data.FastString (FastString, mkFastString, unpackFS) import GHC.Types.SourceText import GHC.Types.Name.Occurrence +import GHC.Types.Name.Env +import GHC.Types.Name (Name) import GHC.Types.SrcLoc +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.Extension import Data.Data +import Data.List (isPrefixOf) import GHC.Generics ( Generic ) +import Control.DeepSeq + +{- +Note [Warning categories] +~~~~~~~~~~~~~~~~~~~~~~~~~ +See GHC Proposal 541 for the design of the warning categories feature: +https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0541-warning-pragmas-with-categories.rst + +A WARNING pragma may be annotated with a category such as "x-partial" written +after the 'in' keyword, like this: + + {-# WARNING in "x-partial" head "This function is partial..." #-} + +This is represented by the 'Maybe (Located WarningCategory)' field in +'WarningTxt'. The parser will accept an arbitrary string as the category name, +then the renamer (in 'rnWarningTxt') will check it contains only valid +characters, so we can generate a nicer error message than a parse error. + +The corresponding warnings can then be controlled with the -Wx-partial, +-Wno-x-partial, -Werror=x-partial and -Wwarn=x-partial flags. Such a flag is +distinguished from an 'unrecognisedWarning' by the flag parser testing +'validWarningCategory'. The 'x-' prefix means we can still usually report an +unrecognised warning where the user has made a mistake. + +A DEPRECATED pragma may not have a user-defined category, and is always treated +as belonging to the special category 'deprecations'. Similarly, a WARNING +pragma without a category belongs to the 'deprecations' category. +Thus the '-Wdeprecations' flag will enable all of the following: + + {-# WARNING in "deprecations" foo "This function is deprecated..." #-} + {-# WARNING foo "This function is deprecated..." #-} + {-# DEPRECATED foo "This function is deprecated..." #-} + +The '-Wwarnings-deprecations' flag is supported for backwards compatibility +purposes as being equivalent to '-Wdeprecations'. + +The '-Wextended-warnings' warning group collects together all warnings with +user-defined categories, so they can be enabled or disabled +collectively. Moreover they are treated as being part of other warning groups +such as '-Wdefault' (see 'warningGroupIncludesExtendedWarnings'). + +'DynFlags' and 'DiagOpts' each contain a set of enabled and a set of fatal +warning categories, just as they do for the finite enumeration of 'WarningFlag's +built in to GHC. These are represented as 'WarningCategorySet's to allow for +the possibility of them being infinite. + +-} + +data InWarningCategory + = InWarningCategory + { iwc_in :: !(EpToken "in"), + iwc_st :: !SourceText, + iwc_wc :: (LocatedE WarningCategory) + } deriving Data + +fromWarningCategory :: WarningCategory -> InWarningCategory +fromWarningCategory wc = InWarningCategory noAnn NoSourceText (noLocA wc) + + +-- See Note [Warning categories] +newtype WarningCategory = WarningCategory FastString + deriving stock Data + deriving newtype (Binary, Eq, Outputable, Show, Uniquable, NFData) + +mkWarningCategory :: FastString -> WarningCategory +mkWarningCategory = WarningCategory + +-- | The @deprecations@ category is used for all DEPRECATED pragmas and for +-- WARNING pragmas that do not specify a category. +defaultWarningCategory :: WarningCategory +defaultWarningCategory = mkWarningCategory (mkFastString "deprecations") + +-- | Is this warning category allowed to appear in user-defined WARNING pragmas? +-- It must either be the known category @deprecations@, or be a custom category +-- that begins with @x-@ and contains only valid characters (letters, numbers, +-- apostrophes and dashes). +validWarningCategory :: WarningCategory -> Bool +validWarningCategory cat@(WarningCategory c) = + cat == defaultWarningCategory || ("x-" `isPrefixOf` s && all is_allowed s) + where + s = unpackFS c + is_allowed c = isAlphaNum c || c == '\'' || c == '-' + + +-- | A finite or infinite set of warning categories. +-- +-- Unlike 'WarningFlag', there are (in principle) infinitely many warning +-- categories, so we cannot necessarily enumerate all of them. However the set +-- is constructed by adding or removing categories one at a time, so we can +-- represent it as either a finite set of categories, or a cofinite set (where +-- we store the complement). +data WarningCategorySet = + FiniteWarningCategorySet (UniqSet WarningCategory) + -- ^ The set of warning categories is the given finite set. + | CofiniteWarningCategorySet (UniqSet WarningCategory) + -- ^ The set of warning categories is infinite, so the constructor stores + -- its (finite) complement. + +-- | The empty set of warning categories. +emptyWarningCategorySet :: WarningCategorySet +emptyWarningCategorySet = FiniteWarningCategorySet emptyUniqSet + +-- | The set consisting of all possible warning categories. +completeWarningCategorySet :: WarningCategorySet +completeWarningCategorySet = CofiniteWarningCategorySet emptyUniqSet + +-- | Is this set empty? +nullWarningCategorySet :: WarningCategorySet -> Bool +nullWarningCategorySet (FiniteWarningCategorySet s) = isEmptyUniqSet s +nullWarningCategorySet CofiniteWarningCategorySet{} = False + +-- | Does this warning category belong to the set? +elemWarningCategorySet :: WarningCategory -> WarningCategorySet -> Bool +elemWarningCategorySet c (FiniteWarningCategorySet s) = c `elementOfUniqSet` s +elemWarningCategorySet c (CofiniteWarningCategorySet s) = not (c `elementOfUniqSet` s) + +-- | Insert an element into a warning category set. +insertWarningCategorySet :: WarningCategory -> WarningCategorySet -> WarningCategorySet +insertWarningCategorySet c (FiniteWarningCategorySet s) = FiniteWarningCategorySet (addOneToUniqSet s c) +insertWarningCategorySet c (CofiniteWarningCategorySet s) = CofiniteWarningCategorySet (delOneFromUniqSet s c) + +-- | Delete an element from a warning category set. +deleteWarningCategorySet :: WarningCategory -> WarningCategorySet -> WarningCategorySet +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 - (Located SourceText) - [Located (WithHsDocIdentifiers StringLiteral pass)] + (Maybe (LocatedE InWarningCategory)) + -- ^ Warning category attached to this WARNING pragma, if any; + -- see Note [Warning categories] + SourceText + [LocatedE (WithHsDocIdentifiers StringLiteral pass)] | DeprecatedTxt - (Located SourceText) - [Located (WithHsDocIdentifiers StringLiteral pass)] + SourceText + [LocatedE (WithHsDocIdentifiers StringLiteral pass)] deriving Generic -deriving instance Eq (IdP pass) => Eq (WarningTxt pass) +-- | To which warning category does this WARNING or DEPRECATED pragma belong? +-- See Note [Warning categories]. +warningTxtCategory :: WarningTxt pass -> WarningCategory +warningTxtCategory (WarningTxt (Just (L _ (InWarningCategory _ _ (L _ cat)))) _ _) = cat +warningTxtCategory _ = defaultWarningCategory + +-- | The message that the WarningTxt was specified to output +warningTxtMessage :: WarningTxt p -> [LocatedE (WithHsDocIdentifiers StringLiteral p)] +warningTxtMessage (WarningTxt _ _ m) = m +warningTxtMessage (DeprecatedTxt _ m) = m + +-- | True if the 2 WarningTxts have the same category and messages +warningTxtSame :: WarningTxt p1 -> WarningTxt p2 -> Bool +warningTxtSame w1 w2 + = warningTxtCategory w1 == warningTxtCategory w2 + && literal_message w1 == literal_message w2 + && same_type + where + literal_message :: WarningTxt p -> [StringLiteral] + literal_message = map (hsDocString . unLoc) . warningTxtMessage + same_type | DeprecatedTxt {} <- w1, DeprecatedTxt {} <- w2 = True + | WarningTxt {} <- w1, WarningTxt {} <- w2 = True + | otherwise = False + +deriving instance Eq InWarningCategory + +deriving instance (Eq (IdP pass)) => Eq (WarningTxt pass) deriving instance (Data pass, Data (IdP pass)) => Data (WarningTxt pass) -instance Outputable (WarningTxt pass) where - ppr (WarningTxt lsrc ws) - = case unLoc lsrc of - NoSourceText -> pp_ws ws - SourceText src -> text src <+> pp_ws ws <+> text "#-}" +type instance Anno (WarningTxt (GhcPass pass)) = SrcSpanAnnP - ppr (DeprecatedTxt lsrc ds) - = case unLoc lsrc of - NoSourceText -> pp_ws ds - SourceText src -> text src <+> pp_ws ds <+> text "#-}" +instance Outputable InWarningCategory where + ppr (InWarningCategory _ _ wt) = text "in" <+> doubleQuotes (ppr wt) -instance Binary (WarningTxt GhcRn) where - put_ bh (WarningTxt s w) = do - putByte bh 0 - put_ bh $ unLoc s - put_ bh $ unLoc <$> w - put_ bh (DeprecatedTxt s d) = do - putByte bh 1 - put_ bh $ unLoc s - put_ bh $ unLoc <$> d - get bh = do - h <- getByte bh - case h of - 0 -> do s <- noLoc <$> get bh - w <- fmap noLoc <$> get bh - return (WarningTxt s w) - _ -> do s <- noLoc <$> get bh - d <- fmap noLoc <$> get bh - return (DeprecatedTxt s d) +instance Outputable (WarningTxt pass) where + ppr (WarningTxt mcat lsrc ws) + = case lsrc of + NoSourceText -> pp_ws ws + SourceText src -> ftext src <+> ctg_doc <+> pp_ws ws <+> text "#-}" + where + ctg_doc = maybe empty (\ctg -> ppr ctg) mcat -pp_ws :: [Located (WithHsDocIdentifiers StringLiteral pass)] -> SDoc + ppr (DeprecatedTxt lsrc ds) + = case lsrc of + NoSourceText -> pp_ws ds + SourceText src -> ftext src <+> pp_ws ds <+> text "#-}" + +pp_ws :: [LocatedE (WithHsDocIdentifiers StringLiteral pass)] -> SDoc pp_ws [l] = ppr $ unLoc l pp_ws ws = text "[" @@ -88,20 +271,20 @@ pprWarningTxtForMsg :: WarningTxt p -> SDoc -pprWarningTxtForMsg (WarningTxt _ ws) +pprWarningTxtForMsg (WarningTxt _ _ ws) = doubleQuotes (vcat (map (ftext . sl_fs . hsDocString . unLoc) ws)) pprWarningTxtForMsg (DeprecatedTxt _ ds) = text "Deprecated:" <+> doubleQuotes (vcat (map (ftext . sl_fs . hsDocString . unLoc) ds)) --- | Warning information for a module +-- | Warning information from a module data Warnings pass - = NoWarnings -- ^ Nothing deprecated - | WarnAll (WarningTxt pass) -- ^ Whole module deprecated - | WarnSome [(OccName,WarningTxt pass)] -- ^ Some specific things deprecated + = WarnSome (DeclWarnOccNames pass) -- ^ Names deprecated (may be empty) + (ExportWarnNames pass) -- ^ Exports deprecated (may be empty) + | WarnAll (WarningTxt pass) -- ^ Whole module deprecated - -- Only an OccName is needed because + -- For the module-specific names only an OccName is needed because -- (1) a deprecation always applies to a binding -- defined in the module in which the deprecation appears. -- (2) deprecations are only reported outside the defining module. @@ -121,40 +304,44 @@ -- -- this is in contrast with fixity declarations, where we need to map -- a Name to its fixity declaration. + -- + -- For export deprecations we need to know where the symbol comes from, since + -- we need to be able to check if the deprecated export that was imported is + -- the same thing as imported by another import, which would not trigger + -- a deprecation message. +-- | Deprecated declarations +type DeclWarnOccNames pass = [(OccName, WarningTxt pass)] + +-- | Names that are deprecated as exports +type ExportWarnNames pass = [(Name, WarningTxt pass)] + deriving instance Eq (IdP pass) => Eq (Warnings pass) -instance Binary (Warnings GhcRn) where - put_ bh NoWarnings = putByte bh 0 - put_ bh (WarnAll t) = do - putByte bh 1 - put_ bh t - put_ bh (WarnSome ts) = do - putByte bh 2 - put_ bh ts +emptyWarn :: Warnings p +emptyWarn = WarnSome [] [] - get bh = do - h <- getByte bh - case h of - 0 -> return NoWarnings - 1 -> do aa <- get bh - return (WarnAll aa) - _ -> do aa <- get bh - return (WarnSome aa) +-- | Constructs the cache for the 'mi_decl_warn_fn' field of a 'ModIface' +mkIfaceDeclWarnCache :: Warnings p -> OccName -> Maybe (WarningTxt p) +mkIfaceDeclWarnCache (WarnAll t) = \_ -> Just t +mkIfaceDeclWarnCache (WarnSome vs _) = lookupOccEnv (mkOccEnv vs) --- | Constructs the cache for the 'mi_warn_fn' field of a 'ModIface' -mkIfaceWarnCache :: Warnings p -> OccName -> Maybe (WarningTxt p) -mkIfaceWarnCache NoWarnings = \_ -> Nothing -mkIfaceWarnCache (WarnAll t) = \_ -> Just t -mkIfaceWarnCache (WarnSome pairs) = lookupOccEnv (mkOccEnv pairs) +-- | Constructs the cache for the 'mi_export_warn_fn' field of a 'ModIface' +mkIfaceExportWarnCache :: Warnings p -> Name -> Maybe (WarningTxt p) +mkIfaceExportWarnCache (WarnAll _) = const Nothing -- We do not want a double report of the module deprecation +mkIfaceExportWarnCache (WarnSome _ ds) = lookupNameEnv (mkNameEnv ds) -emptyIfaceWarnCache :: OccName -> Maybe (WarningTxt p) +emptyIfaceWarnCache :: name -> Maybe (WarningTxt p) emptyIfaceWarnCache _ = Nothing -plusWarns :: Warnings p -> Warnings p -> Warnings p -plusWarns d NoWarnings = d -plusWarns NoWarnings d = d -plusWarns _ (WarnAll t) = WarnAll t -plusWarns (WarnAll t) _ = WarnAll t -plusWarns (WarnSome v1) (WarnSome v2) = WarnSome (v1 ++ v2) +insertWarnDecls :: Warnings p -- ^ Existing warnings + -> [(OccName, WarningTxt p)] -- ^ New declaration deprecations + -> Warnings p -- ^ Updated warnings +insertWarnDecls ws@(WarnAll _) _ = ws +insertWarnDecls (WarnSome wns wes) wns' = WarnSome (wns ++ wns') wes +insertWarnExports :: Warnings p -- ^ Existing warnings + -> [(Name, WarningTxt p)] -- ^ New export deprecations + -> Warnings p -- ^ Updated warnings +insertWarnExports ws@(WarnAll _) _ = ws +insertWarnExports (WarnSome wns wes) wes' = WarnSome wns (wes ++ wes') 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,15 +66,15 @@ pprUnitInfoForUser, pprModuleMap, pprWithUnitState, + pprRawUnitIds, -- * Utils - unwireUnit, - implicitPackageDeps) + unwireUnit) where import GHC.Prelude -import GHC.Driver.Session +import GHC.Driver.DynFlags import GHC.Platform import GHC.Platform.Ways @@ -92,6 +90,8 @@ import GHC.Types.Unique.DFM import GHC.Types.Unique.Set import GHC.Types.Unique.DSet +import GHC.Types.Unique.Map +import GHC.Types.Unique import GHC.Types.PkgQual import GHC.Utils.Misc @@ -111,15 +111,11 @@ import Control.Monad import Data.Graph (stronglyConnComp, SCC(..)) import Data.Char ( toUpper ) -import Data.List ( intersperse, partition, sortBy, isSuffixOf ) -import Data.Map (Map) +import Data.List ( intersperse, partition, sortBy, isSuffixOf, sortOn ) import Data.Set (Set) import Data.Monoid (First(..)) import qualified Data.Semigroup as Semigroup -import qualified Data.Map as Map -import qualified Data.Map.Strict as MapStrict import qualified Data.Set as Set -import GHC.LanguageExtensions import Control.Applicative -- --------------------------------------------------------------------------- @@ -271,7 +267,7 @@ type PreloadUnitClosure = UniqSet UnitId -- | 'UniqFM' map from 'Unit' to a 'UnitVisibility'. -type VisibilityMap = Map Unit UnitVisibility +type VisibilityMap = UniqMap Unit UnitVisibility -- | 'UnitVisibility' records the various aspects of visibility of a particular -- 'Unit'. @@ -285,7 +281,7 @@ -- ^ The package name associated with the 'Unit'. This is used -- to implement legacy behavior where @-package foo-0.1@ implicitly -- hides any packages named @foo@ - , uv_requirements :: Map ModuleName (Set InstantiatedModule) + , uv_requirements :: UniqMap ModuleName (Set InstantiatedModule) -- ^ The signatures which are contributed to the requirements context -- from this unit ID. , uv_explicit :: Maybe PackageArg @@ -309,7 +305,7 @@ { uv_expose_all = uv_expose_all uv1 || uv_expose_all uv2 , uv_renamings = uv_renamings uv1 ++ uv_renamings uv2 , uv_package_name = mappend (uv_package_name uv1) (uv_package_name uv2) - , uv_requirements = Map.unionWith Set.union (uv_requirements uv1) (uv_requirements uv2) + , uv_requirements = plusUniqMap_C Set.union (uv_requirements uv2) (uv_requirements uv1) , uv_explicit = uv_explicit uv1 <|> uv_explicit uv2 } @@ -318,7 +314,7 @@ { uv_expose_all = False , uv_renamings = [] , uv_package_name = First Nothing - , uv_requirements = Map.empty + , uv_requirements = emptyUniqMap , uv_explicit = Nothing } mappend = (Semigroup.<>) @@ -369,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 @@ -418,7 +418,7 @@ -- origin for a given 'Module' type ModuleNameProvidersMap = - Map ModuleName (Map Module ModuleOrigin) + UniqMap ModuleName (UniqMap Module ModuleOrigin) data UnitState = UnitState { -- | A mapping of 'Unit' to 'UnitInfo'. This list is adjusted @@ -442,10 +442,10 @@ packageNameMap :: UniqFM PackageName UnitId, -- | A mapping from database unit keys to wired in unit ids. - wireMap :: Map UnitId UnitId, + wireMap :: UniqMap UnitId UnitId, -- | A mapping from wired in unit ids to unit keys from the database. - unwireMap :: Map UnitId UnitId, + unwireMap :: UniqMap UnitId UnitId, -- | The units we're going to link in eagerly. This list -- should be in reverse dependency order; that is, a unit @@ -475,7 +475,7 @@ -- and @r[C=\]:C@. -- -- There's an entry in this map for each hole in our home library. - requirementContext :: Map ModuleName [InstantiatedModule], + requirementContext :: UniqMap ModuleName [InstantiatedModule], -- | Indicate if we can instantiate units on-the-fly. -- @@ -486,17 +486,17 @@ emptyUnitState :: UnitState emptyUnitState = UnitState { - unitInfoMap = Map.empty, + unitInfoMap = emptyUniqMap, preloadClosure = emptyUniqSet, packageNameMap = emptyUFM, - wireMap = Map.empty, - unwireMap = Map.empty, - preloadUnits = [], - explicitUnits = [], + wireMap = emptyUniqMap, + unwireMap = emptyUniqMap, + preloadUnits = [], + explicitUnits = [], homeUnitDepends = [], - moduleNameProvidersMap = Map.empty, - pluginModuleNameProvidersMap = Map.empty, - requirementContext = Map.empty, + moduleNameProvidersMap = emptyUniqMap, + pluginModuleNameProvidersMap = emptyUniqMap, + requirementContext = emptyUniqMap, allowVirtualUnits = False } @@ -509,7 +509,7 @@ instance Outputable u => Outputable (UnitDatabase u) where ppr (UnitDatabase fp _u) = text "DB:" <+> text fp -type UnitInfoMap = Map UnitId UnitInfo +type UnitInfoMap = UniqMap UnitId UnitInfo -- | Find the unit we know about with the given unit, if any lookupUnit :: UnitState -> Unit -> Maybe UnitInfo @@ -525,20 +525,20 @@ lookupUnit' :: Bool -> UnitInfoMap -> PreloadUnitClosure -> Unit -> Maybe UnitInfo lookupUnit' allowOnTheFlyInst pkg_map closure u = case u of HoleUnit -> error "Hole unit" - RealUnit i -> Map.lookup (unDefinite i) pkg_map + RealUnit i -> lookupUniqMap pkg_map (unDefinite i) VirtUnit i | allowOnTheFlyInst -> -- lookup UnitInfo of the indefinite unit to be instantiated and -- instantiate it on-the-fly fmap (renameUnitInfo pkg_map closure (instUnitInsts i)) - (Map.lookup (instUnitInstanceOf i) pkg_map) + (lookupUniqMap pkg_map (instUnitInstanceOf i)) | otherwise -> -- lookup UnitInfo by virtual UnitId. This is used to find indefinite -- units. Even if they are real, installed units, they can't use the -- `RealUnit` constructor (it is reserved for definite units) so we use -- the `VirtUnit` constructor. - Map.lookup (virtualUnitId i) pkg_map + lookupUniqMap pkg_map (virtualUnitId i) -- | Find the unit we know about with the given unit id, if any lookupUnitId :: UnitState -> UnitId -> Maybe UnitInfo @@ -546,7 +546,7 @@ -- | Find the unit we know about with the given unit id, if any lookupUnitId' :: UnitInfoMap -> UnitId -> Maybe UnitInfo -lookupUnitId' db uid = Map.lookup uid db +lookupUnitId' db uid = lookupUniqMap db uid -- | Looks up the given unit in the unit state, panicking if it is not found @@ -580,12 +580,12 @@ resolvePackageImport :: UnitState -> ModuleName -> PackageName -> Maybe UnitId resolvePackageImport unit_st mn pn = do -- 1. Find all modules providing the ModuleName (this accounts for visibility/thinning etc) - providers <- Map.filter originVisible <$> Map.lookup mn (moduleNameProvidersMap unit_st) + providers <- filterUniqMap originVisible <$> lookupUniqMap (moduleNameProvidersMap unit_st) mn -- 2. Get the UnitIds of the candidates - let candidates_uid = concatMap to_uid $ Map.assocs providers + let candidates_uid = concatMap to_uid $ sortOn fst $ nonDetUniqMapToList providers -- 3. Get the package names of the candidates let candidates_units = map (\ui -> ((unitPackageName ui), unitId ui)) - $ mapMaybe (\uid -> Map.lookup uid (unitInfoMap unit_st)) candidates_uid + $ mapMaybe (\uid -> lookupUniqMap (unitInfoMap unit_st) uid) candidates_uid -- 4. Check to see if the PackageName helps us disambiguate any candidates. lookup pn candidates_units @@ -611,23 +611,22 @@ -- with module holes). -- mkUnitInfoMap :: [UnitInfo] -> UnitInfoMap -mkUnitInfoMap infos = foldl' add Map.empty infos +mkUnitInfoMap infos = foldl' add emptyUniqMap infos where mkVirt p = virtualUnitId (mkInstantiatedUnit (unitInstanceOf p) (unitInstantiations p)) add pkg_map p | not (null (unitInstantiations p)) - = Map.insert (mkVirt p) p - $ Map.insert (unitId p) p - $ pkg_map + = addToUniqMap (addToUniqMap pkg_map (mkVirt p) p) + (unitId p) p | otherwise - = Map.insert (unitId p) p pkg_map + = addToUniqMap pkg_map (unitId p) p -- | Get a list of entries from the unit database. NB: be careful with -- this function, although all units in this map are "visible", this -- does not imply that the exposed-modules of the unit are available -- (they may have been thinned or renamed). listUnitInfo :: UnitState -> [UnitInfo] -listUnitInfo state = Map.elems (unitInfoMap state) +listUnitInfo state = nonDetEltsUniqMap (unitInfoMap state) -- ---------------------------------------------------------------------------- -- Loading the unit db files and building up the unit state @@ -915,20 +914,20 @@ -- This method is responsible for computing what our -- inherited requirements are. reqs | UnitIdArg orig_uid <- arg = collectHoles orig_uid - | otherwise = Map.empty + | otherwise = emptyUniqMap collectHoles uid = case uid of - HoleUnit -> Map.empty - RealUnit {} -> Map.empty -- definite units don't have holes + HoleUnit -> emptyUniqMap + RealUnit {} -> emptyUniqMap -- definite units don't have holes VirtUnit indef -> - let local = [ Map.singleton + let local = [ unitUniqMap (moduleName mod) (Set.singleton $ Module indef mod_name) | (mod_name, mod) <- instUnitInsts indef , isHoleModule mod ] recurse = [ collectHoles (moduleUnit mod) | (_, mod) <- instUnitInsts indef ] - in Map.unionsWith Set.union $ local ++ recurse + in plusUniqMapListWith Set.union $ local ++ recurse uv = UnitVisibility { uv_expose_all = b @@ -937,7 +936,7 @@ , uv_requirements = reqs , uv_explicit = Just arg } - vm' = Map.insertWith mappend (mkUnit p) uv vm_cleared + vm' = addToUniqMap_C mappend vm_cleared (mkUnit p) uv -- In the old days, if you said `ghc -package p-0.1 -package p-0.2` -- (or if p-0.1 was registered in the pkgdb as exposed: True), -- the second package flag would override the first one and you @@ -961,7 +960,7 @@ vm_cleared | no_hide_others = vm -- NB: renamings never clear | (_:_) <- rns = vm - | otherwise = Map.filterWithKey + | otherwise = filterWithKeyUniqMap (\k uv -> k == mkUnit p || First (Just n) /= uv_package_name uv) vm _ -> panic "applyPackageFlag" @@ -969,7 +968,7 @@ HidePackage str -> case findPackages prec_map pkg_map closure (PackageArg str) pkgs unusable of Left ps -> Failed (PackageFlagErr flag ps) - Right ps -> Succeeded $ foldl' (flip Map.delete) vm (map mkUnit ps) + Right ps -> Succeeded $ foldl' delFromUniqMap vm (map mkUnit ps) -- | Like 'selectPackages', but doesn't return a list of unmatched -- packages. Furthermore, any packages it returns are *renamed* @@ -985,7 +984,7 @@ = let ps = mapMaybe (finder arg) pkgs in if null ps then Left (mapMaybe (\(x,y) -> finder arg x >>= \x' -> return (x',y)) - (Map.elems unusable)) + (nonDetEltsUniqMap unusable)) else Right (sortByPreference prec_map ps) where finder (PackageArg str) p @@ -1010,7 +1009,7 @@ = let matches = matching arg (ps,rest) = partition matches pkgs in if null ps - then Left (filter (matches.fst) (Map.elems unusable)) + then Left (filter (matches.fst) (nonDetEltsUniqMap unusable)) else Right (sortByPreference prec_map ps, rest) -- | Rename a 'UnitInfo' according to some module instantiation. @@ -1064,8 +1063,8 @@ compareByPreference prec_map pkg pkg' = case comparing unitPackageVersion pkg pkg' of GT -> GT - EQ | Just prec <- Map.lookup (unitId pkg) prec_map - , Just prec' <- Map.lookup (unitId pkg') prec_map + EQ | Just prec <- lookupUniqMap prec_map (unitId pkg) + , Just prec' <- lookupUniqMap prec_map (unitId pkg') -- Prefer the unit from the later DB flag (i.e., higher -- precedence) -> compare prec prec' @@ -1089,9 +1088,9 @@ -- ----------------------------------------------------------------------------- -- Wired-in units -- --- See Note [Wired-in units] in GHC.Unit.Module +-- See Note [Wired-in units] in GHC.Unit.Types -type WiringMap = Map UnitId UnitId +type WiringMap = UniqMap UnitId UnitId findWiredInUnits :: Logger @@ -1105,7 +1104,7 @@ findWiredInUnits logger prec_map pkgs vis_map = do -- Now we must find our wired-in units, and rename them to -- their canonical names (eg. base-1.0 ==> base), as described - -- in Note [Wired-in units] in GHC.Unit.Module + -- in Note [Wired-in units] in GHC.Unit.Types let matches :: UnitInfo -> UnitId -> Bool pc `matches` pid = unitPackageName pc == PackageName (unitIdFS pid) @@ -1131,7 +1130,7 @@ findWiredInUnit pkgs wired_pkg = firstJustsM [try all_exposed_ps, try all_ps, notfound] where all_ps = [ p | p <- pkgs, p `matches` wired_pkg ] - all_exposed_ps = [ p | p <- all_ps, Map.member (mkUnit p) vis_map ] + all_exposed_ps = [ p | p <- all_ps, (mkUnit p) `elemUniqMap` vis_map ] try ps = case sortByPreference prec_map ps of p:_ -> Just <$> pick p @@ -1157,8 +1156,8 @@ let wired_in_pkgs = catMaybes mb_wired_in_pkgs - wiredInMap :: Map UnitId UnitId - wiredInMap = Map.fromList + wiredInMap :: UniqMap UnitId UnitId + wiredInMap = listToUniqMap [ (unitId realUnitInfo, wiredInUnitId) | (wiredInUnitId, realUnitInfo) <- wired_in_pkgs , not (unitIsIndefinite realUnitInfo) @@ -1166,7 +1165,7 @@ updateWiredInDependencies pkgs = map (upd_deps . upd_pkg) pkgs where upd_pkg pkg - | Just wiredInUnitId <- Map.lookup (unitId pkg) wiredInMap + | Just wiredInUnitId <- lookupUniqMap wiredInMap (unitId pkg) = pkg { unitId = wiredInUnitId , unitInstanceOf = wiredInUnitId -- every non instantiated unit is an instance of @@ -1188,7 +1187,7 @@ -- Helper functions for rewiring Module and Unit. These -- rewrite Units of modules in wired-in packages to the form known to the --- compiler, as described in Note [Wired-in units] in GHC.Unit.Module. +-- compiler, as described in Note [Wired-in units] in GHC.Unit.Types. -- -- For instance, base-4.9.0.0 will be rewritten to just base, to match -- what appears in GHC.Builtin.Names. @@ -1207,18 +1206,17 @@ upd_wired_in :: WiringMap -> UnitId -> UnitId upd_wired_in wiredInMap key - | Just key' <- Map.lookup key wiredInMap = key' + | Just key' <- lookupUniqMap wiredInMap key = key' | otherwise = key updateVisibilityMap :: WiringMap -> VisibilityMap -> VisibilityMap -updateVisibilityMap wiredInMap vis_map = foldl' f vis_map (Map.toList wiredInMap) - where f vm (from, to) = case Map.lookup (RealUnit (Definite from)) vis_map of +updateVisibilityMap wiredInMap vis_map = foldl' f vis_map (nonDetUniqMapToList wiredInMap) + where f vm (from, to) = case lookupUniqMap vis_map (RealUnit (Definite from)) of Nothing -> vm - Just r -> Map.insert (RealUnit (Definite to)) r - (Map.delete (RealUnit (Definite from)) vm) - + Just r -> addToUniqMap (delFromUniqMap vm (RealUnit (Definite from))) + (RealUnit (Definite to)) r --- ---------------------------------------------------------------------------- + -- ---------------------------------------------------------------------------- -- | The reason why a unit is unusable. data UnusableUnitReason @@ -1245,7 +1243,7 @@ ppr (IgnoredDependencies uids) = brackets (text "ignored" <+> ppr uids) ppr (ShadowedDependencies uids) = brackets (text "shadowed" <+> ppr uids) -type UnusableUnits = Map UnitId (UnitInfo, UnusableUnitReason) +type UnusableUnits = UniqMap UnitId (UnitInfo, UnusableUnitReason) pprReason :: SDoc -> UnusableUnitReason -> SDoc pprReason pref reason = case reason of @@ -1275,7 +1273,7 @@ nest 2 (hsep (map (ppr . unitId) vs)) reportUnusable :: Logger -> UnusableUnits -> IO () -reportUnusable logger pkgs = mapM_ report (Map.toList pkgs) +reportUnusable logger pkgs = mapM_ report (nonDetUniqMapToList pkgs) where report (ipid, (_, reason)) = debugTraceMsg logger 2 $ @@ -1289,14 +1287,15 @@ -- | A reverse dependency index, mapping an 'UnitId' to -- the 'UnitId's which have a dependency on it. -type RevIndex = Map UnitId [UnitId] +type RevIndex = UniqMap UnitId [UnitId] -- | Compute the reverse dependency index of a unit database. reverseDeps :: UnitInfoMap -> RevIndex -reverseDeps db = Map.foldl' go Map.empty db +reverseDeps db = nonDetFoldUniqMap go emptyUniqMap db where - go r pkg = foldl' (go' (unitId pkg)) r (unitDepends pkg) - go' from r to = Map.insertWith (++) to [from] r + go :: (UnitId, UnitInfo) -> RevIndex -> RevIndex + go (_uid, pkg) r = foldl' (go' (unitId pkg)) r (unitDepends pkg) + go' from r to = addToUniqMap_C (++) r to [from] -- | Given a list of 'UnitId's to remove, a database, -- and a reverse dependency index (as computed by 'reverseDeps'), @@ -1310,10 +1309,10 @@ where go [] (m,pkgs) = (m,pkgs) go (uid:uids) (m,pkgs) - | Just pkg <- Map.lookup uid m - = case Map.lookup uid index of - Nothing -> go uids (Map.delete uid m, pkg:pkgs) - Just rdeps -> go (rdeps ++ uids) (Map.delete uid m, pkg:pkgs) + | Just pkg <- lookupUniqMap m uid + = case lookupUniqMap index uid of + Nothing -> go uids (delFromUniqMap m uid, pkg:pkgs) + Just rdeps -> go (rdeps ++ uids) (delFromUniqMap m uid, pkg:pkgs) | otherwise = go uids (m,pkgs) @@ -1322,7 +1321,7 @@ depsNotAvailable :: UnitInfoMap -> UnitInfo -> [UnitId] -depsNotAvailable pkg_map pkg = filter (not . (`Map.member` pkg_map)) (unitDepends pkg) +depsNotAvailable pkg_map pkg = filter (not . (`elemUniqMap` pkg_map)) (unitDepends pkg) -- | Given a 'UnitInfo' from some 'UnitInfoMap' return all entries in -- 'unitAbiDepends' which correspond to units that do not exist, OR have @@ -1333,7 +1332,7 @@ depsAbiMismatch pkg_map pkg = map fst . filter (not . abiMatch) $ unitAbiDepends pkg where abiMatch (dep_uid, abi) - | Just dep_pkg <- Map.lookup dep_uid pkg_map + | Just dep_pkg <- lookupUniqMap pkg_map dep_uid = unitAbiHash dep_pkg == abi | otherwise = False @@ -1342,7 +1341,7 @@ -- Ignore units ignoreUnits :: [IgnorePackageFlag] -> [UnitInfo] -> UnusableUnits -ignoreUnits flags pkgs = Map.fromList (concatMap doit flags) +ignoreUnits flags pkgs = listToUniqMap (concatMap doit flags) where doit (IgnorePackage str) = case partition (matchingStr str) pkgs of @@ -1362,7 +1361,7 @@ -- the command line. We use this mapping to make sure we prefer -- units that were defined later on the command line, if there -- is an ambiguity. -type UnitPrecedenceMap = Map UnitId Int +type UnitPrecedenceMap = UniqMap UnitId Int -- | Given a list of databases, merge them together, where -- units with the same unit id in later databases override @@ -1370,7 +1369,7 @@ -- makes sense (that's done by 'validateDatabase'). mergeDatabases :: Logger -> [UnitDatabase UnitId] -> IO (UnitInfoMap, UnitPrecedenceMap) -mergeDatabases logger = foldM merge (Map.empty, Map.empty) . zip [1..] +mergeDatabases logger = foldM merge (emptyUniqMap, emptyUniqMap) . zip [1..] where merge (pkg_map, prec_map) (i, UnitDatabase db_path db) = do debugTraceMsg logger 2 $ @@ -1382,22 +1381,22 @@ return (pkg_map', prec_map') where db_map = mk_pkg_map db - mk_pkg_map = Map.fromList . map (\p -> (unitId p, p)) + mk_pkg_map = listToUniqMap . map (\p -> (unitId p, p)) -- The set of UnitIds which appear in both db and pkgs. These are the -- ones that get overridden. Compute this just to give some -- helpful debug messages at -v2 override_set :: Set UnitId - override_set = Set.intersection (Map.keysSet db_map) - (Map.keysSet pkg_map) + override_set = Set.intersection (nonDetUniqMapToKeySet db_map) + (nonDetUniqMapToKeySet pkg_map) -- Now merge the sets together (NB: in case of duplicate, -- first argument preferred) pkg_map' :: UnitInfoMap - pkg_map' = Map.union db_map pkg_map + pkg_map' = pkg_map `plusUniqMap` db_map prec_map' :: UnitPrecedenceMap - prec_map' = Map.union (Map.map (const i) db_map) prec_map + prec_map' = prec_map `plusUniqMap` (mapUniqMap (const i) db_map) -- | Validates a database, removing unusable units from it -- (this includes removing units that the user has explicitly @@ -1420,39 +1419,45 @@ -- Helper function mk_unusable mk_err dep_matcher m uids = - Map.fromList [ (unitId pkg, (pkg, mk_err (dep_matcher m pkg))) - | pkg <- uids ] + listToUniqMap [ (unitId pkg, (pkg, mk_err (dep_matcher m pkg))) + | pkg <- uids + ] -- Find broken units directly_broken = filter (not . null . depsNotAvailable pkg_map1) - (Map.elems pkg_map1) + (nonDetEltsUniqMap pkg_map1) (pkg_map2, broken) = removeUnits (map unitId directly_broken) index pkg_map1 unusable_broken = mk_unusable BrokenDependencies depsNotAvailable pkg_map2 broken -- Find recursive units sccs = stronglyConnComp [ (pkg, unitId pkg, unitDepends pkg) - | pkg <- Map.elems pkg_map2 ] + | pkg <- nonDetEltsUniqMap pkg_map2 ] getCyclicSCC (CyclicSCC vs) = map unitId vs getCyclicSCC (AcyclicSCC _) = [] (pkg_map3, cyclic) = removeUnits (concatMap getCyclicSCC sccs) index pkg_map2 unusable_cyclic = mk_unusable CyclicDependencies depsNotAvailable pkg_map3 cyclic -- Apply ignore flags - directly_ignored = ignoreUnits ignore_flags (Map.elems pkg_map3) - (pkg_map4, ignored) = removeUnits (Map.keys directly_ignored) index pkg_map3 + directly_ignored = ignoreUnits ignore_flags (nonDetEltsUniqMap pkg_map3) + (pkg_map4, ignored) = removeUnits (nonDetKeysUniqMap directly_ignored) index pkg_map3 unusable_ignored = mk_unusable IgnoredDependencies depsNotAvailable pkg_map4 ignored -- Knock out units whose dependencies don't agree with ABI -- (i.e., got invalidated due to shadowing) directly_shadowed = filter (not . null . depsAbiMismatch pkg_map4) - (Map.elems pkg_map4) + (nonDetEltsUniqMap pkg_map4) (pkg_map5, shadowed) = removeUnits (map unitId directly_shadowed) index pkg_map4 unusable_shadowed = mk_unusable ShadowedDependencies depsAbiMismatch pkg_map5 shadowed - unusable = directly_ignored `Map.union` unusable_ignored - `Map.union` unusable_broken - `Map.union` unusable_cyclic - `Map.union` unusable_shadowed + -- combine all unusables. The order is important for shadowing. + -- plusUniqMapList folds using plusUFM which is right biased (opposite of + -- Data.Map.union) so the head of the list should be the least preferred + unusable = plusUniqMapList [ unusable_shadowed + , unusable_cyclic + , unusable_broken + , unusable_ignored + , directly_ignored + ] -- ----------------------------------------------------------------------------- -- When all the command-line options are in, we can process our unit @@ -1551,7 +1556,7 @@ -- or not packages are visible or not) pkgs1 <- mayThrowUnitErr $ foldM (applyTrustFlag prec_map unusable) - (Map.elems pkg_map2) (reverse (unitConfigFlagsTrusted cfg)) + (nonDetEltsUniqMap pkg_map2) (reverse (unitConfigFlagsTrusted cfg)) let prelim_pkg_db = mkUnitInfoMap pkgs1 -- @@ -1591,17 +1596,16 @@ -- default, because it's almost assuredly not -- what you want (no mix-in linking has occurred). if unitIsExposed p && unitIsDefinite (mkUnit p) && mostPreferable p - then Map.insert (mkUnit p) + then addToUniqMap vm (mkUnit p) UnitVisibility { uv_expose_all = True, uv_renamings = [], uv_package_name = First (Just (fsPackageName p)), - uv_requirements = Map.empty, + uv_requirements = emptyUniqMap, uv_explicit = Nothing } - vm else vm) - Map.empty pkgs1 + emptyUniqMap pkgs1 -- -- Compute a visibility map according to the command-line flags (-package, @@ -1629,9 +1633,9 @@ case unitConfigFlagsPlugins cfg of -- common case; try to share the old vis_map [] | not hide_plugin_pkgs -> return vis_map - | otherwise -> return Map.empty + | otherwise -> return emptyUniqMap _ -> do let plugin_vis_map1 - | hide_plugin_pkgs = Map.empty + | hide_plugin_pkgs = emptyUniqMap -- Use the vis_map PRIOR to wired in, -- because otherwise applyPackageFlag -- won't work. @@ -1660,9 +1664,9 @@ -- The requirement context is directly based off of this: we simply -- look for nested unit IDs that are directly fed holes: the requirements -- of those units are precisely the ones we need to track - let explicit_pkgs = [(k, uv_explicit v) | (k, v) <- Map.toList vis_map] - req_ctx = Map.map (Set.toList) - $ Map.unionsWith Set.union (map uv_requirements (Map.elems vis_map)) + let explicit_pkgs = [(k, uv_explicit v) | (k, v) <- nonDetUniqMapToList vis_map] + req_ctx = mapUniqMap (Set.toList) + $ plusUniqMapListWith Set.union (map uv_requirements (nonDetEltsUniqMap vis_map)) -- @@ -1675,11 +1679,11 @@ -- NB: preload IS important even for type-checking, because we -- need the correct include path to be set. -- - let preload1 = Map.keys (Map.filter (isJust . uv_explicit) vis_map) + let preload1 = nonDetKeysUniqMap (filterUniqMap (isJust . uv_explicit) vis_map) -- add default preload units if they can be found in the db basicLinkedUnits = fmap (RealUnit . Definite) - $ filter (flip Map.member pkg_db) + $ filter (flip elemUniqMap pkg_db) $ unitConfigAutoLink cfg preload3 = ordNub $ (basicLinkedUnits ++ preload1) @@ -1690,7 +1694,7 @@ let mod_map1 = mkModuleNameProvidersMap logger cfg pkg_db emptyUniqSet vis_map mod_map2 = mkUnusableModuleNameProvidersMap unusable - mod_map = Map.union mod_map1 mod_map2 + mod_map = mod_map2 `plusUniqMap` mod_map1 -- Force the result to avoid leaking input parameters let !state = UnitState @@ -1703,7 +1707,7 @@ , pluginModuleNameProvidersMap = mkModuleNameProvidersMap logger cfg pkg_db emptyUniqSet plugin_vis_map , packageNameMap = pkgname_map , wireMap = wired_map - , unwireMap = Map.fromList [ (v,k) | (k,v) <- Map.toList wired_map ] + , unwireMap = listToUniqMap [ (v,k) | (k,v) <- nonDetUniqMapToList wired_map ] , requirementContext = req_ctx , allowVirtualUnits = unitConfigAllowVirtual cfg } @@ -1726,7 +1730,7 @@ -- that it was recorded as in the package database. unwireUnit :: UnitState -> Unit -> Unit unwireUnit state uid@(RealUnit (Definite def_uid)) = - maybe uid (RealUnit . Definite) (Map.lookup def_uid (unwireMap state)) + maybe uid (RealUnit . Definite) (lookupUniqMap (unwireMap state) def_uid) unwireUnit _ uid = uid -- ----------------------------------------------------------------------------- @@ -1761,36 +1765,35 @@ -- entries for every definite (for non-Backpack) and -- indefinite (for Backpack) package, so that we get the -- hidden entries we need. - Map.foldlWithKey extend_modmap emptyMap vis_map_extended + nonDetFoldUniqMap extend_modmap emptyMap vis_map_extended where - vis_map_extended = Map.union vis_map {- preferred -} default_vis + vis_map_extended = {- preferred -} default_vis `plusUniqMap` vis_map - default_vis = Map.fromList + default_vis = listToUniqMap [ (mkUnit pkg, mempty) - | pkg <- Map.elems pkg_map + | (_, pkg) <- nonDetUniqMapToList pkg_map -- Exclude specific instantiations of an indefinite -- package , unitIsIndefinite pkg || null (unitInstantiations pkg) ] - emptyMap = Map.empty + emptyMap = emptyUniqMap setOrigins m os = fmap (const os) m - extend_modmap modmap uid - UnitVisibility { uv_expose_all = b, uv_renamings = rns } + extend_modmap (uid, UnitVisibility { uv_expose_all = b, uv_renamings = rns }) modmap = addListTo modmap theBindings where pkg = unit_lookup uid - theBindings :: [(ModuleName, Map Module ModuleOrigin)] + theBindings :: [(ModuleName, UniqMap Module ModuleOrigin)] theBindings = newBindings b rns newBindings :: Bool -> [(ModuleName, ModuleName)] - -> [(ModuleName, Map Module ModuleOrigin)] + -> [(ModuleName, UniqMap Module ModuleOrigin)] newBindings e rns = es e ++ hiddens ++ map rnBinding rns rnBinding :: (ModuleName, ModuleName) - -> (ModuleName, Map Module ModuleOrigin) + -> (ModuleName, UniqMap Module ModuleOrigin) rnBinding (orig, new) = (new, setOrigins origEntry fromFlag) where origEntry = case lookupUFM esmap orig of Just r -> r @@ -1799,7 +1802,7 @@ (text "package flag: could not find module name" <+> ppr orig <+> text "in package" <+> ppr pk))) - es :: Bool -> [(ModuleName, Map Module ModuleOrigin)] + es :: Bool -> [(ModuleName, UniqMap Module ModuleOrigin)] es e = do (m, exposedReexport) <- exposed_mods let (pk', m', origin') = @@ -1809,7 +1812,7 @@ (pk', m', fromReexportedModules e pkg) return (m, mkModMap pk' m' origin') - esmap :: UniqFM ModuleName (Map Module ModuleOrigin) + esmap :: UniqFM ModuleName (UniqMap Module ModuleOrigin) esmap = listToUFM (es False) -- parameter here doesn't matter, orig will -- be overwritten @@ -1825,10 +1828,10 @@ -- | Make a 'ModuleNameProvidersMap' covering a set of unusable packages. mkUnusableModuleNameProvidersMap :: UnusableUnits -> ModuleNameProvidersMap mkUnusableModuleNameProvidersMap unusables = - Map.foldl' extend_modmap Map.empty unusables + nonDetFoldUniqMap extend_modmap emptyUniqMap unusables where - extend_modmap modmap (unit_info, reason) = addListTo modmap bindings - where bindings :: [(ModuleName, Map Module ModuleOrigin)] + extend_modmap (_uid, (unit_info, reason)) modmap = addListTo modmap bindings + where bindings :: [(ModuleName, UniqMap Module ModuleOrigin)] bindings = exposed ++ hidden origin_reexport = ModUnusable (UnusableUnit unit reason True) @@ -1863,16 +1866,16 @@ -- The outer map is processed with 'Data.Map.Strict' to prevent memory leaks -- when reloading modules in GHCi (see #4029). This ensures that each -- value is forced before installing into the map. -addListTo :: (Monoid a, Ord k1, Ord k2) - => Map k1 (Map k2 a) - -> [(k1, Map k2 a)] - -> Map k1 (Map k2 a) +addListTo :: (Monoid a, Ord k1, Ord k2, Uniquable k1, Uniquable k2) + => UniqMap k1 (UniqMap k2 a) + -> [(k1, UniqMap k2 a)] + -> UniqMap k1 (UniqMap k2 a) addListTo = foldl' merge - where merge m (k, v) = MapStrict.insertWith (Map.unionWith mappend) k v m + where merge m (k, v) = addToUniqMap_C (plusUniqMap_C mappend) m k v -- | Create a singleton module mapping -mkModMap :: Unit -> ModuleName -> ModuleOrigin -> Map Module ModuleOrigin -mkModMap pkg mod = Map.singleton (mkModule pkg mod) +mkModMap :: Unit -> ModuleName -> ModuleOrigin -> UniqMap Module ModuleOrigin +mkModMap pkg mod = unitUniqMap (mkModule pkg mod) -- ----------------------------------------------------------------------------- @@ -1887,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 @@ -1950,10 +1952,10 @@ -> PkgQual -> LookupResult lookupModuleWithSuggestions' pkgs mod_map m mb_pn - = case Map.lookup m mod_map of + = case lookupUniqMap mod_map m of Nothing -> LookupNotFound suggestions Just xs -> - case foldl' classify ([],[],[], []) (Map.toList xs) of + case foldl' classify ([],[],[], []) (sortOn fst $ nonDetUniqMapToList xs) of ([], [], [], []) -> LookupNotFound suggestions (_, _, _, [(m, o)]) -> LookupFound m (mod_unit m, o) (_, _, _, exposed@(_:_)) -> LookupMultiple exposed @@ -2011,8 +2013,8 @@ all_mods :: [(String, ModuleSuggestion)] -- All modules all_mods = sortBy (comparing fst) $ [ (moduleNameString m, suggestion) - | (m, e) <- Map.toList (moduleNameProvidersMap pkgs) - , suggestion <- map (getSuggestion m) (Map.toList e) + | (m, e) <- nonDetUniqMapToList (moduleNameProvidersMap pkgs) + , suggestion <- map (getSuggestion m) (nonDetUniqMapToList e) ] getSuggestion name (mod, origin) = (if originVisible origin then SuggestVisible else SuggestHidden) @@ -2020,8 +2022,8 @@ listVisibleModuleNames :: UnitState -> [ModuleName] listVisibleModuleNames state = - map fst (filter visible (Map.toList (moduleNameProvidersMap state))) - where visible (_, ms) = any originVisible (Map.elems ms) + map fst (filter visible (nonDetUniqMapToList (moduleNameProvidersMap state))) + where visible (_, ms) = anyUniqMap originVisible ms -- | Takes a list of UnitIds (and their "parent" dependency, used for error -- messages), and returns the list with dependencies included, in reverse @@ -2032,7 +2034,7 @@ -- | Similar to closeUnitDeps but takes a list of already loaded units as an -- additional argument. closeUnitDeps' :: UnitInfoMap -> [UnitId] -> [(UnitId,Maybe UnitId)] -> MaybeErr UnitErr [UnitId] -closeUnitDeps' pkg_map current_ids ps = foldM (add_unit pkg_map) current_ids ps +closeUnitDeps' pkg_map current_ids ps = foldM (uncurry . add_unit pkg_map) current_ids ps -- | Add a UnitId and those it depends on (recursively) to the given list of -- UnitIds if they are not already in it. Return a list in reverse dependency @@ -2043,9 +2045,10 @@ -- error message ("dependency of "). add_unit :: UnitInfoMap -> [UnitId] - -> (UnitId,Maybe UnitId) + -> UnitId + -> Maybe UnitId -> MaybeErr UnitErr [UnitId] -add_unit pkg_map ps (p, mb_parent) +add_unit pkg_map ps p mb_parent | p `elem` ps = return ps -- Check if we've already added this unit | otherwise = case lookupUnitId' pkg_map p of Nothing -> Failed (CloseUnitErr p mb_parent) @@ -2054,8 +2057,8 @@ ps' <- foldM add_unit_key ps (unitDepends info) return (p : ps') where - add_unit_key ps key - = add_unit pkg_map ps (key, Just p) + add_unit_key xs key + = add_unit pkg_map xs key (Just p) data UnitErr = CloseUnitErr !UnitId !(Maybe UnitId) @@ -2099,7 +2102,7 @@ -- to form @mod_name@, or @[]@ if this is not a requirement. requirementMerges :: UnitState -> ModuleName -> [InstantiatedModule] requirementMerges pkgstate mod_name = - fromMaybe [] (Map.lookup mod_name (requirementContext pkgstate)) + fromMaybe [] (lookupUniqMap (requirementContext pkgstate) mod_name) -- ----------------------------------------------------------------------------- @@ -2154,9 +2157,9 @@ -- | Show the mapping of modules to where they come from. pprModuleMap :: ModuleNameProvidersMap -> SDoc pprModuleMap mod_map = - vcat (map pprLine (Map.toList mod_map)) + vcat (map pprLine (nonDetUniqMapToList mod_map)) where - pprLine (m,e) = ppr m $$ nest 50 (vcat (map (pprEntry m) (Map.toList e))) + pprLine (m,e) = ppr m $$ nest 50 (vcat (map (pprEntry m) (nonDetUniqMapToList e))) pprEntry :: Outputable a => ModuleName -> (Module, a) -> SDoc pprEntry m (m',o) | m == moduleName m' = ppr (moduleUnit m') <+> parens (ppr o) @@ -2268,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 @@ -99,17 +95,18 @@ import GHC.Utils.Encoding import GHC.Utils.Fingerprint import GHC.Utils.Misc +import GHC.Settings.Config (cProjectUnitId) -import Control.DeepSeq +import Control.DeepSeq (NFData(..)) import Data.Data -import Data.List (sortBy ) +import Data.List (sortBy) import Data.Function import Data.Bifunctor import qualified Data.ByteString as BS 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 @@ -148,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` () @@ -166,7 +164,7 @@ instance Outputable InstantiatedUnit where ppr = pprInstantiatedUnit -pprInstantiatedUnit :: IsLine doc => InstantiatedUnit -> doc +pprInstantiatedUnit :: InstantiatedUnit -> SDoc pprInstantiatedUnit uid = -- getPprStyle $ \sty -> pprUnitId cid <> @@ -180,8 +178,6 @@ where cid = instUnitInstanceOf uid insts = instUnitInsts uid -{-# SPECIALIZE pprInstantiatedUnit :: InstantiatedUnit -> SDoc #-} -{-# SPECIALIZE pprInstantiatedUnit :: InstantiatedUnit -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable -- | Class for types that are used as unit identifiers (UnitKey, UnitId, Unit) -- @@ -203,14 +199,13 @@ unitFS HoleUnit = holeFS pprModule :: IsLine doc => Module -> doc -pprModule mod@(Module p n) = docWithContext (doc . sdocStyle) +pprModule mod@(Module p n) = docWithStyle code doc where - doc sty - | codeStyle sty = - (if p == mainUnit + code = (if p == mainUnit then empty -- never qualify the main package in code else ztext (zEncodeFS (unitFS p)) <> char '_') <> pprModuleName n + doc sty | qualModule sty mod = case p of HoleUnit -> angleBrackets (pprModuleName n) @@ -319,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 @@ -352,12 +348,10 @@ instance Outputable Unit where ppr pk = pprUnit pk -pprUnit :: IsLine doc => Unit -> doc +pprUnit :: Unit -> SDoc pprUnit (RealUnit (Definite d)) = pprUnitId d pprUnit (VirtUnit uid) = pprInstantiatedUnit uid pprUnit HoleUnit = ftext holeFS -{-# SPECIALIZE pprUnit :: Unit -> SDoc #-} -{-# SPECIALIZE pprUnit :: Unit -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable instance Show Unit where show = unitString @@ -373,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 @@ -517,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) @@ -535,12 +534,8 @@ instance Outputable UnitId where ppr = pprUnitId -pprUnitId :: IsLine doc => UnitId -> doc -pprUnitId (UnitId fs) = dualLine (sdocOption sdocUnitIdForUser ($ fs)) (ftext fs) - -- see Note [Pretty-printing UnitId] in GHC.Unit - -- also see Note [dualLine and dualDoc] in GHC.Utils.Outputable -{-# SPECIALIZE pprUnitId :: UnitId -> SDoc #-} -{-# SPECIALIZE pprUnitId :: UnitId -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable +pprUnitId :: UnitId -> SDoc +pprUnitId (UnitId fs) = sdocOption sdocUnitIdForUser ($ fs) -- | A 'DefUnitId' is an 'UnitId' with the invariant that -- it only refers to a definite library; i.e., one we have generated @@ -596,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 "ghc") +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 @@ -629,14 +622,52 @@ wiredInUnitIds :: [UnitId] wiredInUnitIds = - [ primUnitId - , bignumUnitId - , baseUnitId + [ ghcInternalUnitId , rtsUnitId - , thUnitId - , thisGhcUnitId ] + -- 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 + -- cProjectUnitId defined in build-time-generated module GHC.Version, and + -- the unit key. + -- + -- See also Note [About units], taking into consideration ghc is still a + -- wired-in unit but whose unit-id no longer needs special handling because + -- we take care that it matches the unit key. +{- +Note [GHC's Unit Id] +~~~~~~~~~~~~~~~~~~~~ +Previously, the unit-id of ghc-the-library was fixed as `ghc`. +This was done primarily because the compiler must know the unit-id of +some packages (including ghc) a-priori to define wired-in names. + +However, as seen in #20742, a reinstallable `ghc` whose unit-id is fixed +to `ghc` might result in subtle bugs when different ghc's interact. + +A good example of this is having GHC_A load a plugin compiled by GHC_B, +where GHC_A and GHC_B are linked to ghc-libraries that are ABI +incompatible. Without a distinction between the unit-id of the ghc library +GHC_A is linked against and the ghc library the plugin it is loading was +compiled against, we can't check compatibility. + +Now, we give a better unit-id to ghc (`ghc-version-hash`) by + +(1) Not setting -this-unit-id fixed to `ghc` in `ghc.cabal`, but rather by having + (1.1) Hadrian pass the new unit-id with -this-unit-id for stage0-1 + (1.2) Cabal pass the unit-id it computes to ghc, which it already does by default + +(2) Adding a definition to `GHC.Settings.Config` whose value is the new +unit-id. This is crucial to define the wired-in name of the GHC unit +(`thisGhcUnitId`) which *must* match the value of the -this-unit-id flag. +(Where `GHC.Settings.Config` is a module generated by the build system which, +be it either hadrian or cabal, knows exactly the unit-id it passed with -this-unit-id) + +Note that we also ensure the ghc's unit key matches its unit id, both when +hadrian or cabal is building ghc. This way, we no longer need to add `ghc` to +the WiringMap, and that's why 'wiredInUnitIds' no longer includes +'thisGhcUnitId'. +-} + --------------------------------------------------------------------- -- Boot Modules --------------------------------------------------------------------- @@ -653,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 @@ -675,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,1516 +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, - - 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 - --- | SeekBin but without calling expandBin -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' - - --- ----------------------------------------------------------------------------- --- 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 FunctionOrData where --- put_ bh IsFunction = putByte bh 0 --- put_ bh IsData = putByte bh 1 --- get bh = do --- h <- getByte bh --- case h of --- 0 -> return IsFunction --- 1 -> return IsData --- _ -> panic "Binary FunctionOrData" - --- 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,10 +1,5 @@ {-# LANGUAGE CPP #-} -#if __GLASGOW_HASKELL__ {-# LANGUAGE MagicHash #-} -#endif -#if !defined(TESTING) && defined(__GLASGOW_HASKELL__) -{-# LANGUAGE Safe #-} -#endif ----------------------------------------------------------------------------- -- | 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,14 +1,13 @@ {-# LANGUAGE CPP #-} -#if !defined(TESTING) && defined(__GLASGOW_HASKELL__) -{-# LANGUAGE Safe #-} -#endif -- | A strict pair module GHC.Utils.Containers.Internal.StrictPair (StrictPair(..), toPair) where -import Prelude () -- for build ordering; see #23942 and - -- Note [Depend on GHC.Num.Integer] in base:GHC.Base +-- 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 @@ -32,7 +28,7 @@ formatBulleted, -- ** Construction - DiagOpts (..), diag_wopt, diag_fatal_wopt, + DiagOpts (..), emptyDiagOpts, diag_wopt, diag_fatal_wopt, emptyMessages, mkDecorated, mkLocMessage, mkMsgEnvelope, mkPlainMsgEnvelope, mkPlainErrorMsgEnvelope, mkErrorMsgEnvelope, @@ -75,10 +71,10 @@ 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 +import GHC.Unit.Module.Warnings import System.Exit ( ExitCode(..), exitWith ) import Data.List ( sortBy ) @@ -89,49 +85,93 @@ import Control.Monad.Catch as MC (handle) import GHC.Conc ( getAllocationCounter ) import System.CPUTime +import Data.List.NonEmpty (NonEmpty (..)) +import qualified Data.List.NonEmpty as NE data DiagOpts = DiagOpts { diag_warning_flags :: !(EnumSet WarningFlag) -- ^ Enabled warnings , diag_fatal_warning_flags :: !(EnumSet WarningFlag) -- ^ Fatal warnings + , diag_custom_warning_categories :: !WarningCategorySet -- ^ Enabled custom warning categories + , diag_fatal_custom_warning_categories :: !WarningCategorySet -- ^ Fatal custom warning categories , diag_warn_is_error :: !Bool -- ^ Treat warnings as errors , diag_reverse_errors :: !Bool -- ^ Reverse error reporting order , diag_max_errors :: !(Maybe Int) -- ^ Max reported error count , diag_ppr_ctx :: !SDocContext -- ^ Error printing context } +emptyDiagOpts :: DiagOpts +emptyDiagOpts = + DiagOpts + { diag_warning_flags = EnumSet.empty + , diag_fatal_warning_flags = EnumSet.empty + , diag_custom_warning_categories = emptyWarningCategorySet + , diag_fatal_custom_warning_categories = emptyWarningCategorySet + , diag_warn_is_error = False + , diag_reverse_errors = False + , diag_max_errors = Nothing + , diag_ppr_ctx = defaultSDocContext + } + diag_wopt :: WarningFlag -> DiagOpts -> Bool diag_wopt wflag opts = wflag `EnumSet.member` diag_warning_flags opts diag_fatal_wopt :: WarningFlag -> DiagOpts -> Bool diag_fatal_wopt wflag opts = wflag `EnumSet.member` diag_fatal_warning_flags opts +diag_wopt_custom :: WarningCategory -> DiagOpts -> Bool +diag_wopt_custom wflag opts = wflag `elemWarningCategorySet` diag_custom_warning_categories opts + +diag_fatal_wopt_custom :: WarningCategory -> DiagOpts -> Bool +diag_fatal_wopt_custom wflag opts = wflag `elemWarningCategorySet` diag_fatal_custom_warning_categories opts + -- | Computes the /right/ 'Severity' for the input 'DiagnosticReason' out of -- the 'DiagOpts. This function /has/ to be called when a diagnostic is constructed, -- i.e. with a 'DiagOpts \"snapshot\" taken as close as possible to where a -- particular diagnostic message is built, otherwise the computed 'Severity' might -- not be correct, due to the mutable nature of the 'DynFlags' in GHC. +-- +-- diagReasonSeverity :: DiagOpts -> DiagnosticReason -> Severity -diagReasonSeverity opts reason = case reason of - WarningWithFlag wflag - | not (diag_wopt wflag opts) -> SevIgnore - | diag_fatal_wopt wflag opts -> SevError - | otherwise -> SevWarning +diagReasonSeverity opts reason = fst (diag_reason_severity opts reason) + +-- Like the diagReasonSeverity but the second half of the pair is a small +-- ReasolvedDiagnosticReason which would cause the diagnostic to be triggered with the +-- same severity. +-- +-- See Note [Warnings controlled by multiple flags] +-- +diag_reason_severity :: DiagOpts -> DiagnosticReason -> (Severity, ResolvedDiagnosticReason) +diag_reason_severity opts reason = fmap ResolvedDiagnosticReason $ case reason of + WarningWithFlags wflags -> case wflags' of + [] -> (SevIgnore, reason) + w : ws -> case wflagsE of + [] -> (SevWarning, WarningWithFlags (w :| ws)) + e : es -> (SevError, WarningWithFlags (e :| es)) + where + wflags' = NE.filter (\wflag -> diag_wopt wflag opts) wflags + wflagsE = filter (\wflag -> diag_fatal_wopt wflag opts) wflags' + + WarningWithCategory wcat + | not (diag_wopt_custom wcat opts) -> (SevIgnore, reason) + | diag_fatal_wopt_custom wcat opts -> (SevError, reason) + | otherwise -> (SevWarning, reason) WarningWithoutFlag - | diag_warn_is_error opts -> SevError - | otherwise -> SevWarning + | diag_warn_is_error opts -> (SevError, reason) + | otherwise -> (SevWarning, reason) ErrorWithoutFlag - -> SevError - + -> (SevError, reason) -- | Make a 'MessageClass' for a given 'DiagnosticReason', consulting the --- 'DiagOpts. +-- 'DiagOpts'. mkMCDiagnostic :: DiagOpts -> DiagnosticReason -> Maybe DiagnosticCode -> MessageClass -mkMCDiagnostic opts reason code = MCDiagnostic (diagReasonSeverity opts reason) reason code +mkMCDiagnostic opts reason code = MCDiagnostic sev reason' code + where + (sev, reason') = diag_reason_severity opts reason -- | Varation of 'mkMCDiagnostic' which can be used when we are /sure/ the -- input 'DiagnosticReason' /is/ 'ErrorWithoutFlag' and there is no diagnostic code. errorDiagnostic :: MessageClass -errorDiagnostic = MCDiagnostic SevError ErrorWithoutFlag Nothing +errorDiagnostic = MCDiagnostic SevError (ResolvedDiagnosticReason ErrorWithoutFlag) Nothing -- -- Creating MsgEnvelope(s) @@ -142,13 +182,15 @@ => Severity -> SrcSpan -> NamePprCtx + -> ResolvedDiagnosticReason -> e -> MsgEnvelope e -mk_msg_envelope severity locn name_ppr_ctx err +mk_msg_envelope severity locn name_ppr_ctx reason err = MsgEnvelope { errMsgSpan = locn , errMsgContext = name_ppr_ctx , errMsgDiagnostic = err , errMsgSeverity = severity + , errMsgReason = reason } -- | Wrap a 'Diagnostic' in a 'MsgEnvelope', recording its location. @@ -162,7 +204,9 @@ -> e -> MsgEnvelope e mkMsgEnvelope opts locn name_ppr_ctx err - = mk_msg_envelope (diagReasonSeverity opts (diagnosticReason err)) locn name_ppr_ctx err + = mk_msg_envelope sev locn name_ppr_ctx reason err + where + (sev, reason) = diag_reason_severity opts (diagnosticReason err) -- | Wrap a 'Diagnostic' in a 'MsgEnvelope', recording its location. -- Precondition: the diagnostic is, in fact, an error. That is, @@ -173,7 +217,7 @@ -> e -> MsgEnvelope e mkErrorMsgEnvelope locn name_ppr_ctx msg = - assert (diagnosticReason msg == ErrorWithoutFlag) $ mk_msg_envelope SevError locn name_ppr_ctx msg + assert (diagnosticReason msg == ErrorWithoutFlag) $ mk_msg_envelope SevError locn name_ppr_ctx (ResolvedDiagnosticReason ErrorWithoutFlag) msg -- | Variant that doesn't care about qualified/unqualified names. mkPlainMsgEnvelope :: Diagnostic e @@ -191,7 +235,7 @@ -> e -> MsgEnvelope e mkPlainErrorMsgEnvelope locn msg = - mk_msg_envelope SevError locn alwaysQualify msg + mk_msg_envelope SevError locn alwaysQualify (ResolvedDiagnosticReason ErrorWithoutFlag) msg ------------------------- data Validity' a @@ -219,14 +263,14 @@ ---------------- -- | Formats the input list of structured document, where each element of the list gets a bullet. -formatBulleted :: SDocContext -> DecoratedSDoc -> SDoc -formatBulleted ctx (unDecorated -> docs) - = case msgs of +formatBulleted :: DecoratedSDoc -> SDoc +formatBulleted (unDecorated -> docs) + = sdocWithContext $ \ctx -> case msgs ctx of [] -> Outputable.empty [msg] -> msg - _ -> vcat $ map starred msgs + xs -> vcat $ map starred xs where - msgs = filter (not . Outputable.isEmpty ctx) docs + msgs ctx = filter (not . Outputable.isEmpty ctx) docs starred = (bullet<+>) pprMessages :: Diagnostic e => DiagnosticOpts e -> Messages e -> SDoc @@ -247,13 +291,13 @@ pprLocMsgEnvelope opts (MsgEnvelope { errMsgSpan = s , errMsgDiagnostic = e , errMsgSeverity = sev - , errMsgContext = name_ppr_ctx }) - = sdocWithContext $ \ctx -> - withErrStyle name_ppr_ctx $ + , errMsgContext = name_ppr_ctx + , errMsgReason = reason }) + = withErrStyle name_ppr_ctx $ mkLocMessage - (MCDiagnostic sev (diagnosticReason e) (diagnosticCode e)) + (MCDiagnostic sev reason (diagnosticCode e)) s - (formatBulleted ctx $ diagnosticMessage opts e) + (formatBulleted $ diagnosticMessage opts e) sortMsgBag :: Maybe DiagOpts -> Bag (MsgEnvelope e) -> [MsgEnvelope e] sortMsgBag mopts = maybeLimit . sortBy (cmp `on` errMsgSpan) . bagToList @@ -365,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) @@ -383,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 @@ -403,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 -- @@ -22,12 +20,13 @@ unzipWith, mapFst, mapSnd, chkAppend, - mapAndUnzip, mapAndUnzip3, - filterOut, partitionWith, + mapAndUnzip, mapAndUnzip3, mapAndUnzip4, + 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, @@ -35,14 +34,11 @@ equalLength, compareLength, leLength, ltLength, isSingleton, only, expectOnly, GHC.Utils.Misc.singleton, - notNull, snocView, - - chunkList, + notNull, expectNonEmpty, snocView, holes, changeLast, - mapLastM, whenNonEmpty, @@ -55,6 +51,7 @@ -- * Tuples fstOf3, sndOf3, thdOf3, + fstOf4, sndOf4, fst3, snd3, third3, uncurry3, @@ -121,6 +118,7 @@ ) where import GHC.Prelude.Basic hiding ( head, init, last, tail ) +import qualified GHC.Prelude.Basic as Partial ( head ) import GHC.Utils.Exception import GHC.Utils.Panic.Plain @@ -129,12 +127,11 @@ import Data.Data import qualified Data.List as List -import qualified Data.List as Partial ( head ) 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 ) @@ -145,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 ) @@ -183,6 +181,11 @@ sndOf3 (_,b,_) = b thdOf3 (_,_,c) = c +fstOf4 :: (a,b,c,d) -> a +sndOf4 :: (a,b,c,d) -> b +fstOf4 (a,_,_,_) = a +sndOf4 (_,b,_,_) = b + fst3 :: (a -> d) -> (a, b, c) -> (d, b, c) fst3 f (a, b, c) = (f a, b, c) @@ -215,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 @@ -228,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 @@ -314,24 +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) - zipWithAndUnzip :: (a -> b -> (c,d)) -> [a] -> [b] -> ([c],[d]) zipWithAndUnzip f (a:as) (b:bs) = let (r1, r2) = f a b @@ -472,20 +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 :: HasCallStack => 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. -- @@ -500,11 +491,17 @@ changeLast [_] x = [x] changeLast (x:xs) x' = x : changeLast xs x' --- | 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) +-- | Like @expectJust msg . nonEmpty@; a better alternative to 'NE.fromList'. +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 [] = expectNonEmptyPanic +expectNonEmptyPanic :: HasCallStack => a +expectNonEmptyPanic = panic "expectNonEmpty" +{-# NOINLINE expectNonEmptyPanic #-} + whenNonEmpty :: Applicative m => [a] -> (NonEmpty a -> m ()) -> m () whenNonEmpty [] _ = pure () whenNonEmpty (x:xs) f = f (x :| xs) @@ -637,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 @@ -1028,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) @@ -1048,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') @@ -1417,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 @@ -11,13 +11,14 @@ , MonadIO(..) , zipWith3M, zipWith3M_, zipWith4M, zipWithAndUnzipM + , zipWith3MNE , mapAndUnzipM, mapAndUnzip3M, mapAndUnzip4M, mapAndUnzip5M , mapAccumLM , mapSndM , concatMapM , mapMaybeM , anyM, allM, orM - , foldlM, foldlM_, foldrM + , foldlM, foldlM_, foldrM, foldMapM , whenM, unlessM , filterOutM , partitionM @@ -36,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) ------------------------------------------------------------------------------- @@ -97,6 +99,15 @@ ; return (c:cs, d:ds) } zipWithAndUnzipM _ _ _ = return ([], []) +-- | 'zipWith3M' for 'NonEmpty' lists. +zipWith3MNE :: Monad m + => (a -> b -> c -> m d) + -> NonEmpty a -> NonEmpty b -> NonEmpty c -> m (NonEmpty d) +zipWith3MNE f ~(x :| xs) ~(y :| ys) ~(z :| zs) + = do { w <- f x y z + ; ws <- zipWith3M f xs ys zs + ; return $ w :| ws } + {- Note [Inline @mapAndUnzipNM@ functions] @@ -217,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/Codensity.hs b/GHC/Utils/Monad/Codensity.hs new file mode 100644 --- /dev/null +++ b/GHC/Utils/Monad/Codensity.hs @@ -0,0 +1,64 @@ +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE StandaloneKindSignatures #-} + +module GHC.Utils.Monad.Codensity + ( Codensity(..), toCodensity, fromCodensity ) + where + +import Data.Kind ( Type ) + +import GHC.Prelude +import GHC.Exts ( oneShot ) + +import Control.Monad.Fix +import Control.Monad.IO.Class +import Control.Monad.Trans.Class +import Control.Concurrent.MVar ( newEmptyMVar, readMVar, putMVar ) +import Control.Exception +import GHC.IO.Exception +import GHC.IO.Unsafe ( unsafeDupableInterleaveIO ) + +-------------------------------------------------------------------------------- + +type Codensity :: (Type -> Type) -> Type -> Type +newtype Codensity m a = Codensity { runCodensity :: forall r. (a -> m r) -> m r } +instance Functor (Codensity k) where + fmap f (Codensity m) = Codensity $ oneShot (\k -> m $ oneShot (\x -> k $ f x)) + {-# INLINE fmap #-} +instance Applicative (Codensity f) where + pure x = Codensity $ oneShot (\k -> k x) + {-# INLINE pure #-} + Codensity f <*> Codensity g = + Codensity $ oneShot (\bfr -> f $ oneShot (\ab -> g $ oneShot (\x -> bfr (ab x)))) + {-# INLINE (<*>) #-} +instance Monad (Codensity f) where + return = pure + {-# INLINE return #-} + m >>= k = + Codensity $ oneShot (\c -> runCodensity m $ oneShot (\a -> runCodensity (k a) c)) + {-# INLINE (>>=) #-} +instance MonadTrans Codensity where + lift m = Codensity $ oneShot (m >>=) + {-# INLINE lift #-} +instance MonadIO m => MonadIO (Codensity m) where + liftIO = lift . liftIO + {-# INLINE liftIO #-} +instance MonadIO m => MonadFix (Codensity m) where + mfix f = Codensity $ oneShot $ \ k -> do + promise <- liftIO $ newEmptyMVar + ans <- liftIO $ unsafeDupableInterleaveIO + $ readMVar promise + `catch` + (\ BlockedIndefinitelyOnMVar -> throwIO FixIOException) + runCodensity (f ans) $ oneShot $ \ a -> do + liftIO $ putMVar promise a + k a + {-# INLINE mfix #-} + +toCodensity :: Monad m => m a -> Codensity m a +toCodensity m = Codensity $ oneShot (m >>=) +{-# INLINE toCodensity #-} + +fromCodensity :: Monad m => Codensity m a -> m a +fromCodensity c = runCodensity c return +{-# INLINE fromCodensity #-} 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,13 +32,15 @@ SDoc, runSDoc, PDoc(..), docToSDoc, interppSP, interpp'SP, interpp'SP', - pprQuotedList, pprWithCommas, quotedListWithOr, quotedListWithNor, + 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, @@ -46,10 +49,11 @@ blankLine, forAllLit, bullet, ($+$), cat, fcat, - hang, hangNotEmpty, punctuate, ppWhen, ppUnless, - ppWhenOption, ppUnlessOption, - speakNth, speakN, speakNOf, plural, singular, + hang, hangNotEmpty, punctuate, punctuateFinal, + ppWhen, ppUnless, ppWhenOption, ppUnlessOption, + speakNth, speakN, speakNOf, plural, singular, pluralSet, isOrAre, doOrDoes, itsOrTheir, thisOrThese, hasOrHave, + itOrThey, unicodeSyntax, coloured, keyword, @@ -85,8 +89,6 @@ pprModuleName, -- * Controlling the style in which output is printed - BindingSite(..), - PprStyle(..), NamePprCtx(..), QueryQualifyName, QueryQualifyModule, QueryQualifyPackage, QueryPromotionTick, PromotedItem(..), IsEmptyOrSingleton(..), isListEmptyOrSingleton, @@ -126,10 +128,11 @@ import qualified GHC.Utils.Ppr as Pretty import qualified GHC.Utils.Ppr.Colour as Col import GHC.Utils.Ppr ( Doc, Mode(..) ) +import GHC.Utils.Panic.Plain (assert) 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 @@ -139,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 @@ -149,10 +153,12 @@ import Data.Graph (SCC(..)) import Data.List (intersperse) import Data.List.NonEmpty (NonEmpty (..)) +import Data.Semigroup (Arg(..)) import qualified Data.List.NonEmpty as NEL -import Data.Time +import Data.Time ( UTCTime ) import Data.Time.Format.ISO8601 import Data.Void +import Control.DeepSeq (NFData(rnf)) import GHC.Fingerprint import GHC.Show ( showMultiLineString ) @@ -207,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. @@ -262,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 @@ -393,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 @@ -454,6 +461,7 @@ , sdocDefaultDepth = 5 , sdocLineLength = 100 , sdocCanUseUnicode = False + , sdocPrintErrIndexLinks = False , sdocHexWordLiterals = False , sdocPprDebug = False , sdocPrintUnicodeSyntax = False @@ -559,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 @@ -728,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'. @@ -842,6 +856,21 @@ go d [] = [d] go d (e:es) = (d <> p) : go e es +-- | Punctuate a list, e.g. with commas and dots. +-- +-- > sep $ punctuateFinal comma dot [text "ab", text "cd", text "ef"] +-- > ab, cd, ef. +punctuateFinal :: IsLine doc + => doc -- ^ The interstitial punctuation + -> doc -- ^ The final punctuation + -> [doc] -- ^ The list that will have punctuation added between every adjacent pair of elements + -> [doc] -- ^ Punctuated list +punctuateFinal _ _ [] = [] +punctuateFinal p q (d:ds) = go d ds + where + go d [] = [d <> q] + go d (e:es) = (d <> p) : go e es + ppWhen, ppUnless :: IsOutput doc => Bool -> doc -> doc {-# INLINE CONLIKE ppWhen #-} ppWhen True doc = doc @@ -858,9 +887,10 @@ False -> empty {-# INLINE CONLIKE ppUnlessOption #-} -ppUnlessOption :: IsLine doc => (SDocContext -> Bool) -> doc -> doc -ppUnlessOption f doc = docWithContext $ - \ctx -> if f ctx then empty else doc +ppUnlessOption :: (SDocContext -> Bool) -> SDoc -> SDoc +ppUnlessOption f doc = sdocOption f $ \case + True -> empty + False -> doc -- | Apply the given colour\/style for the argument. -- @@ -890,6 +920,9 @@ -- There's no Outputable for Char; it's too easy to use Outputable -- on String and have ppr "hello" rendered as "h,e,l,l,o". +instance Outputable Void where + ppr _ = text "<>" + instance Outputable Bool where ppr True = text "True" ppr False = text "False" @@ -950,12 +983,18 @@ instance (Outputable a) => Outputable (NonEmpty a) where ppr = ppr . NEL.toList +instance (Outputable a, Outputable b) => Outputable (Arg a b) where + ppr (Arg a b) = text "Arg" <+> ppr a <+> ppr b + instance (Outputable a) => Outputable (Set a) where ppr s = braces (pprWithCommas ppr (Set.toList s)) 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]) @@ -1041,12 +1080,10 @@ instance Outputable ModuleName where ppr = pprModuleName + pprModuleName :: IsLine doc => ModuleName -> doc pprModuleName (ModuleName nm) = - docWithContext $ \ctx -> - if codeStyle (sdocStyle ctx) - then ztext (zEncodeFS nm) - else ftext nm + docWithStyle (ztext (zEncodeFS nm)) (\_ -> ftext nm) {-# SPECIALIZE pprModuleName :: ModuleName -> SDoc #-} {-# SPECIALIZE pprModuleName :: ModuleName -> HLine #-} -- see Note [SPECIALIZE to HDoc] @@ -1168,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) @@ -1198,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 @@ -1219,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` () + {- ************************************************************************ * * @@ -1341,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, @@ -1374,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)) @@ -1387,6 +1459,20 @@ quotedListWithNor xs@(_:_:_) = quotedList (init xs) <+> text "nor" <+> quotes (last xs) quotedListWithNor xs = quotedList xs +quotedListWithAnd :: [SDoc] -> SDoc +-- [x,y,z] ==> `x', `y' and `z' +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 + {- ************************************************************************ * * @@ -1464,6 +1550,10 @@ 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: -- -- > singular [] = empty @@ -1500,7 +1590,16 @@ itsOrTheir [_] = text "its" itsOrTheir _ = text "their" +-- | 'it' or 'they', depeneding on the length of the list. +-- +-- > itOrThey [x] = text "it" +-- > itOrThey [x,y] = text "they" +-- > itOrThey [] = text "they" -- probably avoid this +itOrThey :: [a] -> SDoc +itOrThey [_] = text "it" +itOrThey _ = text "they" + -- | Determines the form of subject appropriate for the length of a list: -- -- > thisOrThese [x] = text "This" @@ -1636,6 +1735,7 @@ class IsOutput doc where empty :: doc docWithContext :: (SDocContext -> doc) -> doc + docWithStyle :: doc -> (PprStyle -> SDoc) -> doc class IsOutput doc => IsLine doc class (IsOutput doc, IsLine (Line doc)) => IsDoc doc @@ -1672,14 +1772,23 @@ difficult to make completely equivalent under both printer implementations. These operations should generally be avoided, as they can result in surprising -changes in behavior when the printer implementation is changed. However, in -certain cases, the alternative is even worse. For example, we use dualLine in -the implementation of pprUnitId, as the hack we use for printing unit ids -(see Note [Pretty-printing UnitId] in GHC.Unit) is difficult to adapt to HLine -and is not necessary for code paths that use it, anyway. +changes in behavior when the printer implementation is changed. +Right now, they are used only when outputting debugging comments in +codegen, as it is difficult to adapt that code to use HLine and not necessary. -Use these operations wisely. -} +Use these operations wisely. +Note [docWithStyle] +~~~~~~~~~~~~~~~~~~~ +Sometimes when printing, we consult the printing style. This can be done +with 'docWithStyle c f'. This is similar to 'docWithContext (f . sdocStyle)', +but: +* For code style, 'docWithStyle c f' will return 'c'. +* For other styles, 'docWithStyle c f', will call 'f style', but expect + an SDoc rather than doc. This removes the need to write code polymorphic + in SDoc and HDoc, since the latter is used only for code style. +-} + -- | Represents a single line of output that can be efficiently printed directly -- to a 'System.IO.Handle' (actually a 'BufHandle'). -- See Note [SDoc versus HDoc] and Note [HLine versus HDoc] for more details. @@ -1703,7 +1812,7 @@ {-# COMPLETE HDoc #-} bPutHDoc :: BufHandle -> SDocContext -> HDoc -> IO () -bPutHDoc h ctx (HDoc f) = f ctx h +bPutHDoc h ctx (HDoc f) = assert (codeStyle (sdocStyle ctx)) (f ctx h) -- | A superclass for 'IsLine' and 'IsDoc' that provides an identity, 'empty', -- as well as access to the shared 'SDocContext'. @@ -1712,6 +1821,7 @@ class IsOutput doc where empty :: doc docWithContext :: (SDocContext -> doc) -> doc + docWithStyle :: doc -> (PprStyle -> SDoc) -> doc -- see Note [docWithStyle] -- | A class of types that represent a single logical line of text, with support -- for horizontal composition. @@ -1782,6 +1892,11 @@ {-# INLINE CONLIKE empty #-} docWithContext = sdocWithContext {-# INLINE docWithContext #-} + docWithStyle c f = sdocWithContext (\ctx -> let sty = sdocStyle ctx + in if codeStyle sty then c + else f sty) + -- see Note [docWithStyle] + {-# INLINE CONLIKE docWithStyle #-} instance IsLine SDoc where char c = docToSDoc $ Pretty.char c @@ -1826,12 +1941,16 @@ {-# INLINE empty #-} docWithContext f = HLine $ \ctx h -> runHLine (f ctx) ctx h {-# INLINE CONLIKE docWithContext #-} + docWithStyle c _ = c -- see Note [docWithStyle] + {-# INLINE CONLIKE docWithStyle #-} instance IsOutput HDoc where empty = HDoc (\_ _ -> pure ()) {-# INLINE empty #-} docWithContext f = HDoc $ \ctx h -> runHDoc (f ctx) ctx h {-# INLINE CONLIKE docWithContext #-} + docWithStyle c _ = c -- see Note [docWithStyle] + {-# INLINE CONLIKE docWithStyle #-} instance IsLine HLine where char c = HLine (\_ h -> bPutChar h c) diff --git a/GHC/Utils/Panic.hs b/GHC/Utils/Panic.hs --- a/GHC/Utils/Panic.hs +++ b/GHC/Utils/Panic.hs @@ -7,6 +7,8 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE ScopedTypeVariables, LambdaCase #-} +#include + -- | Defines basic functions for printing error messages. -- -- It's hard to put these functions anywhere else without causing @@ -21,17 +23,12 @@ , handleGhcException -- * Command error throwing patterns - , pgmError - , panic , pprPanic - , sorry , panicDoc , sorryDoc , pgmErrorDoc - , cmdLineError - , cmdLineErrorIO + -- ** Assertions - , assertPanic , assertPprPanic , assertPpr , assertPprMaybe @@ -50,6 +47,7 @@ , tryMost , throwTo , withSignalHandlers + , module GHC.Utils.Panic.Plain ) where @@ -130,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 @@ -175,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 @@ -186,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 @@ -236,6 +238,11 @@ -- | Temporarily install standard signal handlers for catching ^C, which just -- throw an exception in the current thread. withSignalHandlers :: ExceptionMonad m => m a -> m a +#if !defined(HAVE_SIGNAL_H) +-- No signal functionality exist on the host platform (e.g. on +-- wasm32-wasi), so don't attempt to set up signal handlers +withSignalHandlers = id +#else withSignalHandlers act = do main_thread <- liftIO myThreadId wtid <- liftIO (mkWeakThreadId main_thread) @@ -295,6 +302,7 @@ mayInstallHandlers act `MC.finally` mayUninstallHandlers +#endif callStackDoc :: HasCallStack => SDoc callStackDoc = prettyCallStackDoc callStack 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 @@ -29,6 +24,8 @@ import GHC.Utils.Exception as Exception import GHC.Stack import GHC.Prelude.Basic + +import Control.Monad (when) import System.IO.Unsafe -- | This type is very similar to 'GHC.Utils.Panic.GhcException', but it omits @@ -102,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) @@ -116,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 @@ -128,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 #-} @@ -150,4 +141,8 @@ assertM :: (HasCallStack, Monad m) => m Bool -> m () {-# INLINE assertM #-} -assertM mcond = withFrozenCallStack (mcond >>= massert) +assertM mcond + | debugIsOn = withFrozenCallStack $ do + res <- mcond + when (not res) assertPanic' + | otherwise = return () 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,16 +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.Utils.Misc import GHC.Utils.Panic import GHC.Utils.Outputable ( Outputable, text, (<+>), ppr @@ -78,7 +78,7 @@ scrutinee = smartExtend platform $ smartPlus platform e offset range = inclusiveInterval (lo+toInteger offset) (hi+toInteger offset) in Switch scrutinee range target_labels default_label - CmmCall { cml_cont = Nothing, cml_target = e } -> TailCall e + CmmCall { cml_target = e } -> TailCall e _ -> panic "flowLeaving: unreachable" ----------------------- Evaluation contexts ------------------------------ @@ -138,18 +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 -> (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 txExpr txBlock g = - doTree returns dominatorTree emptyContext - where - gwd :: GraphWithDominators CmmNode - gwd = graphWithDominators g +structuredControl platform txExpr txBlock g' = do + gwd :: GraphWithDominators CmmNode <- + liftUniqDSM $ asReducible $ graphWithDominators g' + let + g :: CmmGraph + g = gwd_graph gwd + dominatorTree :: Tree.Tree CmmBlock-- Dominator tree in which children are sorted -- with highest reverse-postorder number first dominatorTree = fmap blockLabeled $ sortTree $ gwdDominatorTree gwd @@ -309,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 @@ -329,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,63 +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 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 @@ -30,26 +30,23 @@ HsDecl(..), LHsDecl, HsDataDefn(..), HsDeriving, LHsFunDep, FunDep(..), HsDerivingClause(..), LHsDerivingClause, DerivClauseTys(..), LDerivClauseTys, NewOrData(..), DataDefnCons(..), dataDefnConsNewOrData, - isTypeDataDefnCons, + isTypeDataDefnCons, firstDataDefnCon, StandaloneKindSig(..), LStandaloneKindSig, -- ** Class or type declarations TyClDecl(..), LTyClDecl, TyClGroup(..), - tyClGroupTyClDecls, tyClGroupInstDecls, tyClGroupRoleDecls, - tyClGroupKindSigs, isClassDecl, isDataDecl, isSynDecl, isFamilyDecl, isTypeFamilyDecl, isDataFamilyDecl, isOpenTypeFamilyInfo, isClosedTypeFamilyInfo, - tyClDeclTyVars, FamilyDecl(..), LFamilyDecl, -- ** Instance declarations - InstDecl(..), LInstDecl, FamilyInfo(..), + InstDecl(..), LInstDecl, FamilyInfo(..), familyInfoTyConFlavour, 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,31 +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) +import GHC.Types.Basic (TopLevelFlag, OverlapMode, RuleName, Activation + ,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.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 (..)) @@ -133,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 @@ -238,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) @@ -405,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 @@ -432,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 @@ -447,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 @@ -499,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 @@ -567,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 @@ -580,7 +530,8 @@ See https://gitlab.haskell.org/ghc/ghc/wikis/ghc-kinds/kind-inference#proposed-new-strategy and #9200 for lots of discussion of how we got here. -The detection of CUSKs is enabled by the -XCUSKs extension, switched on by default. +The detection of CUSKs is enabled by the -XCUSKs extension, switched off by default +in GHC2021 and on in Haskell98/2010. Under -XNoCUSKs, all declarations are treated as if they have no CUSK. See https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0036-kind-signatures.rst @@ -670,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 @@ -701,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 @@ -789,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 @@ -825,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) @@ -849,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 @@ -862,7 +774,29 @@ -- said "type family Foo x where .." | ClosedTypeFamily (Maybe [LTyFamInstEqn pass]) +familyInfoTyConFlavour + :: Maybe tc -- ^ Just cls <=> this is an associated family of class cls + -> FamilyInfo pass + -> TyConFlavour tc +familyInfoTyConFlavour mb_parent_tycon info = + case info of + 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] + ClosedTypeFamilyFlavour +{- Note [Closed type family mb_parent_tycon] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +There's no way to write a closed type family inside a class declaration: + + class C a where + type family F a where -- error: parse error on input ‘where’ + +In fact, it is not clear what the meaning of such a declaration would be. +Therefore, 'mb_parent_tycon' of any closed type family has to be Nothing. +-} + {- ********************************************************************* * * Data types and data constructors @@ -916,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 @@ -986,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@ @@ -1006,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. @@ -1015,13 +938,14 @@ isTypeDataDefnCons (NewTypeCon _) = False isTypeDataDefnCons (DataTypeCons is_type_data _) = is_type_data +-- | Retrieve the first data constructor in a 'DataDefnCons' (if one exists). +firstDataDefnCon :: DataDefnCons a -> Maybe a +firstDataDefnCon (NewTypeCon con) = Just con +firstDataDefnCon (DataTypeCons _ cons) = listToMaybe cons + -- | 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 - -- | -- -- @ @@ -1037,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 @@ -1201,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. @@ -1212,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 + {- ************************************************************************ * * @@ -1248,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] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1307,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 ------------- @@ -1322,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 @@ -1344,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 @@ -1375,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) @@ -1428,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) @@ -1469,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) {- @@ -1517,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) {- @@ -1552,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 @@ -1598,42 +1480,14 @@ { rd_ext :: XHsRule pass -- ^ After renamer, free-vars from the LHS and RHS , rd_name :: XRec pass RuleName - -- ^ Note [Pragma source text] in "GHC.Types.Basic" - , 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) + -- ^ Note [Pragma source text] in "GHC.Types.SourceText" + , 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] - {- ************************************************************************ * * @@ -1702,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 @@ -1742,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 @@ -5,6 +5,7 @@ {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilyDependencies #-} {-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow] @@ -24,26 +25,22 @@ 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: import Data.Data hiding (Fixity(..)) import Data.Bool -import Data.Either 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]. @@ -147,6 +144,19 @@ type RecUpdProj p = RecProj p (LHsExpr p) type LHsRecUpdProj p = XRec p (RecUpdProj p) +-- | Haskell Record Update Fields. +data LHsRecUpdFields p where + -- | A regular (non-overloaded) record update. + RegularRecUpdFields + :: { xRecUpdFields :: XLHsRecUpdLabels p + , recUpdFields :: [LHsRecUpdField p p] } + -> LHsRecUpdFields p + -- | An overloaded record update. + OverloadedRecUpdFields + :: { xOLRecUpdFields :: XLHsOLRecUpdLabels p + , olRecUpdFields :: [LHsRecUpdProj p] } + -> LHsRecUpdFields p + {- ************************************************************************ * * @@ -159,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] ~~~~~~~~~~~~~~~~~~~~~~ @@ -227,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. -} @@ -248,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) @@ -283,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 @@ -329,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] @@ -354,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) @@ -366,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 @@ -400,80 +415,41 @@ (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 - , rupd_flds :: Either [LHsRecUpdField p] [LHsRecUpdProj p] + , rupd_flds :: LHsRecUpdFields p } -- For a type family, the arg types are of the *instance* tycon, -- 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 { @@ -487,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) @@ -508,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)) @@ -525,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 @@ -556,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 @@ -566,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. -- --------------------------------------------------------------------- @@ -587,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 @@ -605,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 @@ -617,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) {- @@ -793,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 @@ -807,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. @@ -818,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 @@ -960,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) @@ -985,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. @@ -1016,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) @@ -1097,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 @@ -1119,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 @@ -1131,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] @@ -1152,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] @@ -1191,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] @@ -1249,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] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1481,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 |] @@ -1530,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 @@ -1557,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 { ... } @@ -1606,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 @@ -1629,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 @@ -1643,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 @@ -432,6 +471,8 @@ type family XExplicitList x type family XRecordCon x type family XRecordUpd x +type family XLHsRecUpdLabels x +type family XLHsOLRecUpdLabels x type family XGetField x type family XProjection x type family XExprWithTySig x @@ -445,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 @@ -457,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 @@ -473,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 @@ -515,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 @@ -543,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 @@ -562,14 +597,19 @@ 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 type family XHsWordPrim x +type family XHsInt8Prim x +type family XHsInt16Prim x +type family XHsInt32Prim x type family XHsInt64Prim x +type family XHsWord8Prim x +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 @@ -591,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 @@ -598,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 @@ -633,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 @@ -650,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 @@ -673,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 @@ -688,7 +738,7 @@ type family XXFieldOcc x -- ===================================================================== --- Type families for the HsImpExp type families +-- Type families for the HsImpExp extension points -- ------------------------------------- -- ImportDecl type families @@ -711,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 - -- methods/constructors and record fields; see Note [IEThingWith] - -- - '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 + -- The thing is a Class\/Type (can't tell) and the imported or exported things are + -- its children. + -- + -- @ + -- 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) @@ -42,9 +40,9 @@ ************************************************************************ -} --- Note [Literal source text] in GHC.Types.Basic for SourceText fields in +-- Note [Literal source text] in "GHC.Types.SourceText" for SourceText fields in -- the following --- Note [Trees That Grow] in Language.Haskell.Syntax.Extension for the Xxxxx +-- Note [Trees That Grow] in "Language.Haskell.Syntax.Extension" for the Xxxxx -- fields in the following -- | Haskell Literal data HsLit x @@ -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 @@ -63,26 +63,29 @@ -- ^ literal @Int#@ | HsWordPrim (XHsWordPrim x) {- SourceText -} Integer -- ^ literal @Word#@ + | HsInt8Prim (XHsInt8Prim x) {- SourceText -} Integer + -- ^ literal @Int8#@ + | HsInt16Prim (XHsInt16Prim x) {- SourceText -} Integer + -- ^ literal @Int16#@ + | HsInt32Prim (XHsInt32Prim x) {- SourceText -} Integer + -- ^ literal @Int32#@ | HsInt64Prim (XHsInt64Prim x) {- SourceText -} Integer -- ^ literal @Int64#@ + | HsWord8Prim (XHsWord8Prim x) {- SourceText -} Integer + -- ^ literal @Word8#@ + | HsWord16Prim (XHsWord16Prim x) {- SourceText -} Integer + -- ^ literal @Word16#@ + | HsWord32Prim (XHsWord32Prim x) {- SourceText -} Integer + -- ^ 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 @@ -92,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 @@ -107,7 +109,7 @@ | XOverLit !(XXOverLit p) --- Note [Literal source text] in GHC.Types.Basic for SourceText fields in +-- Note [Literal source text] in "GHC.Types.SourceText" for SourceText fields in -- the following -- | Overloaded Literal Value data OverLitVal @@ -116,29 +118,12 @@ | 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 compare (HsIntegral _) (HsFractional _) = LT @@ -149,4 +134,3 @@ compare (HsIsString _ s1) (HsIsString _ s2) = s1 `lexicalCompareFS` s2 compare (HsIsString _ _) (HsIntegral _) = GT compare (HsIsString _ _) (HsFractional _) = GT - 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 = XRec p (HsRecUpdField p) - -- | 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 = HsFieldBind (LAmbiguousFieldOcc p) (LHsExpr p) +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, @@ -353,14 +343,4 @@ -- -- hfbLHS = Unambiguous "x" $sel:x:MkS :: AmbiguousFieldOcc Id -- --- See also Note [Disambiguating record fields] in GHC.Tc.Gen.Head. - -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 - +-- See also Note [Disambiguating record updates] in GHC.Rename.Pat. 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 @@ -8,6 +8,7 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow] +{-# LANGUAGE LambdaCase #-} -- in module Language.Haskell.Syntax.Extension {- (c) The University of Glasgow 2006 @@ -19,62 +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, - 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, + 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.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) +import Data.Ord (Ord) +import Control.DeepSeq {- ************************************************************************ @@ -88,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 = () {- ************************************************************************ @@ -291,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 @@ -342,13 +321,14 @@ data LHsQTyVars pass -- See Note [HsType binders] = HsQTvs { hsq_ext :: XHsQTvs pass - , hsq_explicit :: [LHsTyVarBndr () pass] + , hsq_explicit :: [LHsTyVarBndr (HsBndrVis pass) pass] -- Explicit variables, written by the user } | XLHsQTyVars !(XXLHsQTyVars pass) -hsQTvExplicit :: LHsQTyVars pass -> [LHsTyVarBndr () pass] -hsQTvExplicit = hsq_explicit +hsQTvExplicit :: LHsQTyVars pass -> [LHsTyVarBndr (HsBndrVis pass) pass] +hsQTvExplicit (HsQTvs { hsq_explicit = explicit_tvs }) = explicit_tvs +hsQTvExplicit (XLHsQTyVars {}) = panic "hsQTvExplicit" ------------------------------------------------ -- HsOuterTyVarBndrs @@ -356,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) @@ -445,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. @@ -456,9 +444,6 @@ } | XHsSigType !(XXHsSigType pass) -hsPatSigType :: HsPatSigType pass -> LHsType pass -hsPatSigType = hsps_body - {- Note [forall-or-nothing rule] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -689,36 +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 + = HsTvb { tvb_ext :: XTyVarBndr pass + , tvb_flag :: flag + , tvb_var :: HsBndrVar pass + , tvb_kind :: HsBndrKind pass } + | XTyVarBndr + !(XXTyVarBndr pass) - | 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' +data HsBndrVis pass + = HsBndrRequired !(XBndrRequired pass) + -- Binder for a visible (required) variable: + -- type Dup a = (a, a) + -- ^^^ - -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation + | HsBndrInvisible !(XBndrInvisible pass) + -- Binder for an invisible (specified) variable: + -- type KindOf @k (a :: k) = k + -- ^^^ - | XTyVarBndr - !(XXTyVarBndr pass) + | 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 (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] @@ -727,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 @@ -739,157 +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) (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) @@ -902,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] @@ -970,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. @@ -1025,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: @@ -1060,35 +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 -{- -Note [ConDeclField pass] -~~~~~~~~~~~~~~~~~~~~~~~~~ + , cdf_unpack :: SrcUnpackedness + -- ^ UNPACK pragma if any + -- E.g. data T = MkT {-# UNPACK #-} Int + -- or data T where MtT :: {-# UNPACK #-} Int -> T -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_bang :: SrcStrictness + -- ^ User-specified strictness, if any + -- E.g. data T a = MkT !a + -- or data T a where MtT :: !a -> 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_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 - data T = MkT { x :: Int } + , cdf_type :: LHsType pass + -- ^ The type of the field -gives + , cdf_doc :: Maybe (LHsDoc pass) + -- ^ Documentation for the field + -- F.e. this very piece of documentation + } - ConDeclField { cd_fld_names = [L _ (FieldOcc "x" $sel:x:MkT)], ... }. +{- 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 + +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` -} ----------------------- @@ -1112,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] } @@ -1155,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'. -} {- @@ -1181,14 +1215,19 @@ -} -- | Arguments in an expression/type after splitting -data HsArg tm ty - = HsValArg tm -- Argument is an ordinary expression (f arg) - | HsTypeArg SrcSpan ty -- Argument is a visible type application (f @ty) - -- SrcSpan is location of the `@` - | HsArgPar SrcSpan -- See Note [HsArgPar] +data HsArg p tm ty + = 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 (LHsType p) (LHsKind p) +type LHsTypeArg p = HsArg p (LHsType p) (LHsKind p) {- Note [HsArgPar] @@ -1220,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,631 +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 - -/* ----------------------------------------------------------------------------- - 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_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 -#define REG_CCCS 28 - -/* ----------------------------------------------------------------------------- - 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 @@ -799,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,13 +1,17 @@ -{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE NamedFieldPuns #-} module Main where import Distribution.Simple import Distribution.Simple.BuildPaths +import Distribution.Types.ComponentLocalBuildInfo +import Distribution.Types.ComponentName (ComponentName(CLibName)) import Distribution.Types.LocalBuildInfo +import Distribution.Types.LibraryName (LibraryName(LMainLibName)) import Distribution.Verbosity import Distribution.Simple.Program import Distribution.Simple.Utils import Distribution.Simple.Setup +import Distribution.Simple.PackageIndex import System.IO import System.Process @@ -15,6 +19,7 @@ import System.FilePath import Control.Monad import Data.Char +import qualified Data.Map as Map import GHC.ResponseFile import System.Environment @@ -34,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") @@ -47,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 @@ -72,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" @@ -85,9 +93,18 @@ callProcess "deriveConstants" ["--gen-haskell-type","-o",tmp,"--target-os",targetOS] renameFile tmp platformConstantsPath + let cProjectUnitId = case Map.lookup (CLibName LMainLibName) componentNameMap of + 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 - let configHsPath = autogenPackageModulesDir lbi "GHC/Settings/Config.hs" - configHs = generateConfigHs settings + configHsPath = autogenPackageModulesDir lbi "GHC/Settings/Config.hs" + configHs = generateConfigHs cProjectUnitId cGhcInternalUnitId settings createDirectoryIfMissingVerbose verbosity True (takeDirectory configHsPath) rewriteFileEx verbosity configHsPath configHs @@ -98,8 +115,10 @@ Nothing -> Left (show k ++ " not found in settings: " ++ show settings) Just v -> Right v -generateConfigHs :: [(String,String)] -> String -generateConfigHs settings = either error id $ do +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 cGhcInternalUnitId settings = either error id $ do let getSetting' = getSetting $ (("cStage","2"):) settings buildPlatform <- getSetting' "cBuildPlatformString" "Host platform" hostPlatform <- getSetting' "cHostPlatformString" "Target platform" @@ -114,6 +133,8 @@ , " , cProjectName" , " , cBooterVersion" , " , cStage" + , " , cProjectUnitId" + , " , cGhcInternalUnitId" , " ) where" , "" , "import GHC.Prelude.Basic" @@ -134,4 +155,10 @@ , "" , "cStage :: String" , "cStage = show ("++ cStage ++ " :: Int)" + , "" + , "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,6 +9,7 @@ // // 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,9,0,0) // Unique64 patch was present in 9.10 and later #define HAVE_UNIQUE64 1 @@ -20,34 +21,6 @@ #define HAVE_UNIQUE64 1 #endif - #if !defined(HAVE_UNIQUE64) 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) -STATIC_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 -} -#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; -} 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.6.7 +Version: 9.14.1 License: BSD-3-Clause License-File: LICENSE Author: The GHC Team @@ -20,12 +20,16 @@ . 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 extra-source-files: GHC/Builtin/primops.txt.pp - GHC/Builtin/bytearray-ops.txt.pp Unique.h CodeGen.Platform.h -- Shared with rts via hard-link at configure time. This is safer @@ -35,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 + setup-depends: base >= 3 && < 5, Cabal >= 1.6 && <3.14, directory, process, filepath, containers Flag internal-interpreter Description: Build with internal interpreter support. @@ -57,8 +68,31 @@ Description: Use build-tool-depends Default: True +Flag with-libzstd + Default: False + Manual: True + +Flag static-libzstd + Default: False + Manual: True + +-- While the boot compiler fixes ghc's unit-id to `ghc`, the stage0 compiler must still be compiled with `-this-unit-id ghc` +Flag hadrian-stage0 + Description: Enable if compiling the stage0 compiler with hadrian + 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 @@ -66,32 +100,51 @@ 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 - Build-Depends: base >= 4.11 && < 4.19, - deepseq >= 1.4 && < 1.5, + if flag(with-libzstd) + if flag(static-libzstd) + if os(darwin) + buildable: False + else + extra-libraries: :libzstd.a + else + extra-libraries: zstd + CPP-Options: -DHAVE_LIBZSTD + + Build-Depends: base >= 4.11 && < 4.23, + deepseq >= 1.4 && < 1.6, directory >= 1 && < 1.4, process >= 1 && < 1.7, - bytestring >= 0.9 && < 0.12, + 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.20.*, - hpc == 0.6.*, + 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.6.7, - ghc-heap == 9.6.7, - ghci == 9.6.7 + 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 @@ -136,9 +189,10 @@ Include-Dirs: . - -- We need to set the unit id to ghc (without a version number) - -- as it's magic. - GHC-Options: -this-unit-id ghc + if flag(hadrian-stage0) + -- We need to set the unit id to ghc (without a version number) + -- as it's magic. + GHC-Options: -this-unit-id ghc if arch(javascript) js-sources: @@ -155,10 +209,7 @@ -- we use an explicit Prelude Default-Extensions: NoImplicitPrelude - ,BangPatterns - ,ScopedTypeVariables ,MonoLocalBinds - ,TypeOperators Exposed-Modules: GHC @@ -173,6 +224,7 @@ GHC.Builtin.Uniques GHC.Builtin.Utils GHC.ByteCode.Asm + GHC.ByteCode.Breakpoints GHC.ByteCode.InfoTable GHC.ByteCode.Instr GHC.ByteCode.Linker @@ -186,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 @@ -212,6 +264,7 @@ GHC.Cmm.Switch GHC.Cmm.Switch.Implement GHC.Cmm.ThreadSanitizer + GHC.Cmm.UniqueRenamer GHC.CmmToAsm GHC.Cmm.LRegSet GHC.CmmToAsm.AArch64 @@ -232,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 @@ -256,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 @@ -265,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 @@ -283,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 @@ -300,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 @@ -307,6 +383,7 @@ GHC.Core.Opt.Arity GHC.Core.Opt.CallArity GHC.Core.Opt.CallerCC + GHC.Core.Opt.CallerCC.Types GHC.Core.Opt.ConstantFold GHC.Core.Opt.CprAnal GHC.Core.Opt.CSE @@ -322,6 +399,7 @@ GHC.Core.Opt.SetLevels GHC.Core.Opt.Simplify GHC.Core.Opt.Simplify.Env + GHC.Core.Opt.Simplify.Inline GHC.Core.Opt.Simplify.Iteration GHC.Core.Opt.Simplify.Monad GHC.Core.Opt.Simplify.Utils @@ -346,6 +424,7 @@ GHC.CoreToIface GHC.CoreToStg GHC.CoreToStg.Prep + GHC.CoreToStg.AddImplicitBinds GHC.Core.TyCo.FVs GHC.Core.TyCo.Compare GHC.Core.TyCon @@ -372,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 @@ -436,6 +521,9 @@ GHC.Driver.Config.StgToCmm 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 @@ -446,8 +534,11 @@ GHC.Driver.GenerateCgIPEStub GHC.Driver.Hooks GHC.Driver.LlvmConfigCache + GHC.Driver.MakeSem GHC.Driver.Main GHC.Driver.Make + GHC.Driver.Messager + GHC.Driver.MakeAction GHC.Driver.MakeFile GHC.Driver.Monad GHC.Driver.Phases @@ -460,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 @@ -473,6 +567,7 @@ GHC.Hs.Instances GHC.Hs.Lit GHC.Hs.Pat + GHC.Hs.Specificity GHC.Hs.Stats GHC.HsToCore GHC.HsToCore.Arrows @@ -489,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 @@ -511,8 +607,11 @@ GHC.Hs.Type GHC.Hs.Utils GHC.Iface.Binary + GHC.Iface.Decl GHC.Iface.Env GHC.Iface.Errors + GHC.Iface.Errors.Types + GHC.Iface.Errors.Ppr GHC.Iface.Ext.Ast GHC.Iface.Ext.Binary GHC.Iface.Ext.Debug @@ -524,19 +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.Linker GHC.Linker.Config + GHC.Linker.Deps GHC.Linker.Dynamic + GHC.Linker.External GHC.Linker.ExtraObj GHC.Linker.Loader GHC.Linker.MacOS @@ -558,23 +667,29 @@ 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.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.LoongArch64 GHC.Platform.S390X GHC.Platform.Wasm32 GHC.Platform.Ways @@ -597,13 +712,20 @@ 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 GHC.Settings.Config GHC.Settings.Constants @@ -611,16 +733,18 @@ 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 GHC.Stg.Lift.Config 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 @@ -656,7 +780,6 @@ GHC.StgToJS.Arg GHC.StgToJS.Closure GHC.StgToJS.CodeGen - GHC.StgToJS.CoreUtils GHC.StgToJS.DataCon GHC.StgToJS.Deps GHC.StgToJS.Expr @@ -669,27 +792,27 @@ GHC.StgToJS.Object GHC.StgToJS.Prim GHC.StgToJS.Profiling - GHC.StgToJS.Printer 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.StgUtils GHC.StgToJS.Symbols GHC.StgToJS.Types GHC.StgToJS.Utils GHC.StgToJS.Linker.Linker GHC.StgToJS.Linker.Types GHC.StgToJS.Linker.Utils + GHC.StgToJS.Linker.Opt GHC.Stg.Unarise GHC.SysTools GHC.SysTools.Ar GHC.SysTools.BaseDir GHC.SysTools.Cpp GHC.SysTools.Elf - GHC.SysTools.Info GHC.SysTools.Process GHC.SysTools.Tasks GHC.SysTools.Terminal @@ -702,13 +825,16 @@ GHC.Tc.Errors GHC.Tc.Errors.Hole GHC.Tc.Errors.Hole.FitTypes + GHC.Tc.Errors.Hole.Plugin GHC.Tc.Errors.Ppr GHC.Tc.Errors.Types + GHC.Tc.Errors.Types.PromotionErr GHC.Tc.Gen.Annotation GHC.Tc.Gen.App 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 @@ -716,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 @@ -726,10 +851,13 @@ GHC.Tc.Module GHC.Tc.Plugin GHC.Tc.Solver - GHC.Tc.Solver.Canonical + GHC.Tc.Solver.Default GHC.Tc.Solver.Rewrite GHC.Tc.Solver.InertSet - GHC.Tc.Solver.Interact + GHC.Tc.Solver.Solve + GHC.Tc.Solver.Irred + GHC.Tc.Solver.Equality + GHC.Tc.Solver.Dict GHC.Tc.Solver.Monad GHC.Tc.Solver.Types GHC.Tc.TyCl @@ -741,9 +869,14 @@ 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.CtLoc + GHC.Tc.Types.ErrCtxt + GHC.Tc.Types.LclEnv + GHC.Tc.Types.TH + GHC.Tc.Types.TcRef + GHC.Tc.Types.BasicTypes GHC.Tc.Utils.Backpack GHC.Tc.Utils.Concrete GHC.Tc.Utils.Env @@ -752,17 +885,20 @@ GHC.Tc.Utils.TcMType GHC.Tc.Utils.TcType GHC.Tc.Utils.Unify - GHC.Tc.Utils.Zonk GHC.Tc.Validity + GHC.Tc.Zonk.Env + GHC.Tc.Zonk.Monad + GHC.Tc.Zonk.TcType + GHC.Tc.Zonk.Type GHC.ThToHs 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 @@ -771,11 +907,13 @@ GHC.Types.Fixity.Env GHC.Types.ForeignCall GHC.Types.ForeignStubs + GHC.Types.GREInfo GHC.Types.Hint GHC.Types.Hint.Ppr GHC.Types.HpcInfo GHC.Types.Id GHC.Types.IPE + GHC.Types.ThLevelIndex GHC.Types.Id.Info GHC.Types.Id.Make GHC.Types.Literal @@ -792,9 +930,11 @@ GHC.Types.ProfAuto GHC.Types.RepType GHC.Types.SafeHaskell + GHC.Types.SaneDouble GHC.Types.SourceError GHC.Types.SourceFile GHC.Types.SourceText + GHC.Types.SptEntry GHC.Types.SrcLoc GHC.Types.Target GHC.Types.Tickish @@ -803,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 @@ -818,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 @@ -856,6 +1001,7 @@ GHC.Utils.Logger GHC.Utils.Misc GHC.Utils.Monad + GHC.Utils.Monad.Codensity GHC.Utils.Monad.State.Strict GHC.Utils.Outputable GHC.Utils.Panic @@ -863,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 @@ -877,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 -}